      subroutine schmud1
      use mod_dolo
      implicit real*8 (a-h,o-z)
      character*1280 namel
      character*1    v
      character*8 progr
      character*80 aa
      common/prog/progr
      logical select,ok
      logical*1 yw
      integer        info, lda, ldvl, ldvr,  n
      double precision,dimension(:,:),allocatable :: h,ul,ur,u,s
      double precision,dimension(:),allocatable :: wr,wi,r8
      integer,dimension(:,:),allocatable :: ideb
      integer,dimension(:),allocatable :: iord,ifrag,jord,ifragn
 
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      common /pr/ nprint
      allocate(h(norb,norb))
      allocate(ul(norb,norb))
      allocate(ur(norb,norb))
      allocate(u(norb,norb))
      allocate(s(norb,norb))
      allocate(wr(norb))
      allocate(wi(norb))
      allocate(ideb(norb+1,maxsym))
      allocate(iord(norb),ifrag(norb),jord(norb),ifragn(norb))
      allocate(orbi(norb),nbas(norb))
      allocate(nbast(0:norb))
      allocate(itype(norb))
      yw=.false.
      nbas=0
      nbast=0
c
c
c     lecture de la matrice de recouvrement
c
      do
         read(3)
         read(3) 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
      call lir
!
!-------------------------------------------------------
! Taking account of symmetry
!-------------------------------------------------------
!
      call symetrie
      call titre('ETAPE 1#ORTHOGONALISATION DES OA'//
     *'#orthogonalisation Schmidt',60)
      isymt(0)=0
      do k=1,nsym
         isymt(k)=isymt(k-1)+isym(k)
      enddo
      rewind 93
!
!-------------------------------------------------------
! Data concerning AO orthogonalization
!-------------------------------------------------------
!
      call faido(ideb)
!
! Restart
!
      open(8,status='unknown',form='unformatted',
     *file=trim(workdir)//'S')
      call restart_oao(1,s(1:norb,1:norb),norb,ok,is,workdir)
!
!-------------------------------------------------------
! build files S and S2 for schmudort...
! reorder AO's according to priority (iord)
!-------------------------------------------------------
!
      open(4,status='unknown',form='unformatted',
     *file=trim(workdir)//'S2')
c--------------------------------------------------------------
      kks=0
      if(.not.ok) then
         do 100 is=1,nsym
         ndims=isym(is)
         write(8) ndims,nsym
         write(99) ndims,nsym
         if(ndims.eq.0) goto 100
         ndims0=isymt(is-1)
         if(yw)print*,'is,ndims,ndims0',is,ndims,ndims0
c        priorites d'orthogonalisation
         itype(1:ndims)=itype(1+ndims0:ndims+ndims0)
         if(yw)print*,'itype',itype(1:ndims)
         kk=0
         do ityp=1,ntyp
            do k=1,ndims
               if(itype(k).eq.ityp) then
                  kk=kk+1
                  iord(kk)=k
               endif
            enddo
         enddo
         do k=1,ndims
            jord(iord(k))=k
         enddo
         if(yw)print*,'iord',(iord(kk),kk=1,ndims)
c
!-------------------------------------------------------
c     mise de la matrice de recouvrement en carre
!-------------------------------------------------------
c
         if(yw)print*,'ndims',ndims
         do i=1,ndims
            do j=1,i
               kks=kks+1
               h(i,j)=r8(kks)
               h(j,i)=r8(kks)
            enddo
         enddo
         write(8)((h(k,l),k=1,ndims),l=1,ndims)
         write(8) orbi(ndims0+1:ndims0+ndims)
         write(99)((h(k,l),k=1,ndims),l=1,ndims)
         write(99) orbi(ndims0+1:ndims0+ndims)
         if(yw)print*,orbi(ndims0+1:ndims0+ndims)
c
         eps1=-0.1d0
         eps2=-0.1d0
         dv=-0.0001d0
         dl=-0.00d0
         if(nprint.ge.2) then
            print*,' '
            print*,'matrice de recouvrement  sym',is
            call scripto(h(1:ndims,1:ndims)
     *      ,ndims,ndims,ndims,ndims,orbi(ndims0+1))
         endif
c
!---------------------------------------------------
! Restart oao
!---------------------------------------------------
!
c
c----------------------------------------
c        Orthogonalisation hierarchisee
c----------------------------------------
 
c        mise a zero des orb
         u=0.d0
         do i=1,ndims
            u(i,i)=1.d0
         enddo
c        permutation de la mat de rec
         do i=1,ndims
            s(1:ndims,i)=h(1:ndims,iord(i))
         enddo
         do i=1,ndims
            h(i,1:ndims)=s(iord(i),1:ndims)
         enddo
         if(yw) then
            print*,'rec des orb permutees'
            call script(h(1:ndims,1:ndims),
     *      ndims,ndims,ndims,ndims)
         endif
!
!
         i11=1
c      print*,'ntyp',ntyp
         do k=2,ntyp
c         print*,'hier',k,ideb(k,is)-1,ideb(k+1,is)-1,i11
            call hiersmud2(ideb(k,is)-1,ideb(k+1,is)-1,
     *      ndims,h(1:ndims,1:ndims),u(1:ndims,1:ndims),
     *      ul(1:ndims,1:ndims),ur,i11)
         enddo
         call flush(6)
         s(1:ndims,1:ndims)=u(jord(1:ndims),jord(1:ndims))
c         if(is.eq.2) stop
         if(nprint.ge.1) then
            print*,' '
            print*,'orbitales orthogonalisees   symetrie',is
            call scripto(s(1:ndims,1:ndims)
     *      ,ndims,ndims,ndims,ndims,orbi(ndims0+1))
         endif
         call restart_oao(2,s(1:ndims,1:ndims),ndims,ok,is,workdir)
c
c--------------------------------------------------------
c     ecriture en format Orb molcas
c--------------------------------------------------------
c
         if(yw)print*,'ouverture 1'
         if(is.eq.1)open(1,file=trim(workdir)//'LOCOA',status='unknown')
         if(yw.and.is.eq.1)
     *   write(6,'(A20)') '* Orbitales Hiersmud'
         if(is.eq.1)write(1,'(A20)') '* Orbitales Hiersmud'
         do k=1,ndims
            if(yw)write(6,'(''* ORBITAL'',2i5)') is,k
            write(1,'(''* ORBITAL'',2i5)') is,k
            if(yw)write(6,1000)(s(l,k),l=1,ndims)
            write(1,1000)(s(l,k),l=1,ndims)
 1000       format(4d18.12)
         enddo
 100     continue
      endif
      if(yw)write(6,'(''* OCCUPATION NUMBERS'')')
      write(1,'(''* OCCUPATION NUMBERS'')')
      do is=1,nsym
         ndims=isym(is)
         if(yw)write(6,1000)(0.d0,l=1,ndims)
         write(1,1000)(0.d0,l=1,ndims)
      enddo
      write(4) nsym,isym(1:nsym),progr
      close(99)
      return
      end
