      program proj_scf
      use mod_lirorb
      implicit real(8) (a-h,o-x,z),logical(y)
      parameter (maxsym=8,maxorbcas=30)
      character(100000) namel,namel1
      character(80) prefix,info,mono,locoa,scf
      dimension isym(maxsym)!,ivirt(maxorb)
      dimension nsoc(maxsym),nsal(maxsym)
      double precision,dimension(:),allocatable :: occup
      double precision,dimension(:,:),allocatable :: base,basinv,oscf,
     *u,dum,u1,s
      character(18),dimension(:),allocatable :: tipo
      character(16),dimension(:),allocatable :: pvir,pocc
      character(18),dimension(:),allocatable :: tipol
      integer,dimension(:),allocatable :: iord,jord,npvir,npocc!,ityp_loc
      integer ipocc(maxsym),ipvir(maxsym)
      character(8) orbi(:),calcul,act
      allocatable orbi
      integer fermi(maxsym),numac(maxorbcas),inact(maxsym),nact(maxsym)
      integer frozen(maxsym),delete(maxorbcas)
      allocatable v(:),recou(:)
      logical yprojv
      character(80) nom


      dimension ityp_loc(2000)

      
      allocatable y(:)
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       PROJ_SCF'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '      
      yw=.false.
      nprint=0
      locoa='LOCOA'
      info=' '
      mono=' '
      scf=' '
      fermi=-1
      frozen=0
      delete=0
      inact=0
      nact=0
      calcul='SCF'
      yprojv=.true.
      priorb=0.8d0
c
c---------------------------------------------------------------
c     lecture des donnees
c---------------------------------------------------------------
c
      call LECNAM('&PSCF ',namel,5,ierr,1)
      if(ierr.eq.1) then
         print*,'namelist PSCF non trouvee'
         stop
      endif
      call namela(namel,PREFIX,'PREFIX')
      call namela(namel,LOCOA,'LOCOA')
      call namela(namel,SCF,'SCF')
      call namela(namel,SCF,'SCFORB')
      call namela(namel,INFO,'INFO1')
      call namela(namel,MONO,'MONO1')
      call namela(namel,CALCUL,'CALCUL')
      call nameli(namel,FERMI,'FERMI',4)
      call nameli(namel,FROZEN,'FROZEN',4)
      call nameli(namel,DELETE,'DELETE',4)
      call nameli(namel,NPRINT,'NPRINT',4)
      call namell(namel,YPROJV,'YPROJV',4)
      call nameld(namel,PRIORB,'PRIORB',8)
      if(calcul.eq.'SCF') then
         if(scf.eq.' ') scf=trim(prefix)//'ScfOrb'
      else if(calcul.eq.'CASSCF') then
         if(scf.eq.' ') scf=trim(prefix)//'RasOrb'
      else
         print*,'calcul doit etre egal a SCF ou CASSCF ',trim(calcul)
      endif
      if(info.eq.' ') info=trim(prefix)//'Info'
      if(mono.eq.' ') mono=trim(prefix)//'Mono'
      print*,' '
      print*,'prefix   ',trim(prefix)
      print*,'locoa    ',trim(locoa)
      print*,' les orbitales SCF sont lues dans ',scf
      print*,' '
c     lecture des labels
      open(20,file=info,status='old',form='formatted')
      call LECNAM('&COST_AO ',namel1,20,ierr,min(nprint,1))
c
c---------------------------------------------------------------
c     ouverture et lecture des files
c---------------------------------------------------------------
c
! lecture des orbitales locales non orthogonales
      call lirorb('NONORLOC',norb,nsym,isym,53,54)
      allocate(orbi(norb))
      call namela(namel1,ORBI,'LABEL')
      open(54,status='scratch',form='unformatted')
      open(55,status='scratch',form='unformatted')
      open(56,status='scratch',form='unformatted')
      open(57,status='scratch',form='unformatted')
      open(58,status='scratch',form='unformatted')
      open(59,status='scratch',form='unformatted')
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate(u(ndims,ndims))
         read(53) u(1:ndims,1:ndims)
         if(nprint>=2) then
            print*,' '
            print*,'NONORLOC lu'
            call script(u,ndims,ndims,ndims,ndims)
         endif
         write(54) u(1:ndims,1:ndims)
         deallocate(u)
      enddo
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate(occup(ndims))
         read(53) occup(1:ndims)
         write(55) occup(1:ndims)
         deallocate(occup)
      enddo
      kk=0
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate(tipol(ndims))
         read(53) tipol(1:ndims)
         write(56) tipol(1:ndims)
         deallocate(tipol)
      enddo
      rewind 54
      rewind 55
      rewind 56
      close(53,status='delete')
c     orbitales locales non orthogonales
      print*,'lecture des orbitales non orthogonales (fich NONORLOC)'
c     orbitales scf
      print*,'lecture des orbitales scf'
      call lirorb(scf,norb,nsym,isym,2,1)
c     orbitales atomiques orthogonales
      print*,'orbitales atomiques orthogonales'
      call lirorb(locoa,norb,nsym,isym,3,1)
c
c---------------------------------------------------------------
c     donnees pocc et pvir :
c     orbitales virtuelles dans schmudorb, projetees sur les
c     occupees scf, et vice-versa
c---------------------------------------------------------------
c
      allocate (pvir(norb),pocc(norb))
      allocate (npvir(norb),npocc(norb))
      pvir=' '
      pocc=' '
      ypocc=.false.
      ypvir=.false.
      call namela(namel,POCC,'POCC')
      call namela(namel,PVIR,'PVIR')
      if(calcul=='CASSCF'.and.(pocc(1).ne.' '.or.pvir(1).ne.' ')) then
         print*,
     *   'on ne peut pas utiliser pocc et pvir avec calcul=''CASSCF'''
         stop
      endif
      ipvir=0
      ! Lecture de la symetrie et des numeros des orbitales en donnee
      do k=1,norb
         if(pvir(k)==' ') exit
         call maj(pvir(k),len_trim(pvir(k)))
         ypvir=.true.
         ! symetrie de l'orbitale
         ii=index(pvir(k),';')
         read(pvir(k)(ii+1:ii+1),'(i1)') is
         ipvir(is)=ipvir(is)+1
         ! numero de l'orbitale dans sa symetrie
         ii=ii+2
         if(pvir(k)(ii:ii)==' ') then
            npvir(k)=1
         else
            read(pvir(k)(ii+1:len_trim(pvir(k))),*) npvir(k)
         endif
      enddo
      ipocc=0
      do k=1,norb
         if(pocc(k)==' ') exit
         call maj(pocc(k),len_trim(pocc(k)))
         ypocc=.true.
         ! symetrie de l'orbitale
         ii=index(pocc(k),';')
         read(pocc(k)(ii+1:ii+1),'(i1)') is
         ipocc(is)=ipocc(is)+1
         ! numero de l'orbitale dans sa symetrie
         pocc(k)(ii:ii)=' '
         ii=ii+2
         if(pocc(k)(ii:ii)==' ') then
            npocc(k)=1
         else
            read(pocc(k)(ii+1:len_trim(pocc(k))),*) npocc(k)
         endif
      enddo
      do is=1,nsym
         if(ipocc(is).ne.0) print'(i3,a,i2,a)',
     *   ipocc(is),' virtuelle(s) de symetrie',is,
     *   ' projetee(s) sur les occupees scf'
         if(ipvir(is).ne.0) print'(i3,a,i2,a)'
     *   ,ipvir(is),' occupee(s) de symetrie',is,
     *   ' projetee(s) sur les virtuelles scf'
      enddo
c
c---------------------------------------------------------------
c     le fichier d'orb scf definit un niveau de fermi
c     Le niveau de fermi est aussi defini dans dolo
c     Les deux DOIVENT CORRESPONDRE
c     occupation des obitales scf
c---------------------------------------------------------------
c
      if(calcul.eq.'SCF') then
         if(all(fermi==-1)) then
            print*,' '
            print*,'-------------------------------------------------- '
            print'(a)',
     *      ' FERMI n''est pas donne, on le lit sur SCH_FERMI'
            print'(2a)',
     *      ' Il doit correspondre au niveau de Fermi de ',trim(scf)
            open(12,file='SCH_FERMI',status='old')
            call LECNAM('&FERM ',namel,12,ierr,1)
            if(ierr==0) then
               call nameli(namel,FERMI,'FERMI',4)
               ysch_fermi=.true.
               ! On corrige fermi des orbitales donnees dans pocc et
               ! pvir
               fermi(1:nsym)=fermi(1:nsym)+ipocc(1:nsym)-ipvir(1:nsym)
               if(any(ipocc/=0).or.any(ipvir/=0)) print'(a,8i4)',
     *         'Fermi corrige par pocc et pvir ',fermi(1:nsym)
            else
            print'(a)',
     *         'SCH_FERMI n''existe pas, ',
     *         'on calcule FERMI a partir'//
     *         ' de l''occupation des orb SCF'
               ysch_fermi=.false.
            endif
            rewind 2
            do is=1,nsym
               if(isym(is)==0) cycle
               read(2)
            enddo
            do is=1,nsym
               if(isym(is)==0) cycle
               allocate (occup(isym(is)))
               read(2) occup
               do k=1,isym(is)
                  if(dabs(2.d0-occup(k)).le.1.d-6) then
                     inact(is)=k
                  else if (occup(k).le.1.d-6) then
                  else
                     print*,'***************************************'
                     print*,'ATTENTION'
                     print*,'calcul=''SCF'', et il y a des orbitales'
     *               ,' partiellement occupees dans '
                     print*,trim(SCF)
                     print*,'une orbitale est consideree comme occupee'
     *               //' si elle a plus de 0.1 electron'
                     print*,'***************************************'
                     if(occup(k)>0.1d0) inact(is)=k
                  endif
               enddo
               deallocate (occup)
            enddo
            if(ysch_fermi.and.
     *      any(inact(1:nsym).ne.fermi(1:nsym))) then
               print*,'Il y a contradiction entre FERMI lu dans'//
     *         ' SCH_FERMI'
               print*,'et FERMI trouve dans le fichier ',trim(scf)
               print'(a,8i4)','dans SCH_FERMI',fermi(1:nsym)
               print'(2a,8i4)','dans ',trim(scf),inact(1:nsym)
               print*,'Il faut peut-etre donner fermi dans &pscf'
               print*,'------------------------------------------------'
               stop
            else
               fermi=inact
            endif
            print*,'-------------------------------------------------- '
         else
            inact=fermi
         endif
         print*,' '
      else
         if(all(fermi.eq.-1)) then
            print*,'Calcul=CASSCF : il faut donner FERMI, '
            stop
         endif
         act='A_'
         call namela(namel,ACT,'ACT')
         if(act.ne.'A_') then
            call nameli(namel,NACT,'NACT',4)
            call nameli(namel,NUMAC,'NUMAC',4)
         else
            print*,"act='A_' : les actives sont reperees a partir du"
     *      ," fichier NONORLOC"
         endif
      endif
      if(all(inact.eq.0).and.all(nact.eq.0)) inact=fermi
      if(act.ne.'A_') then
         print'(a,8i3)',' doublement occupees :',inact(1:nsym)
         print'(a,8i3)','             actives :',nact(1:nsym)
         print'(a,8i3)','          virtuelles :',isym(1:nsym)
     *   -nact(1:nsym)-inact(1:nsym)
      endif
      if(any(fermi(1:nsym)==-1)) then
         print*,'donner toutes les symetries pour fermi'
         print'(a,8i5)','fermi=',fermi(1:nsym)
         stop
      endif
c
c---------------------------------------------------------------
c     boucle sur les symetries
c---------------------------------------------------------------
c
      rewind 3
      rewind 2
      print*,' '
      print*,'-------------------------------------------------- '
      print*,'recouvrements des orb projetees avec les anciennes'
      print*,'-------------------------------------------------- '
      print*,' '
      ndimst=0
      do is=1,nsym
         if(is==8) then
                 print*,'debut boucle',is,isym(is)
             endif
         if(isym(is).eq.0) cycle
         ndims=isym(is)
         allocate (base(ndims,ndims))
         allocate (basinv(ndims,ndims))
         allocate (oscf(ndims,ndims))
         allocate (u(ndims,ndims))
         if(yw)allocate (dum(ndims,ndims))
         allocate (occup(ndims),tipo(ndims))
         allocate (recou(ndims))
         allocate (iord(ndims))
         allocate (jord(ndims))
         allocate (y(ndims))
         u=0.d0
         occup=0.d0
         read(3) base
c        P**-1
         call invert(base,basinv,ndims)
         !print*,'verif prog inversion'
         !u=matmul(base,basinv)
         !call script(u,ndims,ndims,ndims,ndims)
         !do k=1,ndims
         !   if(abs(u(k,k)-1.d0)>1.d-6) print*,'err',k
         !enddo
         if(nprint.eq.2) print*,'basinv (inv de la mat OAO)'
         if(nprint.ge.2) call script(basinv,ndims,ndims,ndims,ndims)
         read(2) oscf
         !
         ! mise a zero des orbitales gelees et detruites
         !
         oscf(:,1:frozen(is))=0.d0
         oscf(:,ndims-delete(is)+1:ndims)=0.d0
         !
         if(nprint.ge.2) print*,'orbitales SCF lues'
         if(nprint.ge.2) call script(oscf,ndims,ndims,ndims,ndims)
         ioc=nsoc(is)
         ial=ndims-ioc
         read(54) u(1:ndims,1:ndims)
         read(55) occup(1:ndims)
         read(56) tipo(1:ndims)
         !
         ! traitement de pocc et pvir
         !
         kk=0
         y=.true.
         if(ypocc) then
            do k=1,norb
               if(pocc(k)==' ') exit
               ii=index(pocc(k),';')
               read(pocc(k)(ii+1:ii+1),'(i1)') is1
               if(is.ne.is1) cycle
               yy=.true.
               do l=1,ndims
                  if(tipo(l)(1:ii-1)==pocc(k)(1:ii-1)) then
                     yy=.false.
                     kk=kk+1
                     jord(kk)=l
                     y(l)=.false.
                  endif
               enddo
               if(yy) then
                  print*,'pocc=',pocc(k)(1:ii-1),' n''a pas ete trouve'
                  stop
               endif
            enddo
         endif

         kk=ndims+1
         if(ypvir) then
            do k=1,norb
               if(pvir(k)==' ') exit
               ii=index(pvir(k),';')
               read(pvir(k)(ii+1:ii+1),'(i1)') is1
               if(is.ne.is1) cycle
               yy=.true.
               do l=1,ndims
                  if(tipo(l)(1:ii-1)==pvir(k)(1:ii-1)) then
                     yy=.false.
                     kk=kk-1
                     jord(kk)=l
                     y(l)=.false.
                  endif
               enddo
               if(yy) then
                  print*,'pvir=',pvir(k)(1:ii-1),' n''a pas ete trouve'
                  stop
               endif
            enddo
         endif
         kk=ipocc(is)+1
         do ll=1,ndims
            if(.not.y(ll)) cycle
            jord(kk)=ll
            kk=kk+1
         enddo
c
c        calcul=CASSCF : on calcule ityp_loc
c
         if(calcul.eq.'CASSCF') then
            !allocate (ityp_loc(ndims))
!            print*,'All',allocated(ityp_loc)
            ityp_loc(1:fermi(is))=1
!            print*,'All',allocated(ityp_loc)
            ityp_loc(1+fermi(is):ndims)=3
!            print*,'All',allocated(ityp_loc)
!            print*,'ityp_loc',ityp_loc
            if(act.eq.'A_') then
               kk=0
               do k=1,ndims
                  if(tipo(k)(1:2).eq.'A_') then
                     kk=kk+1
                     numac(kk)=k
                     if(k.le.fermi(is)) inact(is)=inact(is)-1
                  endif
               enddo
               nact(is)=kk
            endif
            !print*,'symetrie, inac, nact',is,inact(is),kk
            ityp_loc(numac(1:nact(is)))=2
!            print*,'All',allocated(ityp_loc)
!            print*,'ityp_loc',ityp_loc
            k1=0
            k2=inact(is)
            k3=inact(is)+nact(is)
            do k=1,ndims
               if(ityp_loc(k).eq.1) then
                  k1=k1+1
                  iord(k1)=k
               else if(ityp_loc(k).eq.2) then
                  k2=k2+1
                  iord(k2)=k
               else if(ityp_loc(k).eq.3) then
                  k3=k3+1
                  iord(k3)=k
               endif
            enddo
!            print*,'Ityp_loc',ityp_loc
!            print*,'all',allocated(ityp_loc)
            !deallocate (ityp_loc)
         else
            iord=(/(k,k=1,ndims)/)
         endif
         occup(iord(1:inact(is)))=2.d0
         occup(iord(1+inact(is)+nact(is):ndims))=0.d0
         tipo(ioc+ial+1:ndims)='R_scf'
c         print*,'is,ioc,ial',is,ioc,ial
         if(nprint.ge.2) print*,'orbitales locales lues (sur NONORLOC)'
!         if(nprint.ge.2)call script(u,ndims,ndims,ndims,ndims)
         if(nprint.ge.2) call scripto(u,ndims,ndims,ndims,
     *   ndims,orbi(ndimst+1:ndimst+ndims))
c        orbitales SCF dans la base des OAO
         oscf=matmul(basinv,oscf)
         if(nprint.ge.2) print*,'basinv*oscf',
     *   ' (orbitales SCF dans la base des OAO)'
         if(nprint.ge.2) call scripto(oscf,ndims,ndims,ndims,
     *   ndims,orbi(ndimst+1:ndimst+ndims))
!         if(nprint.ge.2) call script(oscf,ndims,ndims,ndims,ndims)
         if(yw)dum=matmul(transpose(oscf),oscf)
         if(yw)call script(dum,ndims,ndims,ndims,ndims)
c        projection
         nvirt=ndims-inact(is)-nact(is)
         print*,' '
         print*,' '
         print'(a,i3,a)',' ========= symetrie',is,' ========='
         print*,' '
         allocate (u1(1:ndims,1:ndims))
         u1=u(:,iord)
         u1=u1(:,jord)
         !call scripto(u1,ndims,ndims,ndims,ndims,orbi)
         print*,'projection des inactives. nombre : ',inact(is)
         call proj(u1(1:ndims,1:inact(is)),oscf(1:ndims,1:inact(is))
     *   ,ndims,inact(is),tipo(1:inact(is)),recou(1:inact(is)),.true.,0)
         if(calcul=='CASSCF') then
            !print*,' '
            print*,'projection des actives. nombre :   ',nact(is)
            call proj(u1(1:ndims,inact(is)+1:inact(is)+nact(is))
     *      ,oscf(1:ndims,inact(is)+1:inact(is)+nact(is))
     *      ,ndims,nact(is),tipo(inact(is)+1:inact(is)+nact(is)),
     *      recou(inact(is)+1:inact(is)+nact(is)),.true.,0)
         endif
         !print*,' '
         print*,'projection des virtuelles. nombre :',
     *   ndims-inact(is)-nact(is)
         if(ndims-inact(is)-nact(is)>0)
     *   call proj(u1(1:ndims,inact(is)+nact(is)+1:ndims),
     *   oscf(1:ndims,inact(is)+nact(is)+1:ndims)
     *   ,ndims,nvirt,tipo(inact(is)+nact(is)+1:ndims),
     *   recou(inact(is)+nact(is)+1:ndims),yprojv,0)
c         do k=1,ndims
c            if(tipo(k)(1:2)=='G_') then
c               u1(:,k)=oscf(:,k)
c               recou(k)=dot_product(u(:,k),u1(:,k))
c            endif
c         enddo
         u1(:,jord)=u1
         u(:,iord)=u1
         deallocate (u1)
c        on ecrit les vecteurs projetes
         ialn=ndims-ioc
         write(57) u(1:ndims,1:ndims)
         write(58) occup
         write(59) tipo
c         call scripto(u,ndims,ndims,ndims,ndims,orbi)


         if(nprint.ge.1) then
            call scriptol(u,ndims,ndims,ndims,
     *      ndims,orbi(ndimst+1:ndimst+ndims),
     *      (/(k,k=1,ndims)/),tipo,recou)
         else
            call anapro(u,
     *      ndims,orbi(ndimst+1:ndimst+ndims),
     *      (/(k,k=1,ndims)/),tipo,recou,is,priorb)
         endif
         
         u=matmul(transpose(u),u)
         if(yw)print*,'verif'
         if(yw)call script(u,ndims,ndims,ndims,ndims)

         deallocate(base,basinv,oscf,u,occup,tipo,recou,iord,jord,y)
         if(yw)deallocate(dum)
         ndimst=ndimst+ndims
         if(is==7) then
                 print*,'fin boucle'
             endif
      enddo
      rewind 57
      rewind 58
      rewind 59
      rewind 56
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate(u(1:ndims,1:ndims))
         read(57) u
         write(56) u
         deallocate(u)
      enddo
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate(occup(1:ndims))
         read(58) occup
         write(56) occup
         deallocate(occup)
      enddo
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate(tipo(1:ndims))
         read(59) tipo
         write(56) tipo(1:ndims)
         deallocate(tipo)
      enddo
      close(53)
      close(54)
      close(55)
      close(57)
      close(58)
      close(59)
       !inquire(3,name=nom)
      !print*,'name',nom
      call ecriorb('* Orbitales Locales NON orthogonales (Proj_Scf)',
     *'NONORLOC_scf',nsym,isym,56,53)
       !inquire(3,name=nom)
      !print*,'name',nom
      close(53)
      close(2,status='delete')
      close(3,status='delete')
      call titre('Fin PROJ_scf#-#UN FICHIER NONORLOC_scf a ete cree#'//
     *'faire "cp NONORLOC_scf NONORLOC"#pour que schmudort utilise le'//
     *' fichier des orbitales projetees#',60)
      end
       subroutine proj(u,oscf,ndims,ndim,tipo,recou,yprojv,nprint)
      implicit real(8) (a-h,o-x,z),logical(y)
      dimension u(ndims,ndim),oscf(ndims,ndim)
      character(18) tipo(ndims)
      dimension vv(100,100),recou(ndim)
      allocatable v(:)
      logical yprojv
c      allocatable v(:),recou(:)
c      allocate (recou(ndim))
      allocate (v(ndims))
c      print*,'proj verif'
c      vv(1:ndim,1:ndim)=matmul(transpose(oscf),oscf)
c         call script(vv,ndim,ndim,100,100)

      if(nprint.ge.1) then
         print*,'PROJ'
         call script(u,ndims,ndim,ndims,ndim)
         print*,'OSCF'
         call script(oscf,ndims,ndim,ndims,ndim)
      endif
      do k=1,ndim
!         if(tipo(k)(1:2)=='G_') then
!            u(:,k)=oscf(:,k)
!            recou(k)=0.d0
!         else
            v=0.d0
            if(.not.yprojv.and.tipo(k)(1:2)=='T_') then
               ! On ne projette pas
               v=u(:,k)
            else
               do l=1,ndim
                  a=dot_product(u(:,k),oscf(:,l))
                  v=v+a*oscf(:,l)
               enddo
            endif
            recou(k)=dot_product(v,u(:,k))
            if(nprint==1) print*,'recou',k,recou(k)
            anorm=dot_product(v,v)
            u(:,k)=v/dsqrt(anorm)
!         endif
      enddo
      if(nprint.ge.1) then
         print*,'orb projetees'
         call script(u,ndims,ndim,ndims,ndim)
      endif
      deallocate(v)
      ideb=1
      return
      end
