      program omMFrag
* 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), nbOMocc(maxsym)
      dimension nOM(nOAmax),nusym(nOAmax)
      Logical trouv(nOAmax)
      dimension FicFrag(nfragmax)
      character car*300, nomFrag(NOAmax)*6
      character FicLabM*80, FicIndM*80 ,FicScript*80
      character FicLabfr(nfragmax)*80, FicIndfr(nfragmax)*80
      character bid*80, nomOM(nOAmax)*6, nufrag*2, nomfic*80
      double precision,dimension(:,:),allocatable :: u, v, vinv
      character*6 tipo(nOAmax)
      dimension nsoc(maxsym),nsal(maxsym),ivirt(nOAmax),occup(nOAmax)
      Integer ibid(8)
      
      
* Initialisation des tableaux
      
      nbOM=0
      nbOMocc=0
      OMM=0.D0
      OMM2=0.D0
      
* Lecture et ecriture du nombre d'OAs, du nombre de sym et du
* nombre d'OMs totales et occupees par symetrie
      
      open(90,file='FRAGIN',status='unknown')
      do
         read(5,'(a300)',end=13) car
         write(90,'(a)') trim(car)
      enddo
      
      
13    continue
      rewind(90)
      read(90,*,err=13) nOAM
      write(*,*) 'nOAM=',nOAM
      allocate (u(noam,noam))
      if (nOAM.gt.nOAmax.or.nOAM.le.0) then
         write(*,*) 'Nombre maximum d''OAs fixe a',nOAmax
     *   ,' recommencez!'
         STOP
      endif
      
16    continue
      read(90,*,err=16) nsym
      write(*,*) 'nsym=',nsym
      if (nsym.gt.maxsym.or.nsym.le.0) then
         write(*,*) 'Nsym ne peut depasser',maxsym,' recommencez!'
         STOP
      endif
      
      Do  i=1,nsym
14       continue
         read(90,*,err=14) nbOM(i), nbOMocc(i)
*        write(*,*) nbOM(i)
*        write(*,*) nbOMocc(i)
         write(*,*) 'nombre d''OMs de symetrie',i,'=',nbOM(i)
         write(*,*)
     *   'nombre d''OMs occupees de symetrie',i,'=',nbOMocc(i)
         if (nbOM(i).gt.nOMMax.or.nbOM(i).le.O) then
            write(*,*)'Nombre d''orbitales de la symetrie',
     *      i,'>',nOMMax ou negatif!'
         endif
         if (nbOMocc(i).gt.nbOM(i).or.nbOMocc(i).le.O) then
            write(*,*)
     *      'Nombre d''orbitales occupees de la symetrie',
     *      i,'> nOM(',i,') ou negatif!'
         endif
      enddo
      
      
* Lecture du nombre de fragments
      
7     read(90,*,err=7) Nfrag
      write(*,*) Nfrag
      if (nfrag.gt.nfragmax) then
         write(*,*)'Impossible d''avoir plus de'
     *   , Nfragmax, 'fragments, recommencez!'
         STOP
      endif
      
* Extraction des labels des orbitales de M
*     if(mod(nOAM,4).eq.0) then
*        nlig=nOAM/4
*     else
*        nlig=nOAM/4+1
*     endif
*     write(*,*)'nlig=',nlig
*     call system ('rm xxx')
*     open(1,file='xxx')
*     write(1,*)'laborb', nlig
*     close(1)
*     call system ('chmod u+x xxx')
*     call system ('xxx')
*     call system ('rm xxx')
      
* Lecture des noms des fichiers qui contiennent les labels des OMs de
* M, et de celui qui contiendra les index de  M
      
9     read(90,*,err=9) FicLabM
      write(*,*) FicLabM
6     read(90,*,err=6) FicIndM
      write(*,*) FicIndM
      
* Ouverture des fichiers correspondants
      
      open(11,file=FicLabM,status='unknown',form='formatted')
      open(12,file=FicIndM,status='unknown',form='formatted')
      
      
* Confection du fichier d'index des OMs de la molecule initial
      
      read(11,1000) (nomOM(i), i=1,nOAM)
*     write(*,1000) (nomOM(i), i=1,nOAM)
      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
      
      call LECNAM('&FRAG',car,90,ierr,1)
      open(91,file='LISTE',status='unknown')
      Do
         read(90,'(A)',end=30) car
         car=adjustl(car)
         long=len_trim(car)
         call suppdb(car,long)
*        write(6,'(A)') 'BOUCLE PRINCIPALE', trim(car)
         call maj(car,long)
	 if(car(1:3).eq.'FIN') exit
         if(car(1:4).eq.'FRAG') then
	    write(91,'(a)') car(1:6)
            i=1
            Do
               read(90,'(A)',end=30) car
               car=adjustl(car)
               long=len_trim(car)
               call suppdb(car,long)
               call maj(car,long)
               if(car(1:3).eq.'SEC')exit
               ideb=1
	       if(long.eq.5) cycle
               if(car(1:5).eq.'PRINC') ideb=7
*               print*,'ideb,car(1:5)',ideb,car(1:5)
               Do
                  ind=index(trim(car(ideb:long)),' ')
*                  print*,'ind',ind
                  if(ind.eq.0) then
                     ifin=long
                  else
                     ifin=ideb+ind-2
                  endif
                  nomFrag(i) = car(ideb:ifin)
                  print*,'i,ideb,ifin,long,nomfrag(i)',
     *            i,ideb,ifin,long,nomfrag(i)
                  i=i+1
                  ideb=ifin+2
                  if(ideb.gt.long) exit
               enddo
            enddo
	    write(91,*) i-1
            write(91,'(a6,1x)') (nomFrag(k),k=1,i-1)
         endif
      enddo
30    continue
      





* Comparaison du fichier d'index de la molecule d'origine
* et du fichier LISTE pour determiner les fichiers d'index
* des fragments qu4il faut lire pour chaque orb
    
      rewind(12)
      rewind(91)
      
      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
             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)
	     read(91,*) norb
*            write(6,*) norb
	     Do j=1,norb
		  read(91,'(A)') nomFrag(j)
*                 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)
                         OMM2(1:nOAM,no)=OMM(1:nOAM,no)
		      endif   
                  enddo
	     enddo
	     write(*,*)'matrice	finale du tour',nufrag
	     call script(OMM2,nOAM,nOAM,nOAmax,nOAmax)
           endif 
         enddo
40       continue
         close(50)
c
c       ecriture de la matrice des orbitales non orthogonales
c       dans le format de la file 50 de schmud
c
        open(50,file='OAOdep',status='old',form='unformatted')
        open(51,file='OAO',status='unknown',form='unformatted')
	read(50) mvirt,ivirt(1:mvirt)
	print*,'coucou'
	write(51) mvirt,ivirt(1:mvirt)
	read(50) nsoc(1:nsym),nsal(1:nsym)
	print*,'coucou2'
	write(51) nsoc(1:nsym),nsal(1:nsym)
        ndd=0
        call lirorb('LOCOA',nbid,mbid,ibid,60)
        do is=1,nsym
	   ndims=nbOM(is)
	   allocate(v(ndims,ndims))
	   allocate(vinv(ndims,ndims))
           read(60) v(1:ndims,1:ndims)
	   print*,'v avant'
	   call script(v,ndims,ndims,ndims,ndims)
*          call inverse(v(1:ndims,1:ndims),ndims)
	   call invert(v(1:ndims,1:ndims),vinv(1:ndims,1:ndims),ndims)
	   call script(vinv,ndims,ndims,ndims,ndims)
	   print*,'v apres'
	   call script(vinv,ndims,ndims,ndims,ndims)
	   print*,'VERIF'
           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*,'coucou3',ioc,ndims
*Ecriture de OMM2 avant changement de base
           print*,'occ OMM2 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*,'occ, sym',is
           print*,'occ OMM2 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*,'virt OMM2 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*,'virt OMM2 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)
        enddo
        close(50)
	close(51)


       stop


      


      close(8)
      close(12)
      close(90)
      close(91)

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