      PROGRAM ModifOlin
* Ce programme permet de creer le fichier de donnees Frag$i.olin 
* de chaque "fragment" a partir du fichier de donnees $Project.dat 
* qui ontient les orbitales a geler et du fichier $Project.olin
* de la molecule "entiere"

* Au passage, creation du fichier FRAGIN, copie de $Project.dat
* BESOIN DU FICHIER $Project.dat en DONNEES!!!!!!
           
      implicit double precision (a-h,o-x,z),logical(y)
      parameter (maxsym=8,nOAmax=400,nfragmax=100)
      character car*300, nomFrag*20,car3*3
      character Fic*80,FicOlinM*80, FicOlM*80
      character bid*80, nufrag*2, nomfic*80
      character namel*100000,chaine*80,car2*300
      character nam*20, numer*3
      dimension nferm(1:maxsym),yolin(noamax),nbom(8)
      allocatable yliste(:)
      yw=.false.
      nprint=0
      ypr1=nprint.ge.1
      
      print*,' '
      print*,'********************************************************'
      print*,'========================================================'
      print*,'                      ModifOlin'
      print*,'========================================================'
      print*,'********************************************************'
      print*,' '
      nbOM=0
      
* Lecture (5) des donnees concernant les OMs de chaque 
* fragment et ecriture en virant les espaces en fin de ligne
* dans le fichier FRAGIN (90)
      

!      call timing
      open(90,file='FRAGIN',status='unknown')
      do
         read(5,'(a300)',end=13) car
         write(90,'(a)') trim(car)
      enddo
13    continue

      rewind(90)

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

      call lirorb('LOCOA',noam,nsym,nbom,60)
      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
!      FicOlinM=trim(Fic)//'.olin'
      FicOlinM='OLIN'
      if(yw) write(*,*) FicOlinM
* on ecrit fin a la fin de OLIN
      open(10,file=FicOlinM,status='old',form='formatted')
      lolin=0
      do
         read(10,'(a)',end=1111) car
         lolin=lolin+1
      enddo
 1111 continue
      call maj(car,len(car))
      if(yw) print*,'CAR',trim(car),index(car,'FIN')
      if(index(car,'FIN').eq.0) then
              write(10,'(a3)') 'fin'
      else
              lolin=lolin-1
      endif
      yolin(1:lolin)=.false.
      close(10)
      

     
* Lecture de la namelist &Frag dans le fichier FRAGIN (90) et
* ecriture dans le fichier LISTE (91) 
* (au fait, si le dernier argument de lecnam vaut 1, il ecrit la namelist!)

      call LECNAM('&FRAG',namel,90,ierr,1)
      call maj(namel,len(namel))
*     write(*,'(A)') 'Namelist &Frag', namel
      open(91,file='LISTE',status='unknown')
      long=len_trim(namel)
*     print*, 'longueur de la nameliste',long
      i=1
      k=1
      longnl=0
      Do 
*        print*,'debut de boucle: k',k
         ideb=1
         Do j=longnl+1,long
            if(namel(j:j).ne.',') then
              nam(ideb:ideb)=namel(j:j)
*             print*,'j,namel(j:j)',j,namel(j:j)
*             print*,'ideb,nam(ideb:ideb)',i,nam(ideb:ideb)
              ideb=ideb+1
              i=i+1
*             print*,'i',i
            else
              exit 
            endif 
*           write(*,'(A11,I3,A10)') 'k,chaine lu',k,nam(1:ideb-1)
        enddo
        write(91,'(A)') nam(1:ideb-1)
        k=k+1
        longnl=longnl+ideb
        if(longnl.eq.long) exit
      enddo 
      write(91,'(A)') 'END' 
      isize=k-1
      allocate(yliste(isize))
      yliste=.true.
      call flush(6)
*     print*,'isize',isize



* Comparaison du fichier $Project.olin  de la molecule d'origine
* et du fichier LISTE pour creer les fichiers frag$i.olin 
* des fragments 
    
      rewind(91)
      rewind 10
      
* Ouverture des Nfrag fichiers .olin des fragments       
      Do ifrag=1,Nfrag
         num=10+ifrag
         if (ifrag.lt.10) then
             numer=char(48+ifrag)
         elseif (ifrag.lt.100) then
             numer(1:1)=char(48+ifrag/10)
             numer(2:2)=char(48+mod(ifrag,10))
         endif
*	 print*,'numer',trim(numer)
         nomfic='frag'//trim(numer)//'.olin'
         open(num,file=nomfic,status='unknown',form='formatted')
      enddo
* Boucle sur les fragments
         Do i=1,NFrag
             print*,' '
             print*,'fragment',i
             nmodif=0
             nrecop=0
             num=i+10 
             FicOlinM=trim(Fic)//'.olin'
             open(10,file=FicOlinM,status='old',form='formatted')
* On recopie le debut de $Fic.olin dans chaque frag$i.olin
             Do 
                read(10,'(A)') car
c                call maj(car,len(car))
                if(yw)print*,'car lu 10 debut : ',trim(car)
                write(num,'(A)') trim(car)
                car3=car
                call maj(car3,3)
                if(car3.eq.'FIN') exit
             enddo
*            print*,'fin lect debut'
!             read(10,'(A)') car
!             print*,'car lu 10 : ',trim(car)
!             call maj(car,len(car))
!             print*,'maj(car): ',trim(car)
!             write(num,'(A)') trim(car)
             write(num,'(a)')' &ORB /'
             close(10)
             FicOlinM='OLIN'
             open(10,file=FicOlinM,status='old',form='formatted')
* Boucle de lecture du fichier OLIN
             iolin=0
       yw=.true.
             Do 
                read(10,'(A)',end=55) car
                iolin=iolin+1
                if(yw)print*,'car lu 10 : ',trim(car)
                long10=index(car,' ')-1
*               print*,'longueur from 10 : ', long10 
                if(car(1:3).eq.'FIN') exit
                call maj(car,len(car))
                if (car(1:3).eq.'FIN') then
                    write(num,'(A)') trim(car) 
                    exit 
                endif
                if(yw)print*,'maj(car): ',trim(car)
* 	        print*,char(i+48)
                chaine='FRAG'//char(i+48)
          if(yw) print*,'chaine ',chaine
*	        print*,'chaine',chaine
* Boucle de lecture du fichier LISTE
                rewind(91)
                kliste=0
                Do
                   ydesac=.false.
                   read(91,'(A)',end=45) nomFrag
                   kliste=kliste+1
                   if(len_trim(nomFrag).eq.0) yliste(kliste)=.false.
                   if(yw)print*,'NomFrag lu 91 : ',trim(nomFrag)
                   if(nomFrag(1:5).eq.chaine) then
                      yliste(kliste)=.false.
                      if(yw)print*,'kliste frag',kliste
* lecture de 'PRINC'
                      read(91,'(A)') Bid
                      kliste=kliste+1
                      yliste(kliste)=.false.
                      if(yw)print*,'Bid lu 91 : ',trim(Bid)
                      Do
                         read(91,'(A)',end=45) nomFrag
                         kliste=kliste+1
                         if(yw)print*,'nomFrag lu 91 : ',trim(nomFrag)
*                        print*,'nomFrag',trim(nomFrag)
* si lecture de 'SEC', je relis nomFrag pour continuer
                         if(nomFrag(1:3).eq.'SEC') then
                            yliste(kliste)=.false.
                            if(yw)print*,'kliste sec',kliste
                            read(91,'(A)',end=45) nomFrag   
                            kliste=kliste+1
                            if(yw)print*,'nomFrags lu 91 : ',
     *                      trim(nomFrag)
                         endif
* si lecture de 'DESAC', je relis nomFrag pour continuer, je note ydesac
                         if(nomFrag(1:5).eq.'DESAC') then
                            yliste(kliste)=.false.
                            read(91,'(A)',end=45) nomFrag   
                            kliste=kliste+1
                            ydesac=.true.
                         endif
* si je tombe sur 'FRAG' je retourne au debut de la 
* boucle sur les Fragments 
                         if(nomFrag(1:4).eq.'FRAG'
     *                   .OR.nomFrag(1:3).eq.'END') goto 44 
                         long91=len_trim(nomFrag)
*                        write(*,*) 'long from 91' ,long91 
                         long=max(long10,long91)
                         if(yw)print*,'long10,long91,long'
     *                   ,long10,long91,long  
                         if(nomFrag(1:long).eq.car(1:long)) then
                            if(ypr1)print*,'recopie : ',trim(car)
                            nrecop=nrecop+1
                            if(ydesac) then
                               car2='O'//car(2:len(car))
                            else
                               car2=car
                            endif
                            write(num,'(A)') trim(car2)
                            yolin(iolin)=.true.
                            yliste(kliste)=.false.
                            if(yw)print*,'kliste',kliste
                            goto 45
                         endif
                      enddo
                   endif
                enddo
44              continue
                if(ypr1)print*,'modifie : ',trim(car)
                nmodif=nmodif+1
                if(car(1:1)=='G') then
                   if(ypr1)print*,' --->     ','G'//car(2:len_trim(car))
                   car2='G'//car(2:len(car))
                else
                   if(ypr1)print*,' --->     ','F'//car(2:len_trim(car))
                   car2='F'//car(2:len(car))
                endif
                write(num,'(A)') trim(car2)
c                yolin(iolin)=.true.
45              continue
             enddo
             Do 
                     read(10,'(A)',end=55) car
                     call maj(car,len(car))
                     print*,'recopie fin : ',trim(car)
                     write(num,'(A)') trim(car)
             enddo   
55           continue   
             rewind(10)
             if(yw)print'(40l1)',yolin(1:lolin)
             print*,'Il y a :'
             print*,nrecop,' liaisons recopiees'
             print*,nmodif,' liaisons gelees'
       Enddo



* Test pour verif qu'on a considere toutes les orbitales dans les fragments

      print*,' '
      print*,'**************************************************'
      rewind 91
      do kliste=1,isize
         read(91,'(A)') nomFrag
         if(yliste(kliste)) then
             print*,'liaison non trouvee'
             print*,trim(nomfrag),kliste
         endif
      enddo
      rewind 10
      do k=1,lolin
         read(10,'(a)',end=1111) car
         if(.not.yolin(k)) then
            print*,'erreur, la liaison ',trim(car)
            print*,' n''apparait pas'//
     *      ' dans la liste des donnees'
         endif
      enddo
      print*,'**************************************************'
      stop
       norb=0
       rewind(91)
       Do iFrag=1,Nfrag
          Do
            read(91,'(A)',end=62) chaine 
            long=len_trim(chaine)
            nomFrag='FRAG'//char(iFrag+48)
            long2=len_trim(nomFrag)
            longu=max(long,long2)
            if(chaine(1:longu).eq.nomFrag(1:longu)) then
               read(91,'(A)') bid
               exit
            endif
          enddo  
          Do 
             read(91,'(A)',end=62) chaine
             if(chaine(1:3).eq.'SEC') then
                 exit
             endif 
             norb=norb+1
          enddo
        enddo  
       
62     print*,'norb',norb
       FicOlM=trim(Fic)//'.olout_red'
       open(1,file=FicOlM,status='old',form='formatted')
       read(1,'(A42,10(I4))') bid, nferm(1:nsym)
       close(1)
       write(*,'(A,10(I3))') bid, nferm(1:nsym)
       norbferm=0
       Do is=1,nsym
           norbferm=norbferm+nferm(is)
       enddo
       print*,'norbferm',norbferm
       if(norb.ne.norbferm) then
           print*,'INCOMPATIBILITE entre le nombre d''OMs occupees '
     *     ,'et le nombre d''OMs recuperees a partir des Frags!!!!!'
           print*,'VERIFIER VOTRE FICHIER DE DONNEES $Project.dat'
       endif

       close(91)
       close(10)
       Do ifrag=1,Nfrag
          close(10+ifrag)
       enddo  
!       call timing

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