      program orcomp
* Ce programme permet d'obtenir les OMs (occupees et virtuelles)
* d'unpolyene
* a partir des OMs de plusieurs fragments
      
      parameter (maxsym=8,nOAmax=400,nfragmax=100)
      dimension nbOM(maxsym), nbOMocc(maxsym)
      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
      
* Initialisation des tableaux
      
      nbOM=0
      nbOMocc=0
      
* 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
      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 du polyene et des fragments
      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 : ceux qui contiendront les
* scripts d'extraction des orbitales du polyene
* et ceux qui contiennent les labels des OMs de M, et de celles
* des fragments
      
8     read(90,*,err=8) FicScript
      write(*,*) FicScript
9     read(90,*,err=9) FicLabM
      write(*,*) FicLabM
6     read(90,*,err=6) FicIndM
      write(*,*) FicIndM
      Do  i=1,nfrag
11       read(90,*,err=11) FicLabFr(i)
         write(*,*) FicLabFr(i)
12       read(90,*,err=12) FicIndFr(i)
         write(*,*) FicIndFr(i)
      Enddo
      
* Ouverture des fichiers correspondants
      
      open(8,file=FicScript,status='unknown',form='formatted')
      open(11,file=FicLabM,status='unknown',form='formatted')
      open(12,file=FicIndM,status='unknown',form='formatted')
      num=13
      Do  i=1,nfrag
         open(num,file=FicLabFr(i),status='unknown',form='formatted')
         num=num+1
         open(num,file=FicIndFr(i),status='unknown',form='formatted')
         num=num+1
      Enddo
      
      
      
* Confection des fichiers d'index des OMs du polyene initial
* et des fragments
      
      read(11,*) bid
*     write(*,*) bid
      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
      
      num=13
      Do k=1,nfrag
         read(num,*) bid
*        write(*,*) bid
         read(num,1000) (nomOM(i), i=1,nOAM)
*        write(*,1000) (nomOM(i), i=1,nOAM)
         close(num)
         ncompt=0
         Do i=1,nsym
            Do j=1,nbOM(i)
               ncompt=ncompt+1
               write(num+1,2000) nomOM(ncompt), i, j
            enddo
         enddo
         num=num+2
      enddo
      
      call LECNAM('&FRAG',car,90,ierr,1)
      Do
         read(90,'(A)',end=30) car
         car=adjustl(car)
         long=len_trim(car)
         call suppdb(car,long)
         write(6,'(A)') trim(car)
         call maj(car,long)
         if(car(1:4).eq.'FRAG') then
            i=1
            Do
               read(90,'(A)',end=30) car
               car=adjustl(car)
               long=len_trim(car)
               call suppdb(car,long)
               call maj(car,long)
               ideb=1
               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
      
               if(car(1:3).eq.'SEC')exit
            enddo
            write(6,*) 'nomfrag' ,(nomFrag(k),k=1,i-1)
         endif
         exit
      enddo
      stop
30    continue
      
      
      
      
* Comparaison des fichiers d'index pour creer les scripts de
* recup des OMs du polyene
      
      
      
      
      
      
      close(8)
      close(12)
      
      icompt=13+nfrag*2
      Do i=13,icompt,2
         close(i)
      enddo
      
* Formats
1000  format(4(12X,A6))
2000  format(A6,2X,I3,2X,I3)
      end
      
