      program desymorb0
      use mod_lirorb
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(80) aa
      character(300) info,info1,mono,mono1,prefix
      character(10000) namel
      character(20) symm
      character(21) cdate
      integer fermi(8),frozen(8),isym(8)
      character(18),allocatable :: label(:)
      character(3) cc
      logical yinfo,ymono
      call titre('DESYMORB  DESYMORB  DESYMORB  DESYMORB#',60)
!
! Lecture des donnees
!
      info='Info'
      mono='Mono'
      fermi=0
      frozen=0
      yinfo=.true.
      ymono=.true.
      info1=' '
      mono1=' '
      call LECNAM('&DESYMORB ',namel,5,ierr,1)
      call namela(namel,prefix,'PREFIX')
      call namell(namel,YINFO,'YINFO',4)
      call namell(namel,YMONO,'YMONO',4)
      call nameli(namel,NPRINT,'NPRINT',4)
      call nameli(namel,FERMI,'FERMI',4)
!      call nameli(namel,FROZEN,'FROZEN',4)
      call namela(namel,MONO1,'MONO1')
      call namela(namel,MONO,'MONO')
      call namela(namel,INFO1,'INFO1')
      call namela(namel,INFO,'INFO')
      call namela(namel,SYMM,'SYMM')
      if(info1==' ') info1=trim(prefix)//trim(info)
      if(mono1==' ') mono1=trim(prefix)//trim(mono)
      open(93,file='BID93',status='unknown')
      write(93,'(a)') ' &IJKLOC'
      write(93,'(2a)') " prefix='",trim(prefix)//"'"
      write(93,'(2a)') " symm='",trim(symm)//"'"
      !write(93,'(2a)')  "stop='DESYMORB'"
      write(93,'(a,i1)') 'nprint=',nprint
      write(93,'(a)') ' /'
      open(1,file='SCH_FERMI',status='unknown')
      write(1,'(a,8(i3,","))') ' &ferm fermi=',fermi+frozen
      write(1,'(a)') ' /'
      close(1)
      


C      do
C         read(5,'(a80)',end=1000) aa
C         write(93,'(a)') aa
C      enddo
C 1000 continue
      rewind 93
      call desymorb('DESYMORB')
      !call lisfiles
      close(10,status='delete')
      close(93,status='delete')
      if(yinfo) call desyminfo(info1,symm)
      if(ymono) call desymmono(mono1)
!      if(all(frozen==0)) stop
!!
!! Si frozen est en donnee :
!!
!      !call lisfiles
!      call lirorb('DESYMORB',noa,nsym,isym,4,1,ifiloc=8,ifillab=10)
!      namel='FROZEN est en donnee :#Modification des labels des'//
!     *' orbitales#Frozen='
!      l=len_trim(namel)
!      write(namel(l+1:),'(8i4)') frozen(1:nsym)
!      l=len_trim(namel)
!      namel(l+1:l+1)='#'
!      call titre(namel,60)
!      open(1,file='DESYMORB',status='old')
!      close(1,status='delete')
!      !print*,'noa',noa
!      !print*,'nsym',nsym
!      !print*,'isym',isym
!      allocate(label(noa))
!      rewind 10
!      read(10) label
!      do k=1,noa
!         write(cc,'(i3)') k
!         cc=adjustl(cc)
!         read(label(k)(5:5),'(i1)') is
!         if(frozen(is)>0) then
!            frozen(is)=frozen(is)-1
!            label(k)='G_'//trim(label(k))
!         endif
!         label(k)=trim(label(k))//'_'//trim(cc)
!         !print*,label(k)
!      enddo
!      rewind 10
!      write(10) label
!      call ecriorb('* orbitales DESYMORB','DESYMORB',nsym,isym,
!     *4,1,ifiloc=8,ifillab=10)
!      !call lisfiles
!      close(93,status='delete')
!      close(75,status='delete')
!      close(8,status='delete')
!      close(10,status='delete')
!      close(4,status='delete')
      end
       subroutine desyminfo(infofile,symm)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(*) infofile,symm
      character(3) sim(0:7)
      character(100000) namel
      character(4),allocatable,dimension(:) :: atom_old
      character(8),allocatable,dimension(:) :: label
      character(6),allocatable,dimension(:) :: atom_new
      character(10),allocatable,dimension(:) :: label_new
      character(1),allocatable,dimension(:) :: atom_symm,label_symm
      real(8),allocatable,dimension(:,:) :: coor_old,coor_new
      integer,allocatable,dimension(:) :: multat,nbas
      real(8),dimension(3) :: coor_tmp
      integer isym(8)
      logical yet
      real(8) enuc
      character :: cote=''''

      print*,' '
      print*,'-------------------------------'
      print*,'Desymetrisation de la file Info'
      print*,'-------------------------------'
!
! open old and new info files
!
      open(1,file=infofile,status='old')
      open(2,file='DESYMINFO',status='unknown')
!
! read old Info file
!
      call LECNAM('&COST_AO',namel,1,ierr,1)
      call nameli(namel,natom_old,'NATOM',4)
      allocate(atom_old(natom_old))
      call namela(namel,atom_old,'ATOM')
      allocate(coor_old(3,natom_old))
      call nameld(namel,coor_old,'COOR',8)
      allocate(nbas(natom_old))
      allocate(multat(natom_old))
      call nameli(namel,NSYM,'NSYM',4)
      allocate(atom_new(natom_old*nsym))
      allocate(atom_symm(natom_old*nsym))
      allocate(coor_new(3,natom_old*nsym))
      call nameli(namel,ISYM,'ISYM',4)
      call nameli(namel,NORB,'NORB',4)
      call nameld(namel,ENUC,'ENUC',8)
      allocate(label(norb))
      allocate(label_symm(norb))
      allocate(label_new(norb))
      call namela(namel,LABEL,'LABEL')
!
! Generate new atoms and new coordinates
!
!   compute sim (symmetry operations)
      sim=' '
      call symmsim(symm,sim,nsym)
      print*,'symm ',symm
      print*,'sim ',sim
!   for each atom of the short list, generate all symmetry corresponding
!   atoms
      natom_new=0
      nbas(:)=0
      do i=1,natom_old
         multat(i)=0
!   number of basis function of atom i
         do k=1,norb
            if(atom_old(i)==label(k)(1:4)) nbas(i)=nbas(i)+1
         enddo
         print*,'atom_old',i,atom_old(i),nbas(i)
         do is=1,nsym
            coor_tmp=coor_old(:,i)
            if(index(sim(is),'X')>0) coor_tmp(1)=-coor_tmp(1)
            if(index(sim(is),'Y')>0) coor_tmp(2)=-coor_tmp(2)
            if(index(sim(is),'Z')>0) coor_tmp(3)=-coor_tmp(3)
!   verify if the atom was not yet generated
            yet=.false.
            do j=1,natom_new
               yet=(all(abs(coor_tmp(:)-coor_new(:,j))<1.d-8)) 
               if(yet) exit
            enddo
            if(yet) cycle
            natom_new=natom_new+1
            coor_new(:,natom_new)=coor_tmp
            atom_new(natom_new)=atom_old(i)
            if(is>1) then
               atom_new(natom_new)=trim(atom_old(i))
               l=len_trim(atom_new(natom_new))
               !write(atom_new(natom_new)(l+1:),'(a1,i1)') '#',is
            endif
            !write(atom_symm(natom_new),'(i1)') is
            multat(i)=multat(i)+1
         enddo
         print*,'multat',multat(i),atom_new(1:natom_new)
         nbas(i)=nbas(i)/multat(i)
      enddo
!
! Read labels from file DESYMORB2 et transform them
!
      open(3,file='DESYMORB2',status='old',form='unformatted')
      read(3)
      read(3) label
      io=0
      ia=0
      do i=1,natom_old
         do j=1,multat(i)
            ia=ia+1
            do k=1,nbas(i)
               io=io+1
               label_symm(io)=atom_symm(ia)
            enddo
         enddo
      enddo
!
! test write
!
      ia=0
      do i=1,natom_old
         do j=1,multat(i)
            ia=ia+1
            print'(2i4,10x,a4,a6)',i,ia,atom_old(i),atom_new(ia)
         enddo
      enddo
      io=0
      ia=0
      do i=1,natom_old
         do j=1,multat(i)
            ia=ia+1
            do k=1,nbas(i)
               io=io+1
               write(6,'(i4,10x,a8,2x,a1)') io,label(io)!,label_symm(io)
            enddo
         enddo
      enddo
!
! write new desymmetrizied Info file
!
      write(2,'(a)')'============================================='
      write(2,'(a)')'File: DESYMINFO'
      write(2,'(a)')'created by desymorb'
      call cost_date(cdate)
      write(2,'(2a)')'date: ',cdate
      write(2,'(a)')'============================================='
      write(2,'(a)')' &cost_AO'
      write(2,'(a,i4)')' natom=',natom_new
      write(2,'(a)') ' atom='
      write(2,1003) (cote//trim(atom_new(l))
     *//cote,l=1,natom_new)
 1003 format(100(1x,5(a,','),/))
      write(2,'(a,i1)')' nsym=1'
      write(2,1001) ' isym=',norb
 1001 format(a,8(i4,','))
      write(2,'(a6,i5)')' norb=',norb
      write(2,'(a)')' coor='
      do l=1,natom_new
         write(2,'(3(f20.10,'',''))') coor_new(:,l)
      enddo
      write(2,'(a,f20.12)') ' enuc=',enuc
      write(2,'(a)')' label='
      !do l=1,norb
      !   if(label_symm(l)=='1') then
      !      label_new(l)=trim(label(l)(1:4))
      !      label_new(l)(7:10)=label(l)(5:8)
      !      print*,'label_new',label_new(l),l
      !   else
      !      label_new(l)=trim(label(l)(1:4))!//'#'//label_symm(l)
      !      !label_new(l)(7:10)=label(l)(5:8)
      !      print*,'label_new',label_new(l),l
      !   endif
      !enddo
      !write(2,1002) (cote,trim(label_new(l)),cote,l=1,norb)
      write(6,1002) (cote,trim(label(l)),cote,l=1,norb)
      write(2,1002) (cote,trim(label(l)),cote,l=1,norb)
 1002 format(100(1x,5(a1,a,a1,','),/))
      write(2,'(a)')' its=1'
      write(2,'(a)')' jstr=1   /'
      close(1)
      close(2)
      close(3)
      end
       subroutine desymmono(mono1)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(*) mono1
      dimension isym(8)
      real(8),allocatable,dimension(:,:) :: ss
      open(2,file=mono1,status='old',form='unformatted')
      read(2)
      read(2)
      read(2) ndum,nsym,(isym(k),k=1,nsym)
      norb=sum(isym(1:nsym))
      allocate(ss(norb,norb))
      close(2)
      open(2,file='DESYMORB2',status='old',form='unformatted')
      read(2)
      read(2)
      read(2)
      read(2) ss
      call script(ss,norb,norb,norb,norb)
      open(3,file='DESYMMONO',form='unformatted',status='unknown')
      call ecris(3,ss,norb,'DESYMMONO','desymorb',.true.,nsym,isym,
     *(/(k,k=1,norb)/))

      end
