      program proj_orb
      use mod_lirorb
      implicit real(8) (a-h,o-x,z),logical(y)
      parameter (maxsym=8,maxorbcas=16)
      character(100000) namel,namel1
      character(80) prefix,info!,mono,locoa,scf
      character(80) orb1,orb2,orb3,locoa
      dimension ninac1(maxsym),nac1(maxsym),nvir1(maxsym)
      dimension ninac2(maxsym),nac2(maxsym),nvir2(maxsym)
      allocatable orbi1(:,:),orbi2(:,:),orbi3(:,:),base(:,:),basinv(:,:)
      allocatable occup1(:),occup2(:)

      dimension isym(maxsym)
!      dimension nsoc(maxsym),nsal(maxsym)
!      double precision,dimension(:),allocatable :: occup
!      double precision,dimension(:,:),allocatable :: base,basinv,oscf,
!     *u,dum,u1,s
      character(12),dimension(:),allocatable :: tipo1,tipo2
      character(18),dimension(:),allocatable :: tipol
!      integer,dimension(:),allocatable :: ityp_loc,iord
      character(8) orbi(:)!,calcul,act
      character(3) base1,base2
      allocatable orbi
!      integer fermi(maxsym),numac(maxorbcas),inact(maxsym),nact(maxsym)
      integer frozen1(maxsym)
      integer frozen2(maxsym)
!      allocatable v(:),recou(:)
      allocatable recou(:)
!      logical yprojv
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       PROJ_ORB'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '      
      yw=.false.
      nprint=0
      locoa='LOCOA'
      info=' '
!      mono=' '
!      scf=' '
!      fermi=-1
      frozen1=0
      frozen2=0
!      inact=0
!      nact=0
!      calcul='SCF'
!      yprojv=.true.
      ninac1=0
      ninac2=0
      nac1=0
      nac2=0
      nvir1=0
      nvir2=0
      orb1='NONORLOC'
      orb2='CASORB'
      orb3='NONORLOC_proj'
      base1='OAO'
      base2='OAO'
c
c---------------------------------------------------------------
c     lecture des donnees
c---------------------------------------------------------------
c
      call LECNAM('&PROJ_ORB ',namel,5,ierr,1)
      if(ierr.eq.1) then
         print*,'namelist PROJ_ORB non trouvee'
         stop
      endif
      call namela(namel,PREFIX,'PREFIX')
      call namela(namel,BASE1,'BASE1')
      call namela(namel,BASE2,'BASE2')
      call namela(namel,ORB1,'ORB1')
      call namela(namel,ORB2,'ORB2')
      call namela(namel,ORB3,'ORB3')
      call namela(namel,LOCOA,'LOCOA')
      call nameli(namel,NINAC1,'NINAC1',4)
      call nameli(namel,NINAC2,'NINAC2',4)
      call nameli(namel,NAC1,'NAC1',4)
      call nameli(namel,NAC2,'NAC2',4)
      call nameli(namel,NVIR1,'NVIR1',4)
      call nameli(namel,NVIR2,'NVIR2',4)
      call namela(namel,INFO,'INFO1')
      call nameli(namel,FROZEN1,'FROZEN1',4)
      call nameli(namel,DELETE1,'DELETE1',4)
      call nameli(namel,FROZEN2,'FROZEN2',4)
      call nameli(namel,DELETE2,'DELETE2',4)

      if(info.eq.' ') info=trim(prefix)//'Info'
!      lecture des labels
      open(20,file=info,status='old',form='formatted')
      call LECNAM('&COST_AO ',namel1,20,ierr,1)
      !
      if(base1=='OAO') then
         print*,'les orbitales en entree sont en base orthogonale'
      else if(base1=='OA') then
         print*,'les orbitales en entree sont en base non orthogonale'
      else
         stop" base1 a une valeur non prevue"
      endif
      if(base2=='OAO') then
         print*,'les orbitales en sortie sont en base orthogonale'
      else if(base2=='OA') then
         print*,'les orbitales en sortie sont en base non orthogonale'
      else
         stop" base2 a une valeur non prevue"
      endif
c
c---------------------------------------------------------------
c     ouverture et lecture des files
c---------------------------------------------------------------
c
! lecture des orbitales a projeter (locales ?)
      call lirorb(orb1,norb,nsym,isym,1,2,ifiloc=8,ifillab=9)
! lecture des orbitales de reference
      call lirorb(orb2,norb,nsym,isym,3,2)
! lecture les OAO exprimees dans la base des OA
      call lirorb(locoa,norb,nsym,isym,10,2)
      rewind 10
      allocate(orbi(norb))
      call namela(namel1,ORBI,'LABEL')
c
c---------------------------------------------------------------
c     boucle sur les symetries
c---------------------------------------------------------------
c
      rewind 3
      rewind 2
      print*,' '
      print*,'------------------------------------------------- '
      print*,'recouvrements des orb projetees avec les anciennes'
      print*,' '
      ndimst=0
      open(11,status='scratch',form='unformatted')
      do is=1,nsym
         if(isym(is).eq.0) cycle
         ndims=isym(is)
         if(base1=='OA'.or.base2=='OA') then
            allocate (base(ndims,ndims))
            read(10) base
         endif
         if(base1=='AO') allocate (basinv(ndims,ndims))
         allocate (orbi1(ndims,ndims))
         allocate (orbi2(ndims,ndims))
         allocate (orbi3(ndims,ndims))
         allocate (occup1(ndims),tipo1(ndims))
         allocate (occup2(ndims),tipo2(ndims))
!         allocate (iord(ndims))
c        P**-1
         if(base1=='AO') then
            call invert(base,basinv,ndims)
            if(nprint.eq.2) print*,'basinv (inv de la mat OAO)'
            if(nprint.ge.2) call script(basinv,ndims,ndims,ndims,ndims)
         endif
         norb1=ninac1(is)+nac1(is)+nvir1(is)
         norb2=ninac2(is)+nac2(is)+nvir2(is)
         !delimiteurs:
         if1=frozen1(is)
         ifn1=if1+ninac1(is)
         ifnn1=ifn1+nac1(is)
         ifnnv1=ifnn1+nvir1(is)
         if2=frozen2(is)
         ifn2=if2+ninac2(is)
         ifnn2=ifn2+nac2(is)
         ifnnv2=ifnn2+nvir2(is)
         allocate (recou(ndims))
         read(1) orbi1
         orbi3(:,1:if1)=orbi1(:,1:if1)
         orbi3(:,ifnnv1+1:ndims)=orbi1(:,ifnnv1+1:ndims)
         recou(1:if1)=1.d0
         if(norb1.ne.ndims) recou(ifnnv1+1:norbs)=1.d0
         read(3) orbi2
         orbi2(:,1:norb2)=orbi2(:,if2+1:if2+norb2)
c        orbitales SCF dans la base des OAO
         if(base1=='AO') orbi2=matmul(basinv,orbi2)
         !
         !
         call proj(orbi1(:,if1+1:ifn1),orbi2(:,1:ninac2(is)),
     *   orbi3(:,if1+1:ifn1),ndims
     *   ,ninac1(is),ninac2(is),recou(if1+1:ifn1))
         !
         call proj(orbi1(:,ifn1+1:ifnn1)
     *   ,orbi2(:,1+ninac2(is):nac2(is)+ninac2(is))
     *   ,orbi3(:,ifn1+1:ifnn1),
     *   ndims,
     *   nac1(is),nac2(is),
     *   recou(ifn1+1:ifnn1))
         !
         call proj(orbi1(:,ifnn1+1:norb1)
     *   ,orbi2(:,1+ninac2(is)+nac2(is):norb2)
     *   ,orbi3(:,ifnn1+1:norb1),
     *   ndims,
     *   nvir1(is),nvir2(is),recou(ifnn1+1:norb1))
         !
         if(base2=='AO') then
            orbi3=matmul(base,orbi3)
         endif
         write(11) orbi3
         call scriptol(orbi3,ndims,norb1,ndims,
     *   norb1,orbi(ndimst+1:ndimst+ndims),(/(k,k=1,ndims)/),tipo,recou)
         deallocate (orbi1,orbi2,orbi3,occup1,occup2,tipo1,tipo2,recou)
      enddo
      call ecriorb('* Orbitales Locales NON orthogonales (Proj_Orb)'
     *,'NONORLOC_orb',nsym,isym,11,2,ifiloc=8,ifillab=9)
      end
       subroutine proj(orbi1,orbi2,orbi3,ndims,ninac1,ninac2,recou)
      implicit real(8) (a-h,o-x,z),logical(y)
      dimension orbi1(ndims,ninac1),orbi2(ndims,ninac2)
      dimension orbi3(ndims,ninac1)
      dimension recou(ninac1)
!      allocatable v(:)
!      allocate (v(ndims))
      dimension v(1000)
      nprint=0
      if(nprint.ge.1) then
         print*,'PROJ'
         call script(orbi1,ndims,ninac1,ndims,ninac1)
         call script(orbi2,ndims,ninac2,ndims,ninac2)
      endif
      do k=1,ninac1
         v=0.d0
         do l=1,ninac2
            a=dot_product(orbi1(:,k),orbi2(:,l))
            v(1:ndims)=v(1:ndims)+a*orbi2(:,l)
         enddo
         print*,'k,recou(k)',k,recou(k)
         recou(k)=dot_product(v(1:ndims),orbi1(:,k))
         anorm=dot_product(v(1:ndims),v(1:ndims))
         orbi3(:,k)=v(1:ndims)/dsqrt(anorm)
      enddo
      !deallocate (v)
      return
      end
            
     

