      program hieror
      use mod_lirorb
      implicit real(8) (a-h,o-x,z),logical(y)
      parameter (maxsym=8,maxorbcas=16)
      character(10000) namel,namel1
      character(80) prefix,aa,MONO1,MONO
      dimension isym(maxsym)
      allocatable y(:)
      integer,dimension(:),allocatable :: pri
      double precision,dimension(:,:),allocatable :: u,u1,s
      double precision,dimension(:),allocatable :: r8
      allocatable nbprio(:),npri(:)
      allocatable occup(:)
      character(18),allocatable :: tipo(:)
      logical no_last_ort
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       HIEROR'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '      
      yw=.false.
      nprint=0
      no_last_ort=.false.
c
c---------------------------------------------------------------
c     lecture des donnees
c---------------------------------------------------------------
c
! sockage du fichier de donnees      
      call sto5
      rewind 93
! lecture
      MONO='Mono'
      MONO1=' '
      call LECNAM('&HIEROR ',namel,93,ierr,1)
      if(ierr.eq.1) then
         print*,'namelist PSCF non trouvee'
         stop
      endif
      call namela(namel,PREFIX,'PREFIX')
      call namela(namel,MONO,'MONO')
      call namela(namel,MONO1,'MONO1')
      if(mono1==' ') mono1=trim(prefix)//trim(mono)
      call nameli(namel,NPRINT,'NPRINT',4)
      call namell(namel,NO_LAST_ORT,'NO_LAST_ORT',4)
      open(3,file=mono1,status='old',form='unformatted')
      maxprio=0
      print*,'no_last_ort',no_last_ort
c
c     lecture de la matrice de recouvrement
c
      do
         read(3)
         read(3) aa
         print*,aa
         if(index(aa,'OVERLAP').ne.0.and.index(aa,'SYM').ne.0) then
            read(3) long
            allocate(r8(long))
            read(3) r8
            exit
         endif
      enddo
      close(3)
!
!--------------------------------------------------------
!     lecture du fichier d'orbitales
!--------------------------------------------------------
!
      call lirorb('INPORB',norb,nsym,isym,1,2)
      print*,'norb',norb
      print*,'nsym',nsym
      print*,'isym',isym(1:nsym)
      allocate(pri(norb))
      allocate(y(norb))
      allocate(nbprio(norb))
      allocate(npri(norb))
      allocate(occup(norb))
      allocate(tipo(norb))
!
!--------------------------------------------------------
!     ecriture des labels des orbitales
!--------------------------------------------------------
!
      ifin=0
      do is=1,nsym
         if(isym(is)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(is)
         read(1)
         read(1)
         read(1) tipo(ideb:ifin)
      enddo
      rewind 1
      do k=1,norb
         print*,'labels des OL',k,tipo(k)
      enddo
!
!--------------------------------------------------------
!     boucle sur les symetries
!--------------------------------------------------------
!
      inds=0
      open(3,status='unknown',form='unformatted')
      do is=1,nsym
         print*,' '
         print*,'******************************* '
         print*,'    SYMETRIE ',is
         print*,'******************************* '
         print*,' '
         ndims=isym(is)
         rewind 93
         call LECNAM('&HIEROR ',namel,93,ierr,0)
         yoa_ort=.false.
         call namell(namel,YOA_ORT,'YOA_ORT',1)
         ifin=0
! Extraction de la matrice de recouvrement
         allocate (s(ndims,ndims))
         if(yoa_ort) then
            s=0.d0
            do k=1,ndims
               s(k,k)=1.d0
            enddo
         else
            do k=1,ndims
               do l=1,k
                  inds=inds+1
                  s(k,l)=r8(inds)
                  s(l,k)=r8(inds)
               enddo
            enddo
            if(nprint>1) then
               print*,'matrice de recouvrement'
               call script(s,ndims,ndims,ndims,ndims)
            endif
         endif
! Etablissement des priorites
         do
            read(93,'(a)') namel(1:80)
            if(yw)print*,trim(namel)
            call maj(namel,80)
            if(index(namel,'FINHIER').ne.0) exit
            ii=index(namel,'PR')
! On cherche l'occurence "pr"
            if(yw)print*,'namel',trim(namel)
            if(yw)print*,'ii',ii
            if(ii.ne.0) then
               namel(ii:ii+1)=' '
               read(namel,*)iprio
               if(yw)print*,'iprio',iprio
               nbprio(iprio)=0
            else
! On a trouve l'occurence "pr"
               read(namel,*) is1
               if(yw)print*,'is1',is1
! La symetrie lue doit etre celle de la boucle externe
               if(is1==is) then
                  namel=adjustl(namel)
                  long=len_trim(namel)
                  if(yw)print*,'long',long
                  call suppdb(namel,long)
                  long=len_trim(namel)
                  if(yw)print*,'LONG',long
! On cherche une donnee multiple avec "-"
                  iii=index(namel,'-')
                  if(iii.ne.0) then
                     do k10=iii-1,1,-1
                        if(namel(k10:k10).ne.' ') exit
                     enddo
                     do k1=k10-1,1,-1
                        if(namel(k1:k1).eq.' ') exit
                     enddo
                     do k20=iii+1,long
                        if(namel(k20:k20).ne.' ') exit
                     enddo
                     do k2=k20+1,long
                        if(namel(k2:k2).eq.' ') exit
                     enddo
                     namel(iii:iii)=' '
                     read(namel(k1:k2),*) l1,l2
                     write(namel(k1:10000),'(1000i4)')(k,k=l1,l2)
                     long=len_trim(namel)
                     call suppdb(namel,long)
                     long=len_trim(namel)
                  endif
                  nn=0
                  ! on compte le nb d'orbitales de priorite iprio en
                  ! comptant les blancs
                  do k=1,long
                     if(namel(k:k).eq.' ') nn=nn+1
                  enddo
                  nbprio(iprio)=nbprio(iprio)+nn
                  if(yw)print*,'nbprio(iprio)',nbprio(iprio)
                  ideb=ifin+1
                  ifin=ideb+nn-1
                  if(yw)print*,'ideb,ifin',ideb,ifin
                  read(namel(1:long),*)isbid,npri(ideb:ifin)
                  if(yw)print*,'is,npri(ideb:ifin)',is,npri(ideb:ifin)
               endif
            endif
         enddo
         write(75,*)'nombre d''orbitales par priorite : ',
     *   nbprio(1:iprio),'$'
         call scril
         print*,'orbitales donnees par priorite :'
         ifin=0
         do k=1,iprio
            ideb=ifin+1
            ifin=ideb+nbprio(k)-1
            write(75,*) 'sym=',is,' prio=',k,' orb :', npri(ideb:ifin)
     *      ,'$'
            call scril
         enddo
         ! On complete npri pour la derniere priorite, non en donnee
         if(ifin<ndims) then
            print*,
     *      'On complete npri pour la derniere priorite, non en donnee'
            iprio=iprio+1
            nbprio(iprio)=ndims-sum(nbprio(1:iprio-1))
            y(1:ndims)=.false.
            y(npri(1:ifin))=.true.
            kk=ifin
            do k=1,ndims
               if(.not.y(k)) then
                  kk=kk+1
                  npri(kk)=k
               endif
            enddo
            if(yw)print*,'iprio',iprio
            if(yw)print*,'nbprio',nbprio(1:iprio)
            if(yw)print*,'npri',npri(1:ndims)
         endif
         if(nprint>0)
     *   write(75,*)'ordre   ',' is',is,' npri', npri(1:ndims),'$'
         if(nprint>0)call scril
!
!--------------------------------------------------------
!        lecture, orthogonalisation, ecriture
!--------------------------------------------------------
!
         allocate(u(ndims,ndims))
         allocate(u1(ndims,ndims))
         read(1) u
         if(nprint.ge.1) then
            print*,'orbitales avant orthogonalisation sym',is
            call script(u,ndims,ndims,ndims,ndims)
         endif
         ! recouvrements
         u1=matmul(transpose(u),matmul(s,u))
         print*,'norme des orbitales a orthogonaliser'
         print'(10f8.4)',(u1(i,i),i=1,ndims)
         if(nprint>=0) then
            do i=1,ndims
               if(abs(u1(i,i)-1.d0)>0.5) then
                  print*,'NORME LOIN DE 1. : ',i,u1(i,i),' '
               endif
               do j=1,i-1
                  if(abs(u1(i,j)).gt.0.5) then
                     print*,'GRAND RECOUVREMENT',i,j,u1(i,j)
                  endif
               enddo
            enddo
         endif
         ! projection, orthonormalisation
         if(yw) then
            print*,'NPRI',npri
            print*,'IPRIO',iprio
            print*,'ndims',ndims,nsym
            print*,'mat a orthogonaliser'
            call script(u,ndims,ndims,ndims,ndims)
            u1=matmul(transpose(u),matmul(s,u))
            print*,'verif d''orthogonalite0'
            call script(u1,ndims,ndims,ndims,ndims)
         endif
         nort=iprio-1
         if(nort==0) nort=1
         do k=1,nort
            i1=sum(nbprio(1:k-1))
            i2=sum(nbprio(1:k))
            i3=sum(nbprio(1:k+1))
            if(nort==1) i3=i2
            print*, ' '
            print'(a,i4,a3)','Orthogonalisation',k,' : '
            if(k==1) then
               print*,'s**-1/2 sur'
               print'(20i4)',npri(i1+1:i2)
            endif
            if(k==iprio-1.and.no_last_ort) then
               print*,'no_last_ort=T, pas de derniere orthogonalisation'
               exit
            else
               if(nort>1) then
                  print*,'Schmidt, puis s**-1/2 sur'
                  print'(20i4)',npri(i2+1:i3)
               endif
            endif
            if(k==1) then
               call hier3(u,ndims,npri,i1,i2,i3,s,1,1,1)
            else
               call hier3(u,ndims,npri,i1,i2,i3,s,0,1,1)
            endif
            if(yw) then
               u1=matmul(transpose(u),matmul(s,u))
               print*,'verif d''orthogonalite1',is,k
               call script(u1,ndims,ndims,ndims,ndims)
            endif
         enddo
!        i1=sum(nbprio(1:iprio-1))
!        i2=sum(nbprio(1:iprio))
!        i3=ndims
!        print*,'2i1,i2,i3,npri',i1,i2,i3,npri(i1+1:i2),npri(i2+1:i3)
!         call hier3(u,ndims,nbprio(iprio),nbprio(iprio+1),
!     *   npri(i1+1:i2),npri(i2+1:i3),s,no_last_ort)
         !
         print*,' '
         print*,'orbitales apres orthogonalisation sym',is
         call script(u,ndims,ndims,ndims,ndims)
         write(3) u
!         if(yw) then
            u1=matmul(transpose(u),matmul(s,u))
            print*,'verif d''orthogonalite',is
            call script(u1,ndims,ndims,ndims,ndims)
!         endif
         deallocate (s,u,u1)
      enddo
! Ecriture de la matrice orthogonalisee
      do is=1,nsym
         ndims=isym(is)
         read(1) occup(1:ndims)
         write(3)  occup(1:ndims)
      enddo
      do is=1,nsym
         ndims=isym(is)
         read(1) tipo(1:ndims)
         write(3)  tipo(1:ndims)
      enddo
      call ecriorb('* Orbitales orthogonalisees par hieror','ORTORB',
     *nsym,isym,3,4)
      close(3,status='delete')
      close(1,status='delete')
      end
