      PROGRAM omMFrag
      use mod_lirorb
* Ce programme permet d'obtenir les OMs (occupees et virtuelles)
* d'une molecule a partir des OMs de plusieurs de ses fragments

           
      implicit double precision (a-h,o-x,z),logical*1(y)
      parameter (maxsym=8,nOAmax=400,nfragmax=100)
      double precision OMM(nOAmax,nOAmax), OMM2(nOAmax,nOAmax)
      dimension nbOM(maxsym)
      dimension nOM(nOAmax),nusym(nOAmax)
      Logical trouv(nOAmax)
      dimension FicFrag(nfragmax)
      character car*300, nomFrag(NOAmax)*12
      character FicLabM*80, FicIndM*80 , Fic*80
      character bid*80, nomOM(nOAmax)*12, nufrag*2, nomfic*80
      character nam*10
      double precision,dimension(:,:),allocatable :: u, v, vinv
      character*12 tipo(nOAmax)
      character*12 issu(nOAmax)
      dimension nsoc(maxsym),nsal(maxsym),occup(nOAmax)
      Integer ibid(8)
      character(1000) namel
      integer fermi(8)
      
      
* Initialisation des tableaux
      
      nbOM=0
      OMM=0.D0
      OMM2=0.D0
      
* Ouverture du fichier FRAGIN (90) qui contient les donnees
      
      open(90,file='FRAGIN',status='unknown')

* Lecture "prematuree" du fichier LOCOA contenant les OAs 
* dans la base des OA orthogonales afin d'obtenir le
* nombre d'OAs, le nombre de symetries et le nombre d'OMs par sym  

      call lirorb('LOCOA',noam,nsym,nbom,60,50)
*      print*,'noam,nsym,nbom(1:nsym)',noam,nsym,nbom(1:nsym)

      
* Lecture du nombre de fragments
      
7     read(90,*,err=7) Nfrag
      write(*,*) 'Nfrag',Nfrag
      if (nfrag.gt.nfragmax) then
         write(*,*)'Impossible d''avoir plus de'
     *   , Nfragmax, 'fragments, recommencez!'
         STOP
      endif
      
* Lecture du fichier qui contient les labels des OMs de la molecule
* et de celui qui contiendra ces labels en 1 colonne

9     read(90,'(A)',err=9) Fic
      FicLabM=trim(Fic)//'.lab'
      write(*,*) FicLabM
      FicIndM=trim(Fic)//'.ind'
      write(*,*) FicIndM


* Ouverture des fichiers $Project.lab, .ind et du fichier LISTE
      
      open(11,file=FicLabM,status='old',form='formatted')
      open(12,file=FicIndM,status='unknown',form='formatted')
      open(91,file='LISTE',status='old',form='formatted')
      
      
* Confection du fichier d'index des OMs de la molecule initial
* (ordre des OMs a concerver!) 

      ideb=1 
      Do is=1,nsym 
         ifin=ideb-1+nbOM(is)
         read(11,1000) (nomOM(i), i=ideb,ifin)
         ideb=ifin+1
      enddo 
      close(11)

      ncompt=0
      Do i=1,nsym
         Do j=1,nbOM(i)
            ncompt=ncompt+1
            write(12,2000) nomOM(ncompt), i, j
         enddo
      enddo
      if(ncompt.ne.nOAM) print*, 'Probleme avec fichier de Label!'
     

* Comparaison du fichier d'index de la molecule d'origine
* et du fichier LISTE pour determiner les fichiers d'index
* des fragments qu'il faut lire pour chaque orb
    
      rewind(12)
      issu=' '
      
      Do  
           read(91,'(A)',end=40) car
           if(car(1:4).eq.'FRAG') then
             nufrag=car(5:6)
*            write(6,'(A)') nufrag 
             nomfic='frag'//trim(nufrag)//'.locorb2'
             open(50,file=nomfic,status='old')
             read(50,*) bid
             kk=0
             read(91,'(A)') bid
             Do is=1,nsym
                Do in=1,nbOM(is)
                   kk=kk+1
                   read(50,*) bid
                   read(50,3000) OMM(1+sum(nbOM(1:is-1)):nbOM(is)
     *              +sum(nbOM(1:is-1)),kk)
                enddo
             enddo
             write(*,*)'matrice ',nomfic
             call script(OMM,nOAM,nOAM,nOAmax,nOAmax)
             Do 
                  read(91,'(A)') nomFrag(j)
                  if(nomFrag(j)(1:3).eq.'SEC') exit
                 !write(6,'(A)') nomFrag(j) 
                  rewind(12)
                  Do no=1,nOAM
                      read(12,'(A)') nomOM(no)
                      if(nomOM(no).eq.nomFrag(j)) then
                         !write(6,*) nbOM(isym)
                         !print*,'c''est bon'
                         OMM2(1:nOAM,no)=OMM(1:nOAM,no)
                         if(issu(no).ne.' ') then
                            print*,'l''orbitale',no,' est issue de 2'//
     *                      ' fragments :',issu(no),nomFrag(j)
                            stop
                         endif
                         issu(no)=nomfrag(j)
                         print*,'issu',no,issu(no)
                      endif   
                  enddo
             enddo
             write(*,*)'matrice	finale du tour',nufrag
             call script(OMM2,nOAM,nOAM,nOAmax,nOAmax)
           endif 
         enddo
40       continue
         do k=1,noam
            write(6,'(''l orbitale'',i4,'' est issue de '',a12)')
     *      k,issu(k)
         enddo
         do k=1,noam
            if(issu(k)==' ') then
               print*,'l''orbitale',k,' n''est issue d''aucun'//
     *         ' fragment'
               stop
            endif
         enddo
         close(50)


!* Ecriture de la matrice des orbitales non orthogonales
!* dans le fichier OAO (51) dans le format de la file 50 de schmud
!
!        open(50,file='OAOdep',status='old',form='unformatted')
!        open(51,file='OAO',status='unknown',form='unformatted')
!        read(50) mvirt,ivirt(1:mvirt)
!        write(51) mvirt,ivirt(1:mvirt)
!        read(50) nsoc(1:nsym),nsal(1:nsym)
!        write(51) nsoc(1:nsym),nsal(1:nsym)
!        ndd=0
!        call lirorb('LOCOA',noam,mbid,ibid,60)
!
!        do is=1,nsym
!           ndims=nbOM(is)
!           allocate(v(ndims,ndims))
!           allocate(vinv(ndims,ndims))
!           allocate (u(ndims,ndims))
!           read(60) v(1:ndims,1:ndims)
!*          print*,'v avant'
!*          call script(v,ndims,ndims,ndims,ndims)
!* Procedure inverse de Daniel inverse seulement des matrices carres!  
!*          call inverse(v(1:ndims,1:ndims),ndims)
!* Procedure invert trouve sur le web la remplacera!
!           call invert(v(1:ndims,1:ndims),vinv(1:ndims,1:ndims),ndims)
!*          print*,'v apres'
!*          write(*,*)' ndims', ndims
!*          call script(vinv,ndims,ndims,ndims,ndims)
!           print*,'VERIF v inv * v'
!           u(1:ndims,1:ndims)=matmul(v,vinv)
!           call script(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
!           read(50) ioc,ndims,u(1:ndims,1:ioc),
!     *     occup(1:ioc),tipo(1:ioc)
!           print*,'ioc,ndims',ioc,ndims
!
!*Ecriture de OMM2 avant changement de base
!
!           print*,'OMs occ avant changement de base, sym',is
!           call script(OMM2(ndd+1:ndd+ndims,ndd+1:ndd+ioc)
!     *     ,ndims,ioc,ndims,ioc)
!
!* Changement de base pour avoir les OMs dans la base des 
!* OAs orthogonales (necessaires pour Shmudort!)
!
!           omm2(ndd+1:ndd+ndims,ndd+1:ndd+ioc)=matmul(vinv,
!     *     omm2(ndd+1:ndd+ndims,ndd+1:ndd+ioc))
!           write(51) ioc,ndims,omm2(ndd+1:ndd+ndims,ndd+1:ndd+ioc),
!     *     occup(1:ioc),tipo(1:ioc)
!           print*,'OMs occ apres changement de base, sym',is
!           call script(OMM2(ndd+1:ndd+ndims,ndd+1:ndd+ioc)
!     *     ,ndims,ioc,ndims,ioc)
!
!           read(50) ial,ndims,u(1:ndims,ioc+1:ioc+ial),
!     *     occup(ioc+1:ioc+ial),tipo(ioc+1:ioc+ial)
!           print*,'OMs virt avant changement de base, sym',is
!           call script(OMM2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial)
!     *       ,ndims,ial,ndims,ial)
!           omm2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial)=matmul(vinv,
!     *     omm2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial))
!           write(51) ial,ndims,omm2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc
!     *     +ial), occup(ioc+1:ioc+ial),tipo(ioc+1:ioc+ial)
!           print*,'virt, sym',is
!           print*,'OMs virt apres changement de base, sym',is
!           call script(OMM2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial)
!     *       ,ndims,ial,ndims,ial)
!           ndd=ndd+ndims
!           deallocate(v)
!           deallocate(vinv)
!           deallocate(u)
!        enddo
!        close(50)
!        close(51)

* Ecriture de la matrice des orbitales non orthogonales
* dans le fichier NONORLOC (51)
!
!        open(50,file='OAOdep',status='old',form='unformatted')
!        open(51,file='OAO',status='unknown',form='unformatted')
!        read(50) mvirt,ivirt(1:mvirt)
!        write(51) mvirt,ivirt(1:mvirt)
!        read(50) nsoc(1:nsym),nsal(1:nsym)
!        write(51) nsoc(1:nsym),nsal(1:nsym)
        ndd=0
        open(50,file='SCH_FERMI',status='old')
        call LECNAM('&FERM ',namel,50,ierr,1)
        if(ierr==1) stop' namelist &ferm non trouvee dans SCH_FERMI'
        call nameli(namel,fermi,'FERMI',4)
        close(50)
        call lirorb('LOCOA',noam,mbid,ibid,60,50)
        open(54,file='UTEMP',status='unknown',form='unformatted')
        call lirorb('NONORLOCdep',noam,mbid,ibid,51,50,ifiloc=52,
     *  ifillab=53)
        rewind 60
        rewind 51
        do is=1,nsym
           ndims=nbOM(is)
           allocate(v(ndims,ndims))
           allocate(vinv(ndims,ndims))
           allocate (u(ndims,ndims))
           read(60) v
*          print*,'v avant'
*          call script(v,ndims,ndims,ndims,ndims)
* Procedure inverse de Daniel inverse seulement des matrices carres!  
*          call inverse(v(1:ndims,1:ndims),ndims)
* Procedure invert trouve sur le web la remplacera!
           call invert(v(1:ndims,1:ndims),vinv(1:ndims,1:ndims),ndims)
*          print*,'v apres'
*          write(*,*)' ndims', ndims
*          call script(vinv,ndims,ndims,ndims,ndims)
           print*,'VERIF v inv * v'
           u(1:ndims,1:ndims)=matmul(v,vinv)
           call script(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
!           read(50) ioc,ndims,u(1:ndims,1:ioc),
!     *     occup(1:ioc),tipo(1:ioc)
!           print*,'ioc,ndims',ioc,ndims
           read(51) u
           ioc=fermi(is)
!           read(52) occup(1:ndims)
!           read(53) tipo(1:ndims)

*Ecriture de OMM2 avant changement de base

           print*,'OMs occ avant changement de base, sym',is
           call script(OMM2(ndd+1:ndd+ndims,ndd+1:ndd+ioc)
     *     ,ndims,ioc,ndims,ioc)

* Changement de base pour avoir les OMs dans la base des 
* OAs orthogonales (necessaires pour Shmudort!)

           omm2(ndd+1:ndd+ndims,ndd+1:ndd+ioc)=matmul(vinv,
     *     omm2(ndd+1:ndd+ndims,ndd+1:ndd+ioc))
!           write(51) ioc,ndims,omm2(ndd+1:ndd+ndims,ndd+1:ndd+ioc),
!     *     occup(1:ioc),tipo(1:ioc)
           print*,'OMs occ apres changement de base, sym',is
           call script(OMM2(ndd+1:ndd+ndims,ndd+1:ndd+ioc)
     *     ,ndims,ioc,ndims,ioc)

!           read(50) ial,ndims,u(1:ndims,ioc+1:ioc+ial),
!     *     occup(ioc+1:ioc+ial),tipo(ioc+1:ioc+ial)
           ial=nbom(is)-ioc
           print*,'OMs virt avant changement de base, sym',is
           call script(OMM2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial)
     *       ,ndims,ial,ndims,ial)
           omm2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial)=matmul(vinv,
     *     omm2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial))
!           write(51) ial,ndims,omm2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc
!     *     +ial), occup(ioc+1:ioc+ial),tipo(ioc+1:ioc+ial)
           write(54) omm2(ndd+1:ndd+ndims,ndd+1:ndd+ndims)
           print*,'virt, sym',is
           print*,'OMs virt apres changement de base, sym',is
           call script(OMM2(ndd+1:ndd+ndims,ndd+ioc+1:ndd+ioc+ial)
     *       ,ndims,ial,ndims,ial)
           ndd=ndd+ndims
           deallocate(v)
           deallocate(vinv)
           deallocate(u)
        enddo
        rewind 52
        rewind 53
        call ecriorb('NONORLOC PAR OMsMformFrags','NONORLOC',
     *  nsym,nbom,54,55,ifiloc=52,ifillab=53)
        close(50)
        close(51,status='delete')
        close(52,status='delete')
        close(53,status='delete')
        close(54,status='delete')

      close(11)
      close(12)
      close(90)
      close(91)

* Formats
1000  format(4(a12,6X))
2000  format(A12,2X,I3,2X,I3)
3000  format(4(D18.12))
      end
      
