      program LOCAS
      use mod_lirorb
!     
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     Optimisation d'orbitales locales
!     programme pilotant les appels a
!     - rasscf - proj_scf
!     
!     en entree:
!     liste de donnees (voir plus bas)
!     un fichier d'orbitales locales non orthogonales de nom "NONORLOC"
!     un fichier d'orbitales locales orthogonales de nom "INPORB"
!     - le fichier INPORB va servir pour demarrer le RASSCF
!     - le fichier NONORLOC sert a la fin pour relocaliser la solution
!       trouvee par RASSCF
!     Rem 1 : les orbitales de INPORB son necessairement orthogonales,
!     mais il n'y a aucune condition pour NONORLOC. Rien n'empeche de
!     recopier INPORB dans NONORLOC et de donner donc deux fois le meme
!     fichier.
!     Rem 2 : en general, INPORB est obtenu a partir de NONORLOC par
!     orthogonalisation (par schmudort par exemple)
!     
!     Les labels des orbitales moleculaires sont indispensables. Ils
!     determinent les orbitales actives, gelees, etc..., c'est-a-dire
!     les classes pour l'orthogonalisation schmudort. Il sont lus dans
!     inporb et doivent donc necessairement y figurer.
!  
!     en sortie:
!     un fichier d'orbitales locales orthogonales INPORB2
!     
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter (maxsym=8,maxorb=255,maxorbcas=16,maxet=100,maxrac=50)
      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(maxrac,maxet)
      !dimension nocs(0:maxsym),nvirs(0:maxsym)
      dimension nacos(0:maxsym),nacvs(0:maxsym)
      character*1 syspin
      character*8 gener,stop
      character*80 prefix
      character*80 pgm,fil(maxet),filcas(maxet)
     *,proj_scf,schmudort
     *,aa(100)
      character*1280 namel
      character*3 num(999)
      character*1 d
      character*3 r
      character*4 data
      character*2 ald
      character(18),allocatable,dimension(:) :: tipo
      integer spin,inac(maxsym),ras2(maxsym)
      r='  >'
      d=' '
      nprint=0
      data='AUTO'
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       LOCAS'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '
      yw=.false.
      include 'pgm.prm'
      maxit=50
c
c-----------------------------------------------------
c     lecture des donnees
c-----------------------------------------------------
c
      call sto5
      call LECNAM('&LOCAS ',namel,93,ierr,1)
      if(ierr.eq.1) then
         print*,'namelist LOCAS non trouvee'
         stop
      endif
      call namela(namel,PREFIX,'PREFIX')
      nmat=1
      fermi=0
      frozen=0
      delete=0
      seuil=1.d-4
      stop=' '
      call nameli(namel,NPRINT,'NPRINT',4)
      call nameli(namel,FERMI,'FERMI',4)
      call nameli(namel,FROZEN,'FROZEN',4)
      call nameli(namel,DELETE,'DELETE',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)
      call namela(namel,R,'R')
      call namela(namel,STOP,'STOP')
      call namela(namel,DATA,'DATA')
      !
      ! Lecture des donnees rasscf
      !
      rewind 93
      call LECNAM('&RAS ',namel,93,ierr,1)
      nl=0
      yrasinac=.true.
      yrasfro=.true.
      yrasdel=.true.
      yrasnactel=.true.
      yrasras1=.true.
      yrasras2=.true.
      yrasras3=.true.
      yrasthr=.true.
      yrassym=.true.
      yrasspin=.true.
      do
         nl=nl+1
         read(93,'(a80)') aa(nl)
         call maj(aa(nl),80)
         if(index(aa(nl),'INAC').ne.0) yrasinac=.false.
         if(index(aa(nl),'FROZ').ne.0) yrasfro=.false.
         if(index(aa(nl),'DELE').ne.0) yrasdel=.false.
         if(index(aa(nl),'NACT').ne.0) yrasnactel=.false.
         if(index(aa(nl),'RAS1').ne.0) yrasras1=.false.
         if(index(aa(nl),'RAS2').ne.0) yrasras2=.false.
         if(index(aa(nl),'RAS3').ne.0) yrasras3=.false.
         if(index(aa(nl),'THR').ne.0) yrasthr=.false.
         if(index(aa(nl),'SYMM').ne.0) yrasSYM=.false.
         if(index(aa(nl),'SPIN').ne.0) yrasSPIN=.false.
         if(index(aa(nl),'END').ne.0) exit
      enddo
      ystop=.false.
      if(yrassym) then
         print*,'Vous devez donner SYMMETRY'
         ystop=.true.
      endif
      if(yrasSPIN) then
         print*,'Vous devez donner SPIN'
         ystop=.true.
      endif
      if(yrasnactel) then
         print*,'Vous devez donner NACTEL'
         ystop=.true.
      endif
      if(ystop) stop
c
c-----------------------------------------------------
c     fabrication des donnees
c-----------------------------------------------------
c
      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 fermi est donne a -1, on prend les valeurs definies dans 
c     schmudorb
      if(fermi(1)==-1) then
         open(51,file='SCH_FERMI',status='old',form='formatted')
         call lecnam('&FERM',namel,51,ierr,1)
         call nameli(namel,FERMI,'FERMI',4)
         close(51)
      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        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-------
      noac=0
      if(data.eq.'AUTO') noac=-1
      nelac=0
      numac=0
c
c        si noac=-1, on genere noac, numac, nelac a partir de INPORB
c
         if(noac.eq.-1) then
            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,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')
!            nocs(0)=0
!            nvirs(0)=0
!            nocs(1:nsym)=frozen(1:nsym)+fermi(1:nsym)
!            nvirs(1:nsym)=isym(1:nsym)-nocs(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)
         endif
c     fabrication du premier fichier de donnees LOIN0
      open(1,file='LOIN0',status='unknown')
      ! calcul de ras2 et de inac a partir de numac
      y=.false.
      y(numac(1:noac))=.true.
      ras2=0
      inac=fermi
      kk=0
      do is=1,nsym
         do k=1,isym(is)-frozen(is)-delete(is)
            kk=kk+1
            if(y(kk)) then
               ras2(is)=ras2(is)+1
               if(k<=fermi(is)) inac(is)=inac(is)-1
            endif
         enddo
      enddo
      !print*,'numac',numac
      !print*,'y',y
      !print*,'fermi',fermi
      !print*,'isym',isym-frozen-delete
c     donnees rasscf
      write(6,'(a)') ' &rasscf &end'
      write(6,'(a)') 'title'
      write(6,'(a)') prefix(1:len_trim(prefix))
      if(yrasfro)write(6,'(a)') 'frozen'
      if(yrasfro)write(6,'(8i5)')frozen(1:nsym)
      if(yrasdel)write(6,'(a)') 'delete'
      if(yrasdel)write(6,'(8i5)')delete(1:nsym)
      if(yrasinac)write(6,'(a)') 'inactive'
      if(yrasinac)write(6,'(8i5)')inac(1:nsym)
      if(yrasras2)write(6,'(a)') 'ras2'
      if(yrasras2)write(6,'(8i5)')ras2(1:nsym)
      write(1,'(a)') ' &rasscf &end'
      write(1,'(a)') 'title'
      write(1,'(a)') prefix(1:len_trim(prefix))
      if(yrasfro)write(1,'(a)') 'frozen'
      if(yrasfro)write(1,'(8i5)')frozen(1:nsym)
      if(yrasdel)write(1,'(a)') 'delete'
      if(yrasdel)write(1,'(8i5)')delete(1:nsym)
      if(yrasinac)write(1,'(a)') 'inactive'
      if(yrasinac)write(1,'(8i5)')inac(1:nsym)
      if(yrasras2)write(1,'(a)') 'ras2'
      if(yrasras2)write(1,'(8i5)')ras2(1:nsym)
      write(1,'(a)')'lumorb'
      do k=1,nl
         write(1,'(a)') aa(k)(1:len_trim(aa(k)))
         write(6,'(a)') aa(k)(1:len_trim(aa(k)))
      enddo
      write(1,'(a)') ' &rasread &end'
      write(6,'(a)') ' &rasread &end'
      write(1,'(a)') 'Average Orbitals'
      write(6,'(a)') 'Average Orbitals'
      write(1,'(a)') 'End of input'
      write(6,'(a)') 'End of input'
      write(1,'(a)') " &pscf prefix='"//trim(prefix)//
     *"',scforb='CASORB',calcul='CASSCF'"
      write(6,'(a)') " &pscf prefix='"//trim(prefix)//
     *"',scforb='CASORB',calcul='CASSCF'"
      write(1,'(a,8(i4,'',''))')' fermi=',fermi(1:nsym)+frozen(1:nsym)
      write(6,'(a,8(i4,'',''))')' fermi=',fermi(1:nsym)+frozen(1:nsym)
!      write(1,'(a,8(i4,'',''))')' frozen=',frozen(1:nsym)
!      write(6,'(a,8(i4,'',''))')' frozen=',frozen(1:nsym)
!      write(1,'(a,8(i4,'',''))')' delete=',delete(1:nsym)
!      write(6,'(a,8(i4,'',''))')' delete=',delete(1:nsym)
      write(1,'(a,i1)')' nprint=',nprint
      write(6,'(a,i1)')' nprint=',nprint
      write(1,'(a)') ' /'
      write(6,'(a)') ' /'
      write(1,'(a)') ' &ort '
      write(6,'(a)') ' &ort '
      write(1,'(a,i1)')' nprint=',nprint
      write(6,'(a,i1)')' nprint=',nprint
      write(1,'(a)') ' /'
      write(6,'(a)') ' /'
         !print*,'numac',numac(1:noac)
c------------------------------
c     fabrication du script xx0
c------------------------------
       iter=1
         open(10,file='xx0',status='unknown')
         namel=' '
         write(10,'(a)')
     *   'molcas run rasscf LOIN0  '//r//' rasscfout'//num(iter)//
     *   ' 2>&1'
         write(10,'(a)')
     *   'molcas run rasread LOIN0  '//r//' rasreadout'//num(iter)//
     *   ' 2>&1'
         write(10,'(a)') 'rm CASORB'

         write(10,'(a)') 'cp '//trim(prefix)//'RasOrb CASORB'
         if(stop=='RASSCF') write(10,'(a)') 'exit'
         write(10,'(a)') trim(proj_scf)//' < LOIN0 '//r//' proj_out'
     *   //num(iter)//' 2>&1'
         write(10,'(a)') 'cp NONORLOC_scf NONORLOC'
         write(10,'(a)') 
     *   trim(schmudort)//' < LOIN0 '//r//' schmudortout'
     *   //num(iter)//' 2>&1'
         write(10,'(a)') 'cp LOCORB LOCORB2'
         close(10)
         call system('chmod +x xx0')
         call system('./xx0')
      end
      
      
