      program desymorb_via_molden
      use mod_lirorb
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(10000) namel
      character(80) prefix,molden,info1,info,orb,mono,mono1
      character(20) basis(1000),basis1
      character(4) atom(1000),bas,atom1
      character(50) rasscf_data(25)
      allocatable ol(:,:),p(:,:),s(:,:),ol0(:,:),iord(:)
      character(17) c
      character(8),save,allocatable,dimension(:) :: orbi,orbi2
      character(18),allocatable,dimension(:) :: tipo
      double precision,allocatable,dimension(:) :: occup
      allocatable y(:)
      dimension isym(8)
      logical exist_labels,rasscf
      yw=.true.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Desymetrisation des orbitales molcas (fichier type INPORB)
! 1) execute un rasscf CIONLY
! 2) recupere le fichier molden, lit les orbitales desymetrisees
! 3) recupere les labels des OA, les reordonne
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      print*,'====================================================='
      print*,' desymorb desymorb desymorb desymorb desymorb'
      print*,'====================================================='
      print*,' '
!
!
! Lecture des donnees
!
      call LECNAM('&DESYMORB ',namel,5,ierr,1)
      prefix=' '
      basis=' '
      orb='INPORB'
      info1=' '
      mono1=' '
      info='Info'
      mono='Mono'
      rasscf=.true.
      call namela(namel,prefix,'PREFIX')
      call namela(namel,BASIS,'BASIS')
      call namela(namel,MONO1,'MONO1')
      call namela(namel,MONO,'MONO')
      call namela(namel,INFO1,'INFO1')
      call namela(namel,INFO,'INFO')
      call namell(namel,RASSCF,'RASSCF',4)
      if(info1==' ') info1=trim(prefix)//trim(info)
      if(mono1==' ') mono1=trim(prefix)//trim(mono)
!
! ouvertures
!
      open(2,file=INFO1,status='old')
!
! generations donnees rasscf
!
      if(rasscf) then
      rasscf_data(1)=' &RASSCF &END'
      rasscf_data(2)='Title'
      rasscf_data(3)=' test'
      rasscf_data(4)='Symmetry'
      rasscf_data(5)=' 1'
      rasscf_data(6)='Spin'
      rasscf_data(7)=' 1'
      rasscf_data(8)='Frozen'
      rasscf_data(9)=' 0  0  0  0  0  0  0  0'
      rasscf_data(10)='nActEl'
      rasscf_data(11)=' 0 0 0'
      rasscf_data(12)='Inactive'
      rasscf_data(13)=' 1  0  0  0  1  0  0  0'
      rasscf_data(14)='Ras2'
      rasscf_data(15)=' 0  0  0  0  0  0  0  0'
      rasscf_data(16)='Iterations'
      rasscf_data(17)='50 50'
      rasscf_data(18)='Lumorb'
      rasscf_data(19)='cionly'
      rasscf_data(20)='thrs'
      rasscf_data(21)='   1.0e-06  1.0e-05   1.0e-05'
      rasscf_data(22)='End of input'
      rasscf_data(23)=' &RASREAD &END'
      rasscf_data(24)='Average Orbitals'
      rasscf_data(25)='End of input'
      open(3,file='RASIN',status='unknown')
      do k=1,25
         write(3,'(a)') rasscf_data(k)
      enddo
      close(3)
      endif
!
! on lit INPORB pour recuperer les occupations et les labels
!
      print*,
     *'on lit INPORB pour recuperer les occupations et les labels'
      call lirorb('INPORB',noa,nsym,isym,4,1,ifiloc=8,ifillab=10
     *,exist_labels=exist_labels)
!
! On recupere les orbitales a desymetriser dans ol0
!
      allocate(ol0(noa,noa))
      ol0=0.d0
      rewind 4
      ifin=0
      do k=1,nsym
         if(isym(k)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(k)
         read(4) ol0(ideb:ifin,ideb:ifin)
      enddo
      rewind 4
      
!
! on reecrit les OM en mettant toutes les occupations a 1,
! pour que molden ecrive toutes les OM
!
      if(rasscf) then
      call system('cp INPORB INPORBsv')
      open(12,file='MOLDENORB',status='unknown',form='unformatted')
      ifin=0
      do k=1,nsym
         if(isym(k)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(k)
         write(12) (/(1.d0,k=ideb,ifin)/)
      enddo
      rewind 1
      call ecriorb('* RASORB MODIFIEES INSERORB','INPORB',
     *nsym,isym,4,1
     *,ifiloc=12,ifillab=10,nolabels=.not.exist_labels)
      close(12,status='delete')
      close(1)
      endif
!
! execution rasscf
!
      if(rasscf) then
      call system('molcas run rasscf RASIN > RASOUT')
      call system('molcas run rasread RASIN >> RASOUT')
      call system('cp INPORBsv INPORB')
      endif
!
! on recupere les occupations et les labels a partir de INPORB
!
      allocate(tipo(noa))
      allocate(occup(noa))
      rewind 8
      ifin=0
      do k=1,nsym
         if(isym(k)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(k)
         read(8) occup(ideb:ifin)
      enddo
      ifin=0
      tipo=' '
      rewind 10
      do k=1,nsym
         if(isym(k)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(k)
         if(exist_labels) then
            read(10) tipo(ideb:ifin)
         else
            do l=ideb,ifin
               write(tipo(l)(1:5),'(a3,i2)') 'sym',k
            enddo
         endif
      enddo
      if(yw) then
         print*,'tipo'
         do k=1,noa
            print*,k,tipo(k)
         enddo
      endif
      close(1)
!
! on recupere orbi sur INFO
!
      call LECNAM('&COST_AO',namel,2,ierr,1)
      call nameli(namel,noa,'NORB',4)
      call nameli(namel,NSYM,'NSYM',4)
      allocate(orbi(noa))
      allocate(orbi2(noa))
      call namela(namel,ORBI,'LABEL')
      call nameli(namel,NATOM,'NATOM',4)
      call namela(namel,ATOM,'ATOM')
      print*,'natom',natom
      do k=1,noa
         call maj(orbi(k),8)
      enddo
      do k=1,natom
         i=index(basis(k),':')
         call maj(basis(k),20)
         call maj(atom(k),4)
         print*,'basis apres maj',basis(k)
      enddo
      if(yw)print*,'orbi lu dans &COST_AO'
      if(yw)print*, orbi
      print*, ' '
!
! Ecriture des OM a desymetriser
!
      print*,'orbitales lues, a desymetriser'
      call scriptol(ol0,noa,noa,noa,noa,orbi
     *,(/(k,k=1,noa)/),tipo(:)(1:12),occup)
         
!
! On recupere les orbitales sur molden
!
      molden=trim(prefix)//'rasscf.molden'
      open(1,file=MOLDEN,status='old')
      allocate(ol(noa,noa))
      ol=0.d0
      i=0
      do
         read(1,'(a,f11.4)',end=1) c
         if(c(1:6)=='Occup=') then
            read(c(7:17),*) a
            i=i+1
            do k=1,noa
               read(1,'(i4,f19.8)') i4,ol(k,i)
            enddo
         endif
      enddo
 1    continue
      if(yw)print*,'orbitales recuperees sur molden'
      if(yw)call mscript(ol)
!
! On regenere orbi
!
      allocate(y(noa))
      y=.false.
      ind=0
      orbi2=' '
      ! boucle sur les atomes
      do iat=1,natom
         ind0=ind
         print*,'Atome ',atom(iat)
         ! Nombre d'OA de la base de l'atome iat
         l=0
         do ibas=1,natom
            basis1=basis(ibas)
            i=index(basis(ibas),':')
            if(yw)print*,'atom,basis',(atom(iat)),basis(ibas)(1:i-1)
     *      ,trim(atom(iat))==basis(ibas)(1:i-1)
            if(trim(atom(iat))==basis(ibas)(1:i-1)) then
               call longbas(basis1(1+i:20),l)
            endif
         enddo
         ! Multiplicite de l'atome iat
         n=0
         do i=1,noa
            if(trim(atom(iat))==trim(orbi(i)(1:4))) n=n+1
         enddo
         if(yw)print*,'n,l',n,l
         print*,'===Nombre d''atomes equivalents pour ',trim(atom(iat)),
     *   n/l 
         if(mod(n,l).ne.0) then
            print*,'erreur'
            stop
         endif
         neq=n/l
         ! fabrication de orbi2 pour l'atome iat
          basis1=basis(iat)
         call faborbi(basis1,'S',ind,orbi2,atom(iat),noa,neq)
         call faborbi(basis1,'P',ind,orbi2,atom(iat),noa,neq)
         call faborbi(basis1,'D',ind,orbi2,atom(iat),noa,neq)
         call faborbi(basis1,'F',ind,orbi2,atom(iat),noa,neq)
         call faborbi(basis1,'G',ind,orbi2,atom(iat),noa,neq)
         call faborbi(basis1,'H',ind,orbi2,atom(iat),noa,neq)
         call faborbi(basis1,'I',ind,orbi2,atom(iat),noa,neq)
         if(yw) then
            do k=1,ind
               print*,'orbi2',k,orbi2(k)
            enddo
         endif
         ind1=ind
         do i=2,neq
            do j=ind0+1,ind1
               ind=ind+1
               orbi2(ind)=orbi2(j)
            enddo
         enddo
         if(yw) then
            do k=1,ind
               print*,'ORBI regenere',k,orbi2(k)
            enddo
         endif
      enddo
!
! On reordonne les coefs de l'orb Molden pour les autres OA que les S
!
      call reor_oa_molden(ol,orbi2,noa)
!
! Ecritures
!
      print*,' '
      print*,'Orbitales desymorb / MOLDEN   (ordonnees par symetrie)'
      call scriptol(ol,noa,noa,noa,noa,orbi2
     *,(/(k,k=1,noa)/),tipo(:)(1:12),occup)
      close(4,status='delete')
      open(4,form='unformatted',status='unknown',file='bid4')
      write(4) ol
      write(4) occup
      write(4) tipo
      nsym=1
      isym(1)=noa
      call ecriorb('* Orbitales desymorb','DESYMORB',nsym,isym,4,8)
      close(4,status='delete')
      close(8)
      if(yw)print*,'DESYMORB2'
      open(4,form='unformatted',status='unknown',file='DESYMORB2')
      write(4) ol
      write(4) orbi2
!     
! Lecture de la matrice de recouvrement entre OA
!
      open(14,file=mono1,status='old',form='unformatted')
      allocate(s(noa,noa))
      s=0.d0
      call lis(14,s,'SYM  ',noa)
      if(yw)print*,'matrice de recouvrement entre OA'
      if(yw)call mscript(s)
!
! Orthogonalite de l'ancienne matrice d'OM
! 
      allocate(p(noa,noa))
      p=matmul(transpose(ol0),matmul(s,ol0))
      if(yw)print*,'verif orthogonalite ol0'
      if(yw)call mscript(p)
!
! passage de l'ordre en symetrie a l'ordre sans symetrie
!
! matrice de passage entre avant et apres disymetrisation
! ol0 : avant (par blocs) ; ol : apres
! P=mat de passege : ol=P*B => P=ol0*ol**(-1) => P**(-1)=ol*ol0(-1)
! or ol0(t)*S*ol=I => ol0(t)*S=ol0**(-1) =>
! P**(-1)=ol*ol0(t)*S or P**(-1)=P(t)  d'ou P
!
      p=transpose(matmul(ol,matmul(transpose(ol0),s)))
      ! normalisation
      do k=1,noa
         anorm=sum(p(:,k)*p(:,k))
         p(:,k)=p(:,k)/dsqrt(anorm)
      enddo
      if(yw)print*,
     *'matrice de passage entre avant et apres disymetrisation'
      if(yw)call mscript(p)
      write(4) p
!
! Matrice de recouvrement entre OA desymetrisees
!
      s=matmul(transpose(p),matmul(s,p))
      ! normalisation
      do k=1,noa
         fac=dsqrt(1.d0/s(k,k))
         s(:,k)=s(:,k)*fac
         s(k,:)=s(k,:)*fac
      enddo
      if(yw)print*,'Matrice de recouvrement entre OA desymetrisees'
      if(yw)call mscript(s)
      write(4) s
      close(4)
!
! Orthogonalite de la nouvelle matrice d'OM
! 
      p=matmul(transpose(ol),matmul(s,ol))
      if(yw) then
         print*,'verif orthogonalite ol'
         call mscript(p)
         do k=1,noa
            print'(a,i7,F12.8)','norme**2',k,p(k,k)
         enddo
      endif
      if(yw)print*,'verif orthogonalite ol'
      if(yw)call mscript(p)
      ssmaxij=0.d0
      ssmaxii=0.d0
      print*,'verif orthogonalite orbitales desymorb '
      do i=1,noa
         do j=1,i-1
            ssmaxij=max(ssmaxij,abs(p(i,j)))
         enddo
         ssmaxii=max(ssmaxii,abs(p(i,i)-1.d0))
      enddo
      if(ssmaxij>1.d-6) print*,'defaut d''orthogonalite max',ssmaxij
      if(ssmaxii>1.d-6) print*,'defaut de normalisation max',ssmaxii
      print*,'verif d''orthogonalite terminee'

!      do k=1,noa
!         if(dabs(p(k,k)-1.d0)>1.d-5) then
!            print*,'l''orbitale desymetrisee',k,' n''est pas normee'
!            print'(a,i7,F12.8)','norme**2',k,p(k,k)
!            stop
!         endif
!         p(k,k)=0.d0
!      enddo
!      if(any(dabs(p)>1.d-5)) then
!         print*,'Les orbitales ne sont pas orthogonales'
!         print*,maxval(dabs(p))
!         stop
!      endif
      print*,'verif orthogonalite orbitales desymorb '
      print*,'====================================================='
      print*,' Fin desymorb Fin desymorb Fin desymorb Fin desymorb'
      print*,'====================================================='
      print*,' '
      
      end
       subroutine longbas(c,l)
      character(*) c
      logical yw
      yw=.false.
      l=0
      if(yw)print*,'entree longbas'
      call longbas2(c,l,'S',1)
      call longbas2(c,l,'P',3)
      call longbas2(c,l,'D',5)
      call longbas2(c,l,'F',7)
      call longbas2(c,l,'G',9)
      call longbas2(c,l,'H',11)
      call longbas2(c,l,'I',13)
      if(yw)print*,'l',l
      return
      end
      subroutine longbas2(c,l,d,ifac)
      character(*) c
      character(1) d
      logical yw
      yw=.false.
      !if(yw)print*,'entree longbas',c,'-',d
      i=index(c,d)
      if(i==0) return
      c(i:i)=' '
      read(c,*) ls
      c(1:i)=' '
      !if(yw)print*,'ls',d,'   ',ls
      l=l+ls*ifac
      !print*,'l',l
      return
      end
       subroutine faborbi(c,d,ind,orbi,atom,noa,neq)
      character(*) c
      character(1) d
      character(4) atom
      character(8) orbi(noa)
      logical yw
      yw=.false.
      if(yw)print*,'entree faborbi',c,'-',d
      i=index(c,':')
      c(1:i)=' '
      i=index(c,d)
      if(i==0) return
      c(i:i)=' '
      if(yw)print*,'c',c
      read(c,*) ls
      if(yw)print*,'ls',ls
      c(1:i)=' '
      if(yw)print*,'faborbi',c,d,ls
      if(d=='S') then
         call faborbi2(atom,ls,ind,orbi,'1S  ',noa)
      else if (d=='P') then
         call faborbi2(atom,ls,ind,orbi,'2PX ',noa)
         call faborbi2(atom,ls,ind,orbi,'2PY ',noa)
         call faborbi2(atom,ls,ind,orbi,'2PZ ',noa)
      else if (d=='D') then
         call faborbi2(atom,ls,ind,orbi,'3D0 ',noa)
         call faborbi2(atom,ls,ind,orbi,'3D1+',noa)
         call faborbi2(atom,ls,ind,orbi,'3D1-',noa)
         call faborbi2(atom,ls,ind,orbi,'3D2+',noa)
         call faborbi2(atom,ls,ind,orbi,'3D2-',noa)
      else if (d=='F') then
         call faborbi2(atom,ls,ind,orbi,'4F0 ',noa)
         call faborbi2(atom,ls,ind,orbi,'4F1+',noa)
         call faborbi2(atom,ls,ind,orbi,'4F1-',noa)
         call faborbi2(atom,ls,ind,orbi,'4F2+',noa)
         call faborbi2(atom,ls,ind,orbi,'4F2-',noa)
         call faborbi2(atom,ls,ind,orbi,'4F3+',noa)
         call faborbi2(atom,ls,ind,orbi,'4F3-',noa)
      else if (d=='G') then
         call faborbi2(atom,ls,ind,orbi,'5G0 ',noa)
         call faborbi2(atom,ls,ind,orbi,'5G1+',noa)
         call faborbi2(atom,ls,ind,orbi,'5G1-',noa)
         call faborbi2(atom,ls,ind,orbi,'5G2+',noa)
         call faborbi2(atom,ls,ind,orbi,'5G2-',noa)
         call faborbi2(atom,ls,ind,orbi,'5G3+',noa)
         call faborbi2(atom,ls,ind,orbi,'5G3-',noa)
         call faborbi2(atom,ls,ind,orbi,'5G4+',noa)
         call faborbi2(atom,ls,ind,orbi,'5G4-',noa)
      else if (d=='H') then
         call faborbi2(atom,ls,ind,orbi,'6H0 ',noa)
         call faborbi2(atom,ls,ind,orbi,'6H1+',noa)
         call faborbi2(atom,ls,ind,orbi,'6H1-',noa)
         call faborbi2(atom,ls,ind,orbi,'6H2+',noa)
         call faborbi2(atom,ls,ind,orbi,'6H2-',noa)
         call faborbi2(atom,ls,ind,orbi,'6H3+',noa)
         call faborbi2(atom,ls,ind,orbi,'6H3-',noa)
         call faborbi2(atom,ls,ind,orbi,'6H4+',noa)
         call faborbi2(atom,ls,ind,orbi,'6H4-',noa)
         call faborbi2(atom,ls,ind,orbi,'6H5+',noa)
         call faborbi2(atom,ls,ind,orbi,'6H5-',noa)
      else if (d=='I') then
         call faborbi2(atom,ls,ind,orbi,'7I0 ',noa)
         call faborbi2(atom,ls,ind,orbi,'7I1+',noa)
         call faborbi2(atom,ls,ind,orbi,'7I1-',noa)
         call faborbi2(atom,ls,ind,orbi,'7I2+',noa)
         call faborbi2(atom,ls,ind,orbi,'7I2-',noa)
         call faborbi2(atom,ls,ind,orbi,'7I3+',noa)
         call faborbi2(atom,ls,ind,orbi,'7I3-',noa)
         call faborbi2(atom,ls,ind,orbi,'7I4+',noa)
         call faborbi2(atom,ls,ind,orbi,'7I4-',noa)
         call faborbi2(atom,ls,ind,orbi,'7I5+',noa)
         call faborbi2(atom,ls,ind,orbi,'7I5-',noa)
         call faborbi2(atom,ls,ind,orbi,'7I6+',noa)
         call faborbi2(atom,ls,ind,orbi,'7I6-',noa)
      endif
      return
      end
       subroutine faborbi2(atom,ls,ind,orbi,c,noa)
      character(*) c
      character(4) atom
      character(8) orbi(noa)
      logical yw
      yw=.false.
      if(yw)print*,'entree faborbi2'
      ind0=ind+1
      ind=ind+ls
      if(yw)print*,'ind',ind
      orbi(ind0:ind)=atom//c
      return
      end
       subroutine reor_oa_molden(ol,orbi2,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(*) orbi2(noa)
      dimension ol(noa,noa)
      allocatable ol2(:,:)
      allocate(ol2(noa,noa))
      yw=.false.
!
! On reordonne les P,D... pour passer de l'ordre molden Px,Py,Pz,Px,Py..
! a Px,Px,Py,Py...
!
      k=1
      k2=1
      do
         if(yw)print*,'orbi2',orbi2(k)
         if(yw)print*,'orbi2',orbi2(k)(5:6),k
         if(orbi2(k)(5:6)=='1S') then
            ol2(k2,:)=ol(k,:)
            k=k+1
            k2=k2+1
         else if(orbi2(k)(5:6)=='2P') then
            call reor_oa_molden2(ol2,ol,orbi2,noa,k,k2,'2P',3)
         else if(orbi2(k)(5:6)=='3D') then
            call reor_oa_molden2(ol2,ol,orbi2,noa,k,k2,'3D',5)
         else if(orbi2(k)(5:6)=='4F') then
            call reor_oa_molden2(ol2,ol,orbi2,noa,k,k2,'4F',7)
         else if(orbi2(k)(5:6)=='5G') then
            call reor_oa_molden2(ol2,ol,orbi2,noa,k,k2,'5G',9)
         else if(orbi2(k)(5:6)=='6H') then
            call reor_oa_molden2(ol2,ol,orbi2,noa,k,k2,'6H',11)
         else if(orbi2(k)(5:6)=='7I') then
            call reor_oa_molden2(ol2,ol,orbi2,noa,k,k2,'7I',13)
         else
            print*,'desymorb  orb autre que SPDF non programmees'
            print*,orbi2(k)(5:6)
            stop
         endif
         k=k2
         if(k>noa) exit
      enddo
      if(yw)call mscript(ol2)
      ol=ol2
      deallocate(ol2)
      return
      end
       subroutine reor_oa_molden2(ol2,ol,orbi2,noa,k,k2,c,n)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(*) orbi2(noa),c
      dimension ol(noa,noa)
      dimension ol2(noa,noa)
      yw=.false.
      l=0
      do
         l=l+1
         if(orbi2(k+l)/=orbi2(k)) exit
      enddo
      if(yw)print*,'multiplicite de ',c,l
      do i=1,n
         kk=k+i-1
         do j=1,l
            if(yw)print*,'k2',k2,kk
            ol2(k2,:)=ol(kk,:)
            k2=k2+1
            kk=kk+n
         enddo
      enddo
!
! A partir de D, il faut reordonner (ordre molden d0 d1+ d1- d2+ d2-,
! ordre molcas d2- d1- d0 d1+ d2+)
!
      if(c=='3D') call reor_oa_molden3(orbi2(k:k2-1),ol2(k:k2-1,:)
     *,l,noa)
      if(c=='4F') call reor_oa_molden4(orbi2(k:k2-1),ol2(k:k2-1,:)
     *,l,noa)
      if(c=='5G') call reor_oa_molden4(orbi2(k:k2-1),ol2(k:k2-1,:)
     *,l,noa)
      if(c=='6H') call reor_oa_molden4(orbi2(k:k2-1),ol2(k:k2-1,:)
     *,l,noa)
      if(c=='7I') call reor_oa_molden4(orbi2(k:k2-1),ol2(k:k2-1,:)
     *,l,noa)
      return
      end
       subroutine reor_oa_molden3(orbi2,ol2,l,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(8),allocatable :: orbi3(:)
      character(*) orbi2(l*5)
      allocatable ol3(:,:)
      dimension ol2(l*5,noa)
      character(4) lab(13)
      lab(1:5)='3D'//(/'2-','1-','0 ','1+','2+'/)
      allocate(ol3(l*5,noa),orbi3(l*5))
      ij=0
      do i=1,5
         do j=1,5*l
            if(orbi2(j)(5:8)==lab(i)) then
               ij=ij+1
               ol3(ij,:)=ol2(j,:)
               orbi3(ij)=orbi2(j)
            endif
         enddo
      enddo
      orbi2=orbi3
      ol2=ol3
      return
      end
       subroutine reor_oa_molden4(orbi2,ol2,l,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(8),allocatable :: orbi3(:)
      character(*) orbi2(l*7)
      allocatable ol3(:,:)
      dimension ol2(l*7,noa)
      character(4) lab(7)
      lab(1:7)='4F'//(/'3-','2-','1-','0 ','1+','2+','3+'/)
      allocate(ol3(l*7,noa),orbi3(l*7))
      ij=0
      do i=1,7
         do j=1,7*l
            if(orbi2(j)(5:8)==lab(i)) then
               ij=ij+1
               ol3(ij,:)=ol2(j,:)
               orbi3(ij)=orbi2(j)
            endif
         enddo
      enddo
      orbi2=orbi3
      ol2=ol3
      return
      end
       subroutine reor_oa_molden5(orbi2,ol2,l,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(8),allocatable :: orbi3(:)
      character(*) orbi2(l*9)
      allocatable ol3(:,:)
      dimension ol2(l*9,noa)
      character(4) lab(9)
      lab(1:9)='5G'//(/'4-','3-','2-','1-','0 ','1+','2+','3+','4+'/)
      allocate(ol3(l*9,noa),orbi3(l*9))
      ij=0
      do i=1,9
         do j=1,9*l
            if(orbi2(j)(5:8)==lab(i)) then
               ij=ij+1
               ol3(ij,:)=ol2(j,:)
               orbi3(ij)=orbi2(j)
            endif
         enddo
      enddo
      orbi2=orbi3
      ol2=ol3
      return
      end
       subroutine reor_oa_molden6(orbi2,ol2,l,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(8),allocatable :: orbi3(:)
      character(*) orbi2(l*11)
      allocatable ol3(:,:)
      dimension ol2(l*11,noa)
      character(4) lab(11)
      lab(1:11)='6H'
     *//(/'5-','4-','3-','2-','1-','0 ','1+','2+','3+','4+','5+'/)
      allocate(ol3(l*11,noa),orbi3(l*11))
      ij=0
      do i=1,11
         do j=1,11*l
            if(orbi2(j)(5:8)==lab(i)) then
               ij=ij+1
               ol3(ij,:)=ol2(j,:)
               orbi3(ij)=orbi2(j)
            endif
         enddo
      enddo
      orbi2=orbi3
      ol2=ol3
      return
      end
       subroutine reor_oa_molden7(orbi2,ol2,l,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(8),allocatable :: orbi3(:)
      character(*) orbi2(l*13)
      allocatable ol3(:,:)
      dimension ol2(l*13,noa)
      character(4) lab(13)
      lab(1:13)='7I'
     *//(/'6-','5-','4-','3-','2-','1-','0 '
     *,'1+','2+','3+','4+','5+','6+'/)
      allocate(ol3(l*13,noa),orbi3(l*13))
      ij=0
      do i=1,13
         do j=1,13*l
            if(orbi2(j)(5:8)==lab(i)) then
               ij=ij+1
               ol3(ij,:)=ol2(j,:)
               orbi3(ij)=orbi2(j)
            endif
         enddo
      enddo
      orbi2=orbi3
      ol2=ol3
      return
      end
