      program faiano
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! faiano
      ! fabrication d'ANO
      ! Utilisation :
      ! 1. faire un calcul scf ou casscf pour obtnir les OM a partir
      ! desquelles on construira les ANO. Copier le fichier d'orbitales
      ! dans un fichier nomme ORB
      ! 2. extraire du fichier dans baslib_library de molcas 
      ! la base qui nous interesse (extraire TOUT ce qui concerne
      ! l'atome, c.a.d. jusqu'a la ligne qui precede la donnee de
      ! l'atome suivant)
      ! 3. l'ecrire dans le fichier nomme BAS
      ! 4. Editer le fichier BAS. Il faut lui donner une forme bien
      ! definie (car les differentes base donnees dans baslib_library
      ! ont des formats tres variables)
          ! ligne 1 definition du pseudo
          ! lignes 2,3 commentaires
          ! ligne 1 charge, lmax
          ! ligne 4 : vide
          ! ligne 5 : ngauss, ncont pour les s
          ! ngauss lignes exposants (1 par ligne !)
          ! ngauss lignes de ncont coefs (les ncont coefs peuvent etre
          ! sur plusieurs lignes). Completer les lignes si necessaire,
          ! pour bien avoir ncont coefs, comme dans l'exemple donne
          !  ngauss, ncont pour les p
          ! ...
          ! 
          ! exemple qui marche :
          !
! /Ni.ECP.Seijo.9s6p6d.3s3p4d.16e-NR-AIMP.
! L.Seijo, Z.Barandiaran, and S. Huzinaga, J.Chem.Phys. 91(1989)7011
! core[Mg] val[3p,4s,3d]     (711/411*/3111d)=3s3p4d recomended
!  16.000000         2
! 
!     9    3
!    4285.323290
!    651.9116660
!    148.4310420
!    14.61565810
!    5.084914950
!    2.695829830
!    .9637774780
!    .1247067220
!    .4440127210E-01
!   -.001291434550  0.  0.
!   -.008765641940  0.  0.
!   -.026885866400  0.  0.
!    .120663572000  0.  0.
!    .088548487800  0.  0.
!   -.211511413000  0.  0.
!   -.300423481000  0.  0.
!    .616312812000  1.  0.
!    .514892857000  0.  1.
!     6    3
!    335.2111400
!    78.05211610
!    23.61618700
!    2.862374010
!    .9462498720
!    .1110000000
!   -.017329090100   .000000000000   .000000000000
!   -.105886106000   .000000000000   .000000000000
!   -.251733492000   .000000000000   .000000000000
!    .623521318000   .000000000000   .000000000000
!    .470407510000  1.000000000000  0.000000000000
!    .000000000000  0.000000000000  1.000000000000
!    47.29662940
!    13.20797580
!    4.435978690
!    1.482292030
!    .4385855920
!    .1316000000
!    .028692884000   .000000000000   .000000000000   .000000000000
!    .153696374000   .000000000000   .000000000000   .000000000000
!    .374873996000   .000000000000   .000000000000   .000000000000
!    .473227536000  1.000000000000   .000000000000   .000000000000
!    .312182257000   .000000000000  1.000000000000   .000000000000
!    .000000000000   .000000000000   .000000000000  1.000000000000
! *
! * Core AIMP: NI3F-3S
! *
! * Local Potential Paramenters : (ECP convention)
! *                               A(AIMP)=-Zeff*A(ECP)
! M1
!    10
!    305000.0000
!    40270.00000
!    ...

      ! 4. lancer faiano, sans donnees
      ! si le programme donne une erreur du genre :
      ! on selectionne trop d'orbitales
      ! ou
      ! stop  kk.ne.nbcon
      ! c'est que le OM sont tres impure (melanges Px/Py par exemple) et
      ! n'ont pas pu etre reconnues. 
      ! Les purifier d'abord :
      ! lancer purigom (sans donnees, il lit le fichier BAS, il cree le
      ! fichier "PUR") ; mv PUR BAS ; lancer faiano
      ! 5. La base ANO est dans un fichier nomme ANO
      ! copier ce fichier dans un fichier dont le nom est celui du
      ! fichier dans lequel on a pris la base dans baslib_library
      ! cp ANO ...
      ! 6. ajouter dans le script l'emplacement de la nouvelle base
      !   exemple ln -sf ${CurrDir} BASLIB
      ! 7. verifier en relancant seward, scf
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      use mod_lirorb
      implicit double precision (a-h,o-z)
      character(80) aa
      character(4) format
      dimension expo(1000),isym(8)
      double precision,allocatable,dimension(:,:) :: 
     *coefs,coefp,coefd,coeff,om,oms,omp,omd,omf
      print*,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
      print*,'!!!!!!!!!!!!!!! FAIANO !!!!!!!!!!!!!!!!!!!!!'
      print*,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'

      open(1,file='BAS',status='old')
      !
      ! types presents
      !
      format='(i0)'
      read(1,'(a80)') aa
      do k=1,4
         ii=index(aa,'.')
         aa(ii:ii)=' '
      enddo
      aa(1:ii)=' '
      aa=adjustl(aa)
      ii=index(aa,'.')
      j1=1
      nbcons=0
      nbconp=0
      nbcond=0
      nbconf=0
      do k=1,ii
         if(aa(k:k)=='s') then
            j2=k-1
            l=j2-j1+1
            write(format(3:3),'(i1)') l
            read(aa(j1:j2),format) nbcons
            j1=k+1
         else if(aa(k:k)=='p') then
            j2=k-1
            l=j2-j1+1
            write(format(3:3),'(i1)') l
            read(aa(j1:j2),format) nbconp
            j1=k+1
         else if(aa(k:k)=='d') then
            j2=k-1
            l=j2-j1+1
            write(format(3:3),'(i1)') l
            read(aa(j1:j2),format) nbcond
            j1=k+1
         else if(aa(k:k)=='f') then
            j2=k-1
            l=j2-j1+1
            write(format(3:3),'(i1)') l
            read(aa(j1:j2),format) nbconf
            j1=k+1
         endif
      enddo
      print*,' '
      print*,'nb contractees s,p,d,f ',nbcons,nbconp,nbcond,nbconf
      print*,' '
      !
      ! Lecture des exposants et des coefficients
      !
      call saut(1,4)
      nbs=0
      nbp=0
      nbd=0
      nbf=0
      print*,'Anciennes contraction'
      if(nbcons.ne.0) then
         call lirexp(nbs,nbcons,expo)
         allocate(coefs(nbs,nbcons))
         call lircoef(nbs,nbcons,coefs)
      endif
      if(nbconp.ne.0) then
         call lirexp(nbp,nbconp,expo(nbcons+1))
         allocate(coefp(nbp,nbconp))
         call lircoef(nbp,nbconp,coefp)
      endif
      if(nbcond.ne.0) then
         call lirexp(nbd,nbcond,expo(nbcons+nbconp+1))
         allocate(coefd(nbd,nbcond))
         call lircoef(nbd,nbcond,coefd)
      endif
      if(nbconf.ne.0) then
         call lirexp(nbf,nbconf,
     *   expo(nbcons+nbconp+nbcond+1))
         allocate(coeff(nbf,nbconf))
         call lircoef(nbf,nbconf,coeff)
      endif
      print*,'nbs,nbcons',nbs,nbcons
      print*,'nbp,nbconp',nbp,nbconp
      print*,'nbd,nbcond',nbd,nbcond
      print*,'nbf,nbconf',nbf,nbconf
      !
      ! Lecture des om
      !
      norb=nbcons+nbconp*3+nbcond*5+nbconf*7
      print*,'norb',norb
      allocate(om(norb,norb))
      call lirorb('ORB',norb,nsym,isym,3,2)
      print*,'norb',norb,nsym
      if(nsym/=1) then
         print*,'Le calcul SCF ou CASSCF doit avoir ete fait '//
     *   'sans symetrie'
         stop
      endif
      rewind 3
      close(2)
      print*,'om',shape(om)
      read(3) om
      close(3,status='delete')
      print*,' '
      print*,'Orbitales lues'
      print*,' '
      call script(om,norb,norb,norb,norb)
      !
      ! choix des om de reference
      !
      if(nbcons.ne.0) then
         print*,'Orbitales S'
         allocate (oms(nbcons,nbcons))
         call choix(oms,nbcons,om,norb,0,1)
         call script(oms,nbcons,nbcons,nbcons,nbcons)
      endif
      if(nbconp.ne.0) then
         print*,'Orbitales P'
         allocate (omp(nbconp,nbconp))
         call choix(omp,nbconp,om,norb,nbcons,3)
         call script(omp,nbconp,nbconp,nbconp,nbconp)
      endif
      if(nbcond.ne.0) then
         print*,'Orbitales D'
         allocate (omd(nbcond,nbcond))
         call choix(omd,nbcond,om,norb,nbcons+nbconp*3,5)
         call script(omd,nbcond,nbcond,nbcond,nbcond)
      endif
      if(nbconf.ne.0) then
         print*,'Orbitales F'
         allocate (omf(nbconf,nbconf))
         call choix(omf,nbconf,om,norb,nbcons+nbconp*3+nbcond*5,7)
         call script(omf,nbconf,nbconf,nbconf,nbconf)
      endif
      print*,' '
      print*,'Nouvelles contractions'
      if(nbcons.ne.0) then
         coefs=matmul(coefs,oms)
         call script(coefs,nbs,nbcons,nbs,nbcons)
      endif
      if(nbconp.ne.0) then
         coefp=matmul(coefp,omp)
         call script(coefp,nbp,nbconp,nbp,nbconp)
      endif
      if(nbcond.ne.0) then
         coefd=matmul(coefd,omd)
         call script(coefd,nbd,nbcond,nbd,nbcond)
      endif
      if(nbconf.ne.0) then
         coeff=matmul(coeff,omf)
         call script(coeff,nbf,nbconf,nbf,nbconf)
      endif
      !
      ! on fabrique le nouveau fichier de base
      !
      rewind 1
      open(3,file='ANO',status='unknown')
      open(4,file='DECONT',status='unknown')
      call modifc(nbs,nbp,nbd,nbf)
      call copiec(5)
      if(nbcons.ne.0) then
         call copie(nbs)
         call modif(coefs,nbs,nbcons)
         call copiec(1)
      endif
      if(nbconp.ne.0) then
         call copie(nbp)
         call modif(coefp,nbp,nbconp)
         call copiec(1)
      endif
      if(nbcond.ne.0) then
         call copie(nbd)
         call modif(coefd,nbd,nbcond)
         call copiec(1)
      endif
      if(nbconf.ne.0) then
         call copie(nbf)
         call modif(coeff,nbf,nbconf)
         call copiec(1)
      endif
      do
         read(1,'(a80)',end=2) aa
         write(3,'(a)') trim(aa)
         write(4,'(a)') trim(aa)
      enddo
  2   continue
      end
     
       subroutine modifc(nbs,nbp,nbd,nbf)
      character(80) aa,bb,cc
      rewind 1
      bb=' '
      read(1,'(a80)') aa
      write(3,'(a)') trim(aa)
      do k=1,4
         ii=index(aa,'.')
         aa(ii:ii)=' '
      enddo
      ich1=ii
      ii=index(aa,'.')
      ich2=ii
      ich3=len_trim(aa(ich2:80))
      rewind 1
      ideb=1
      call modifc2(bb,nbs,'s',ideb,ifin)
      call modifc2(bb,nbp,'p',ideb,ifin)
      call modifc2(bb,nbd,'d',ideb,ifin)
      call modifc2(bb,nbf,'f',ideb,ifin)
      rewind 1
      read(1,'(a80)') cc
      cc(ich1+1:ich1+ifin)=bb(1:ifin)
      cc(ich1+ifin+1:80)=aa(ich2:ich2+ich3)
      write(4,*) trim(cc)
      return
      end
       subroutine modifc2(bb,nbs,c,ideb,ifin)
      character(80) aa,bb
      character c
      if(nbs==0) return
      write(bb(ideb:ideb+1),'(i2)') nbs
      bb(ideb:ideb+1)=adjustl(bb(ideb:ideb+1))
      l=len_trim(bb(ideb:ideb+2))
      ifin=ideb+l
      bb(ifin:ifin)=c
      ideb=ifin+1
      return
      end

       subroutine copiec(n)
      character(80) aa
 1    format(a80)
      print*,'entree copiec',n
      do k=1,n
         read(1,1,end=2) aa
         do while(aa(1:1)=='*')
            write(3,'(a)') trim(aa)
            write(4,'(a)') trim(aa)
            read(1,1) aa
         enddo
         write(3,'(a)') trim(aa)
         write(4,'(a)') trim(aa)
      enddo
 2    continue
      return
      end
       subroutine copie(n)
      character(80) aa
      double precision v
 1    format(a80)
 2    format(f17.8)
      if(n.eq.0) return
      do k=1,n
         read(1,1) aa
         do while(aa(1:1)=='*')
            write(3,1) aa
            write(4,1) aa
            read(1,1) aa
         enddo
         read(aa,*) v
         write(3,2) v
         write(4,2) v
      enddo
      return
      end
       subroutine modif(coef,n,nbcon)
      double precision coef(n,nbcon)
      double precision v(1000)
 2    format(6f13.8)
 3    format(20f5.1)
      do k=1,n
         read(1,*) v(1:nbcon)
         write(3,2) coef(k,:)
         v=0.d0
         v(k)=1.d0
         write(4,3) v(1:n)
      enddo
      return
      end
     
       subroutine choix(oms,nbcon,om,norb,idep,mul)
      double precision om(norb,norb),oms(nbcon,nbcon)
      double precision,allocatable,dimension(:) :: v
      double precision,allocatable,dimension(:,:) :: om2
      dimension is(1000)
      logical,allocatable :: y(:)
      allocate(v(norb),y(norb))
      allocate(om2(nbcon*mul,mul))
      y=.false.
      do k=1,norb
         v(k)=sum(om(idep+1:idep+nbcon*mul,k)**2)
         v(k)=v(k)/sum(om(1:norb,k)**2)
         !print*,'k,v(k)',k,v(k)
      enddo
      ! si mul>1, les vecteurs retenus arrivent par paquets de mul
      ! on prend le premier du paquet
      if(mul>1) then
      do k=1,norb
         if(y(k)) cycle
         if(v(k)>1.d-2) then
            om2=0.d0
            do l=k+1,k+mul-1
               v(l)=0.d0
            enddo
            !print*,'1er du paquet',k
            !print*, v
            ! on purifie les om
            kk=0
            do m=1,mul
               do n=1,nbcon
                  kk=kk+1
                  om2(kk,m)=sum(om(idep+kk,k:k+mul-1))
                  y(k+mul-1)=.true.
               enddo
            enddo
            !call script(om2,nbcon*mul,mul,nbcon*mul,mul)
            om(idep+1:idep+nbcon*mul,k:k+mul-1)=om2
         endif
      enddo
      endif
      kk=0
      do k=1,norb
         if(v(k)>1.d-2) then
            kk=kk+1
            if(kk>nbcon*mul) then
               print*,'on selectionne trop d''orbitales'
               print*,is(1:nbcon)
               stop
            endif
            is(kk)=k
         endif
      enddo
      if(kk.ne.nbcon) then
         print*,'stop  kk.ne.nbcon',kk,nbcon
         stop
      endif
      print'(a,30i3)','place dans la matrice des OM',is(1:kk)
      !call script(om,norb,norb,norb,norb)
      oms(1:nbcon,1:nbcon)=om(idep+1:idep+nbcon,is(1:nbcon))
      deallocate(v)
      return
      end
      
       subroutine lircoef(nbe,nbcon,coef)
      double precision coef(nbe,nbcon)
      do k=1,nbe
         read(1,*) coef(k,1:nbcon)
      enddo
      call script(coef,nbe,nbcon,nbe,nbcon)
      return
      end
     
       subroutine lirexp(nbe,nbcon,expo)
      double precision expo(1000)
      call saute_commentaires(1)
      read(1,*,end=2) nbe,nbcon
      read(1,*) expo(1:nbe)
 2    continue
      return
      end
     
     
       subroutine saut(ifil,n)
      do k=1,n
         read(ifil,*)
      enddo
      end
       subroutine saute_commentaires(ifil)
      implicit double precision (a-h,o-x,z),logical(1)(y)
      character(80) aa
      yw=.false.
      aa(1:1)='*'
      do while (aa(1:1)=='*')
         read(1,'(a80)') aa
         if(yw)print*,trim(aa)
      enddo
      backspace 1
      return
      end

