      PROGRAM CreNoin
* Ce programme permet de creer le fichier de donnees Frag$i.noin 
* de chaque "fragment" a partir du fichier de donnees $Project.noin 
* qui contient les infos de la molecule "entiere" et des fichier 
* Frag$i.olout (Nombre d'orbitales frozen ou deleted!) 
           
      implicit double precision (a-h,o-x,z),logical*1(y)
      parameter (maxsym=8,nOAmax=400,nfragmax=100)
      character car*300, nomFrag*10
      character Fic*80,FicNoinM*85
      character bid*80, nufrag*2, nomfic*80, nomfic2*80
      character namel*500,chaine*80,car2*300
      character nam*10, numer*3
      dimension nfroz(maxsym), ndel(maxsym), nferm(maxsym)
      dimension nbom(maxsym), nfred(maxsym)
      print*,' '
      print*,'**************************************************'
      print*,'               creanoin'
      print*,'**************************************************'
      print*,' '
      
      
* sauvegarde du ficher de donnees

      open(93,file='BID93')
      call sto5

* 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)

      
* Ouverture du fichier FRAGIN (90) contenant les donnees 
* (Nfrag et nom du projet) et lecture des infos
      
      open(90,file='FRAGIN',status='old',form='formatted')
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
      
9     read(90,'(A)',err=9) Fic
      FicNoinM=trim(Fic)//'.noin'
      write(*,*) FicNoinM
      close(90)
     
* Ouverture du fichier $Project.noin (10)
      open(10,file=FicNoinM,status='old',form='formatted')
      

* Ouverture des Nfrag fichiers Frag$i.noin et Frag$i.olout_red
* et "remplissage" des Frag$i.noin 

      Do ifrag=1,Nfrag
 
         num=10+ifrag
         num2=11+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)//'.noin'
         print*,'fichier noin cree            : ',trim(nomfic)
         nomfic2='frag'//trim(numer)//'.olout_red'
         print*,'fichier red cree             : ',trim(nomfic2)
         open(num,file=nomfic,status='unknown',form='formatted')
         open(num2,file=nomfic2,status='old',form='formatted')

         rewind(10)
         call LECNAM('&NOFIL',namel,10,ierr,0)
         write(*,*) 'Namelist &nofil :', trim(namel)
         write(num,'(A7,A,A)')'&nofil ',trim(namel)
         call addon('NOFIL'//trim(numer),num)
         write(num,'(A)')' /'
         write(6,'(A)')' /'
         write(num,'(A)')'&no'
         write(6,'(A)')'&no'
         write(num,'(A)')' data=''AUTO'''
         write(6,'(A)')' data=''AUTO'''

         read(num2,'(A42,10(I4))') bid, nferm(1:nsym) 
         write(*,'(A,10(I3))') bid, nferm(1:nsym) 
         read(num2,'(A80)') bid
c         print*, trim(bid)
         read(num2,'(a)') car
c         print*, trim(car)
         read(num2,*) nfroz(1:nsym)
c         print*, nfroz(1:nsym)
         write(num,'(A,A1,10(I3,A))') trim(car),'= '
     *    ,(nfroz(is),',',is=1,nsym) 
         write(6,'(A,A1,10(I3,A))') trim(car),'= '
     *    ,(nfroz(is),',',is=1,nsym) 

         read(num2,'(a)') car
c         print*, trim(car)
         read(num2,*) ndel(1:nsym)
c         print*, ndel(1:nsym)
         write(num,'(A,A1,10(I3,A))') trim(car),'= '
     *    ,(ndel(is),',',is=1,nsym) 
         write(6,'(A,A1,10(I3,A))') trim(car),'= '
     *    ,(ndel(is),',',is=1,nsym) 
         Do is=1,nsym
              nfred(is)=nferm(is)-nfroz(is)
         enddo
         write(num,'(A,10(I3,A))') ' FERMI = '
     *       ,(nfred(is),',',is=1,nsym)
         write(6,'(A,10(I3,A))') ' FERMI = '
     *       ,(nfred(is),',',is=1,nsym)
         call addon('NO'//trim(numer),num)
         write(num,'(A)') ' / '
         write(6,'(A)') ' / '

         rewind 10
         call LECNAM('&CASDI',namel,10,ierr,0)
         write(num,'(A7,A)')'&casdi ',trim(namel)
         write(6,'(A7,A)')'&casdi ',trim(namel)
         call addon('CASDI'//trim(numer),num)
         write(num,'(A2)') ' /'
         write(6,'(A2)') ' /'
         close(num)
         close(num2)
      enddo


       close(90)
       close(10)
       
      end
      
