      program purigom
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! purigom
      !
      ! Le programme est prevu pour marcher avec faiano
      ! Les orbitales sont celles d'un atome, calcule en symetrie 1
      ! Il n'y a pas de donnees
      ! en entree : 1 fichier "BAS" contenant la base format 
      !             bases_library de molcas
      !             un fichier d'orbitales format molcas nomme "ORB"
      ! en sortie : 1 fichier "PUR" contenant la base format 
      !             bases_library de molcas (purifiee)
      !
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      use mod_lirorb
      implicit double precision (a-h,o-z)
      character(80) aa
      character(4) format
      dimension occup(1000),isym(8),ityp(1000)
      dimension ompp(3,3),omdd(5,5),omff(7,7)
      double precision,allocatable,dimension(:,:) :: 
     *coefs,coefp,coefd,coeff,om,oms,omp,omd,omf,omp1,omd1,omf1
      print*,' '
      print*,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
      print*,'!!!!!!!!!!!!!!! PURIGOM !!!!!!!!!!!!!!!!!!!'
      print*,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
      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
      nbconsp=nbcons+nbconp*3
      nbconspd=nbcons+nbconp*3+nbcond*5
      nbconspdf=nbcons+nbconp*3+nbcond*5+nbconf*7
      print*,' '
      print*,'nb contractees s,p,d,f ',nbcons,nbconp,nbcond,nbconf
      print*,' '
      !
      ! Lecture des om
      !
      call lirorb('ORB',norb,nsym,isym,3,2)
      allocate(om(norb,norb))
      print*,'norb',norb,nsym
      rewind 3
      close(2)
      read(3) om
      read(3) occup(1:norb)
      close(3,status='delete')
      !call script(om,norb,norb,norb,norb)
      !
      ! Type des OM
      !
      print*,'nb contractees s,p,d,f ',nbcons,nbconsp,nbconspd,nbconspdf
      print*,' '
      print*,'Orbitales lues'
      call script(om,norb,norb,norb,norb)
      do k=1,norb
         cc=0.d0
         do l=1,nbcons
            cc=cc+om(l,k)*om(l,k)
         enddo
         cc=dsqrt(cc)
         if(cc>1.d-2) then
            ityp(k)=1
            cycle
         endif
         cc=0.d0
         do l=1+ncons,nbconsp
            cc=cc+om(l,k)*om(l,k)
         enddo
         cc=dsqrt(cc)
         if(cc>1.d-2) then
            ityp(k)=2
            cycle
         endif
         cc=0.d0
         do l=1+nconsp,nbconspd
            cc=cc+om(l,k)*om(l,k)
         enddo
         cc=dsqrt(cc)
         if(cc>1.d-2) then
            ityp(k)=3
            cycle
         endif
         cc=0.d0
         do l=1+nconspd,nbconspdf
            cc=cc+om(l,k)*om(l,k)
         enddo
         cc=dsqrt(cc)
         if(cc>1.d-2) then
            ityp(k)=4
            cycle
         endif
      enddo
      print*,'Type des OM'
      print'(20i3)',ityp(1:norb)
      allocate (omp(nbconp*3,3))
      allocate (omd(nbcond*5,5))
      allocate (omf(nbconf*7,7))
      allocate (omp1(nbconp*3,3))
      allocate (omd1(nbcond*5,5))
      allocate (omf1(nbconf*7,7))
      ncyc=0
      ! Boucle sur les orbitales
      b1: do k=1,norb
         print*,'ncyc,k',ncyc,k
         do while (ncyc.ne.0)
            ncyc=ncyc-1
            cycle b1
         enddo
         print*,'1ncyc,k',ncyc,k
         if(ityp(k)==1) cycle
         if(ityp(k)==2) then
            omp=om(nbcons+1:nbcons+nbconp*3,k:k+2)
            omp1=0.d0
            print*,'orbitales extraites'
            call script(omp,nbconp*3,3,nbconp*3,3)
            omp1(1:nbconp,1)=dsqrt(sum(omp(1:nbconp,1:3)**2,dim=2))
            omp1(nbconp+1:nbconp*2,2)=
     *      dsqrt(sum(omp(nbconp+1:nbconp*2,1:3)**2,dim=2))
            omp1(nbconp*2+1:nbconp*3,3)=
     *      dsqrt(sum(omp(nbconp*2+1:nbconp*3,1:3)**2,dim=2))
            ncyc=2
            do kk=1,nbconp*3
               sgn=sum(omp(kk,:))
               sgn=sgn/dabs(sgn)
               omp1(kk,:)=omp1(kk,:)*sgn
            enddo
            call script(omp1,nbconp*3,3,nbconp*3,3)
            om(nbcons+1:nbcons+nbconp*3,k:k+2)=omp1
         endif
         if(ityp(k)==3) then
            omd=om(nbconsp+1:nbconspd,k:k+4)
            omd1=0.d0
            print*,'orbitales extraites'
            call script(omd,nbcond*5,5,nbcond*5,5)
            omd1(1:nbcond,1)=dsqrt(sum(omd(1:nbcond,1:5)**2,dim=2))
            omd1(nbcond+1:nbcond*2,2)=
     *      dsqrt(sum(omd(nbcond+1:nbcond*2,1:5)**2,dim=2))
            omd1(nbcond*2+1:nbcond*3,3)=
     *      dsqrt(sum(omd(nbcond*2+1:nbcond*3,1:5)**2,dim=2))
            omd1(nbcond*3+1:nbcond*4,4)=
     *      dsqrt(sum(omd(nbcond*3+1:nbcond*4,1:5)**2,dim=2))
            omd1(nbcond*4+1:nbcond*5,5)=
     *      dsqrt(sum(omd(nbcond*4+1:nbcond*5,1:5)**2,dim=2))
            ncyc=4
            do kk=1,nbcond*5
               sgn=sum(omd(kk,:))
               sgn=sgn/dabs(sgn)
               omd1(kk,:)=omd1(kk,:)*sgn
            enddo
            call script(omd1,nbcond*5,5,nbcond*5,5)
            om(nbconsp+1:nbconspd,k:k+4)=omd1
         endif
         if(ityp(k)==4) then
            omf=om(nbconspd+1:nbconspdf,k:k+6)
            print*,'orbitales extraites'
            call script(omf,nbconf*7,7,nbconf*7,7)
            omf1(1:nbconf,1)=dsqrt(sum(omf(1:nbconf,1:7)**2,dim=2))
            omf1(nbconf+1:nbconf*2,2)=
     *      dsqrt(sum(omf(nbconf  +1:nbconf*2,1:7)**2,dim=2))
            omf1(nbconf*2+1:nbconf*3,3)=
     *      dsqrt(sum(omf(nbconf*2+1:nbconf*3,1:7)**2,dim=2))
            omf1(nbconf*3+1:nbconf*4,4)=
     *      dsqrt(sum(omf(nbconf*3+1:nbconf*4,1:7)**2,dim=2))
            omf1(nbconf*4+1:nbconf*5,5)=
     *      dsqrt(sum(omf(nbconf*4+1:nbconf*5,1:7)**2,dim=2))
            omf1(nbconf*5+1:nbconf*6,6)=
     *      dsqrt(sum(omf(nbconf*5+1:nbconf*6,1:7)**2,dim=2))
            omf1(nbconf*6+1:nbconf*7,7)=
     *      dsqrt(sum(omf(nbconf*6+1:nbconf*7,1:7)**2,dim=2))
            ncyc=6
            do kk=1,nbconf*7
               sgn=sum(omf(kk,:))
               sgn=sgn/dabs(sgn)
               omf1(kk,:)=omf1(kk,:)*sgn
            enddo
            call script(omf1,nbconf*7,7,nbconf*7,7)
            om(nbconspd+1:nbconspdf,k:k+6)=omf1
         endif
      enddo b1
      print*,'matrice purifiee'
      call script(om,norb,norb,norb,norb)
      deallocate(omp,omd,omf,omp1,omd1,omf1)
      open(3,file='PURIG',status='unknown',form='unformatted')
      write(3) om
      write(3) occup(1:norb)
      call ecriorb('* Orbitales purifiees','PUR',nsym,isym,3,2,
     *nolabels=.true.)
      close(3,status='delete')
      end
     
