      program LCASSCF
      use mod_lirorb
!     
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     Optimisation d'orbitales locales
!     programme pilotant les appels a
!     - rasscf a partir des orbitales INPORB (=LOCORB)
!     - proj_scf pour recuperer des orbitales locales      
!     
!     en entree:
!     liste de donnees (voir plus bas)
!     un fichier d'orbitales de nom "INPORB"
!     
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter (maxsym=8,maxorb=1024,maxorbcas=16,maxet=100)
      dimension numac(maxorbcas),numacv(maxorbcas),numac0(maxorbcas)
      integer fermi(maxsym),frozen(maxsym),delete(maxsym)
      dimension netat(maxet),metat(maxet),coef(maxet),isym(maxsym)
      dimension e(maxet),y(maxorb),ev(maxet)
      dimension nocs(0:maxsym),nvirs(0:maxsym)
      dimension nacos(0:maxsym),nacvs(0:maxsym)
      character(1) syspin
      character(8) gener,progr,stop
      character(80) prefix
      character(80) pgm,casdet,casdi,fil(maxet),locnat,filcas(maxet)
     *,molcost
      character(1280) namel
      character(3) num(999)
      character(1) d
      character(3) r
      character(4) data
      character(2) ald
      double precision,allocatable,dimension(:,:) :: u
      character(6),dimension(:),allocatable :: tipo
      double precision,allocatable,dimension(:) :: occup
      integer spin
      r='  >'
      d=' '
      data=' '
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       LCASSCF'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '
      yw=.true.
      include 'pgm.prm0'
      include 'pgm.prm'
c
c-----------------------------------------------------
c     lecture des donnees
c-----------------------------------------------------
c
      call sto5
      call LECNAM('&LCAS ',namel,93,ierr,1)
      if(ierr.eq.1) then
         print*,'namelist LCAS non trouvee'
         stop
      endif
      call namela(namel,PREFIX,'PREFIX')
      nmat=1
      fermi=0
      frozen=0
      delete=0
      seuil=1.d-4
      molcas=0
      stop=' '
      call nameli(namel,molcas,'MOLCAS',4)
      call nameli(namel,FERMI,'FERMI',4)
      call nameli(namel,FROZEN,'FROZEN',4)
      call nameli(namel,DELETE,'DELETE',4)
      call nameli(namel,NMAT,'NMAT',4)
      netat(1:nmat)=1
      call nameli(namel,NETAT,'NETAT',4)
      netatot=sum(netat(1:nmat))
      metat(1:netatot)=1
      call nameli(namel,METAT,'METAT',4)
      coef(1:netatot)=1.d0
      call nameld(namel,coef,'COEF',8)
      call nameld(namel,SEUIL,'SEUIL',8)
      open(4,status='old',form='unformatted',file='S2')
      read(4) nsym,isym(1:nsym),progr
      call namela(namel,R,'R')
      call namela(namel,STOP,'STOP')
      call namela(namel,DATA,'DATA')
c
c-----------------------------------------------------
c     fabrication des donnees
c-----------------------------------------------------
c
      if(nmat.ge.100) then
         print*,'nmat trop grand', nmat
      endif
      do k=1,max(nmat,maxit)
         write(num(k),'(''00'',i1)') k
      enddo
      do k=10,max(nmat,maxit)
         write(num(k),'(''0'',i2)') k
      enddo
      do k=100,max(nmat,maxit)
         write(num(k),'(i3)') k
      enddo
c     si data='AUTO', fermi,frozen,delete et noac sont mis a -1
      if(data.eq.'AUTO') then
         fermi=-1
         frozen=-1
         delete=-1
         noac=-1
      endif
c     si frozen-1 ou delete=-1 ces donnees sont a chercher dans INPORB
      call lirorb('INPORB',norb,nsym,isym,51,54)
      do is=1,2*nsym
         read(51)
      enddo
      yfr=frozen(1)==-1
      ydel=delete(1)==-1
      do is=1,nsym
         allocate(tipo(isym(is)))
         read(51) tipo
c        si frozen est donne a -1, on prend les valeurs definies dans 
c        schmudorb. On modifie alors fermi
         if(yfr) then
            frozen(is)=0
            do k=1,fermi(is)
               if(tipo(k)(1:2)=='G_') frozen(is)=frozen(is)+1
            enddo
         endif
c            print*,'fermi',fermi
c            print*,'frozen',frozen
c            stop
c        si delete est donne a -1, on prend les valeurs definies dans 
c        schmudorb
         if(ydel) then
            delete(is)=0
            do k=1+fermi(is),isym(is)
               if(tipo(k)(1:2)=='G_') delete(is)=delete(is)+1
            enddo
         endif
         deallocate(tipo)
      enddo
      if(yfr) fermi(1:nsym)=fermi(1:nsym)-frozen(1:nsym)
c-------
c
c------------------------------------------------------------------
c     fabrication du premier fichier de donnees IN0
c     Ce sont les donnees communes pour tous les etats
c------------------------------------------------------------------
c
      nocs(0)=0
      nvirs(0)=0
      nocs(1:nsym)=frozen(1:nsym)+fermi(1:nsym)
      nvirs(1:nsym)=isym(1:nsym)-nocs(1:nsym)
c      print*,'nocs',nocs(1:nsym)
c      print*,'nvirs',nvirs(1:nsym)
      do k=2,nsym
         nocs(k)=nocs(k)+nocs(k-1)
         nvirs(k)=nvirs(k)+nvirs(k-1)
      enddo
      noc=nocs(nsym)
      nvir=nvirs(nsym)
      norb=noc+nvir
      if(yw)print*,'nocs',nocs(1:nsym)
      if(yw)print*,'nvirs',nvirs(1:nsym)
      if(yw)print*,'fermi',fermi(1:nsym)
      if(yw)print*,'frozen',frozen(1:nsym)
      if(yw)print*,'delete',delete(1:nsym)
      if(yw)print*,'fermi',fermi(1:nsym)
      open(2,file='IN0',status='unknown')
c     donnees motra
      write(2,'(a)') ' &cost '
      write(2,'(2a)') ' prefix=''',prefix(1:len_trim(prefix))//''''
      write(2,'(a)') ' ymo=f'
      write(2,'(a)') ' /'
c     donnees proj_scf
      write(2,'(a)') ' &pscf'
      write(2,'(2a)') ' prefix=''',prefix(1:len_trim(prefix))//''''
      write(2,'(a)') ' calcul=''CASSCF'''
!      write(1,'(a,i5,1h,i5,1h,') ' fermi=',nocs(1:nsym)-nocs(0:nsym-1)
      write(2,'(a,8(i5,1h,))') ' fermi=',nocs(1:nsym)-nocs(0:nsym-1)
      write(2,'(a)') ' /'
      
      
      ifin=0
      syspin='0'
      iprec=6
      nessai=0
      nvec=1
      noac=0
      if(data.eq.'AUTO') noac=-1
      nelac=0
      numac=0
      ms2=0
      is0=1
c
c------------------------------------------------------------------
c     Generation des fichiers de donnees pour les calculs multiples
c     les fichiers s'appellent INi i=1,2,...,nmat
c------------------------------------------------------------------
c
      do imat=1,nmat
         if(imat.le.9) then
            write(ald(1:1),'(i1)') imat
            lald=1
         else
            write(ald,'(i2)') imat
            lald=2
         endif
         ideb=ifin+1
         ifin=ideb+netat(imat)-1
         do ibid=1,imat-1
            call LECNAM('&LC ',namel,93,ierr,0)
         enddo
         call LECNAM('&LC ',namel,93,ierr,1)
         if(ierr.eq.1) then
            print*,'namelist LC non trouvee'
            stop
         endif
         call nameli(namel,NOAC,'NOAC',4)
         call nameli(namel,NUMAC,'NUMAC',4)
         call nameli(namel,NELAC,'NELAC',4)
         call nameli(namel,SPIN,'SPIN',4)
         call nameli(namel,IS0,'IS0',4)
         if(yw)print*,'noac',noac
         if(yw)print*,'nelac',nelac
         if(yw)print*,'numac',numac
c
c        si noac=-1, on genere noac, numac, nelac a partir de INPORB
c
         if(noac.eq.-1) then
!            open(51,file='SCH_INFO',status='old',form='unformatted')
!            read(51)
!            read(51)noacv,numacv(1:noacv)
            do is=1,nsym
               backspace(51)
            enddo
            kk=0
            noac=0
            do is=1,nsym
               allocate(tipo(isym(is)))
               read(51) tipo
               do k=frozen(is)+1,frozen(is)+fermi(is)
                  kk=kk+1
                  if(tipo(k)(1:2)=='A_') then
                     noac=noac+1
                     numac(noac)=kk
                  endif
               enddo
               deallocate(tipo)
            enddo
            do is=1,nsym
               backspace(51)
            enddo
            do is=1,nsym
               allocate(tipo(isym(is)))
               read(51) tipo
               do k=frozen(is)+fermi(is)+1,isym(is)-delete(is)
                  kk=kk+1
                  if(tipo(k)(1:2)=='A_') then
                     noac=noac+1
                     numac(noac)=kk
                  endif
               enddo
               deallocate(tipo)
            enddo
            close(51,status='delete')
c            print*,'noacv',noacv
c            print*,'numacv',numacv(1:noacv)
            nocs(0)=0
            nvirs(0)=0
            nocs(1:nsym)=frozen(1:nsym)+fermi(1:nsym)
            nvirs(1:nsym)=isym(1:nsym)-nocs(1:nsym)
c            print*,'nocs',nocs(1:nsym)
c            print*,'nvirs',nvirs(1:nsym)
            do k=2,nsym
               nocs(k)=nocs(k)+nocs(k-1)
               nvirs(k)=nvirs(k)+nvirs(k-1)
            enddo
            noc=nocs(nsym)
            nvir=nvirs(nsym)
            norb=noc+nvir
            if(yw)print*,'nocs',nocs(1:nsym)
            if(yw)print*,'nvirs',nvirs(1:nsym)
            if(yw)print*,'fermi',fermi(1:nsym)
            if(yw)print*,'frozen',frozen(1:nsym)
            if(yw)print*,'delete',delete(1:nsym)
            if(yw)print*,'fermi',fermi(1:nsym)
!            y=.false.
!            y(numacv(1:noacv))=.true.
!            if(yw)print'('' y'',100l1)',y
!            
!            numacv est donne dans la numerotation sans fermi
!            on le modifie
!            nacos=0
!            nacvs=0
!            kk=0
!            do is=1,nsym
!               kk=kk+frozen(is)
!               do k=nocs(is-1)+1,nocs(is)-frozen(is)
!                  kk=kk+1
!                  if(y(kk)) nacos(is)=nacos(is)+1
!               enddo
!               kk=kk+nvirs(is)-nvirs(is-1)
!            enddo
!            kk=0
!            do is=1,nsym
!               kk=kk+nocs(is)-nocs(is-1)
!               do k=nvirs(is-1)+1,nvirs(is)-delete(is)
!                  kk=kk+1
!                  if(y(kk)) nacvs(is)=nacvs(is)+1
!               enddo
!               kk=kk+delete(is)
!            enddo
!            if(yw)print*,'nacos',nacos(1:nsym)
!            if(yw)print*,'nacvs',nacvs(1:nsym)
!            y=.false.
!            issgt=sum(frozen(1:nsym))
!            do is=1,nsym
!               issg=sum(frozen(1:is))
!               y(nocs(is)-nacos(is)+1-issg:nocs(is)-issg)=.true.
!               issd=sum(delete(1:is-1))
!               y(noc+nvirs(is-1)+1-issd-issgt:noc+nvirs(is-1)+nacvs(is)
!     *         -issd-issgt)=.true.
!            enddo
!            noac=0
!            do k=1,norb
!               if(y(k)) then
!                  if(yw)print*,'act',k
!                  noac=noac+1
!                  numac(noac)=k
!               endif
!            enddo
! 
!             print'(a,i2)',' noac=',noac
!            close(51)
         endif
            print*,'noac',noac
            print*,'numac',numac(1:noac)
         fil(imat)=' '
         filcas(imat)=' '
         fil(imat)(1:2)='IN'
         filcas(imat)(1:2)='CA'
         if(imat.lt.10) then
            write(fil(imat)(3:3),'(i1)') imat
            write(filcas(imat)(3:3),'(i1)') imat
            open(1,file=fil(imat),status='unknown')
            if(ypertu) open(2,file=filcas(imat),status='unknown')
c            print*,'file1',fil(imat)
         else
            write(fil(imat)(3:4),'(i2)') imat
            write(filcas(imat)(3:4),'(i2)') imat
            open(1,file=fil(imat),status='unknown')
            if(ypertu) open(2,file=filcas(imat),status='unknown')
         endif
         print*,'nocs',nocs(1:nsym)
         print*,'nacos',nacos(1:nsym)
c        fichiers de donnees pour rasscf 
         write(1,'(a)') ' &RASSCF &END'
         write(1,'(a)') 'Title'
         write(1,'(a)') prefix(1:len_trim(prefix)-1)
         write(1,'(a)') 'Symmetry'
         write(1,'(i2)') is0
         write(1,'(a)') 'Spin'
         write(1,'(i2)') spin
         write(1,'(a)') 'Frozen'
         write(1,'(8i5)') frozen(1:nsym)
         write(1,'(a)') 'Delete'
         write(1,'(8i5)') Delete(1:nsym)
         write(1,'(a)') 'NactEl'
         write(1,'(3i5)') nelac,0,0
         write(1,'(a)') 'Inactive'
         write(1,'(8i5)') nocs(1:nsym)-nocs(0:nsym-1)
     *   -frozen(1:nsym)-nacos(1:nsym)
         write(1,'(a)') 'Ras2'
         write(1,'(8i5)') nacos(1:nsym)+nacvs(1:nsym)
         write(1,'(a)') 'Iterations'
         write(1,'(a)') '50 50'
         write(1,'(a)') 'Lumorb'
         write(1,'(a)') 'thrs'
         write(1,'(a)') ' 1.0e-06  1.0e-05   1.0e-05'
         write(1,'(a)') 'End of Input'
         write(1,'(a)') ' &RASREAD &END'
         write(1,'(a)') 'Average Orbitals'
         write(1,'(a)') 'End of Input'
         close(1)
      enddo
c
c---------------------------
c     calculs faits une fois
c---------------------------
c
c     fabrication du script xx0
      open(10,file='xx0',status='unknown')
      write(namel,'(a)') 'molcost02 < IN0  '//r//' molcostout001'
      write(10,'(a)') namel(1:len_trim(namel))
      if(r.ne.' # ')write(10,'(a)') 'cp molcostout001 MOLCSD.OUT'
      if(yw)print*,'stop ',stop
      if(stop.eq.'MOLCOST') write(10,'(a)') 'exit'
c      print*,'nmat2',nmat
c
c---------------------------
c     calculs faits nmat fois
c---------------------------
c
      do imat=1,nmat
         namel=' '
         write(10,'(a)')
     *   'molcas run rasscf '//trim(fil(imat))//r//' rasout001 2>&1'
         if(r.ne.' # ')write(10,'(a)') 'cp rasout001 RAS.OUT'
         write(10,'(a)')
     *   'molcas run rasread '
     *   //trim(fil(imat))//r//' rasreadout001 2>&1'
         if(r.ne.' # ')write(10,'(a)') 'cp rasreadout001 RASREAD.OUT'
      enddo
c
c--------------------------------
c     moyenne des solutions (a faire)
c--------------------------------
c
c
c--------------------------------
c     localisation par projection
c--------------------------------
c
      write(10,'(a)') 'proj_scf02 < IN0'
      write(10,'(a)') 'cp OAO_scf OAO'
      write(10,'(a)') 'schmudort < IN0'
      write(10,'(a)') 'cp LOCORB LOCORB2'
         

      close(10)
      write(2,'(a)') ' &ort / '
      close(2)
      call system('chmod +x xx0')
      call system('./xx0')
      end
      
      
