      subroutine schmud1
      use smuc
      use don
      use bas
      use typ
      use mod_sym
      implicit real*8 (a-h,o-z)
      parameter (maxsym=8)
      character*10000 namel
      character*3000 orb,guess
      character*1    v
      character*8 progr
      character*80 aa
      common/prog/progr
      logical select
      logical*1 ysch,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(numina(norb),numac(norb))
      allocate(orbi(norb),nbas(norb))
      allocate(nbast(0:norb))
      allocate(itype(norb))
      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
c
c     lecture de la namelist
c
      yw=.false.
      ysch=.true.
      orb=' '
      ninac=0
      if(yw)print*,'norb',norb
      iord(1:norb)= (/ (i,i=1,norb) /)
      numina=iord
      guess='SCF'
      rewind 93
      call LECNAM('&SMU ',namel,93,ierr,1)
      call nameli(namel,noac,'NOAC',4)
      call nameli(namel,NINAC,'NINAC',4)
      call nameli(namel,NPRINT,'NPRINT',4)
c      call nameli(namel,NBAS,'NBAS',4)
      call nameli(namel,NUMINA(1),'NUMINA',4)
      call namell(namel,YSCH,'YSCH',1)
      call namela(namel,ORB,'ORB')
      call namela(namel,GUESS,'GUESS')
      kk=0
      call lir(norb)
!
! S'il y a des donnees automatiques, ou des donnees APRA ou ORTH,
! Operations de symetrie, Generation des atomes en symetrie
      if(ycallsymetrie) call symetrie
      call datoto
!      print*,' '
!      print*,'*********************************************** '
!      if(ysch)print*,'                   ETAPE 1  '
!      print*,'          ORTHOGONALISATION DES OA '
!      if(ysch) then
!         print*,'orthogonalisation Schmidt '
!      else
!         print*,'orthogonalisation globale S-1/2'
!      endif
!      print*,'*********************************************** '
!      print*,' '
      if(ysch) then
         call titre('ETAPE 1#ORTHOGONALISATION DES OA'//
     *   '#orthogonalisation Schmidt',60)
      else
         call titre('ETAPE 1#ORTHOGONALISATION DES OA'//
     *   '#orthogonalisation globale S-1/2',60)
      endif
 
      isymt(0)=0
      do k=1,nsym
         isymt(k)=isymt(k-1)+isym(k)
      enddo
      rewind 93
      call faido(ideb)
!c
!c
!c     appartenance aux fragments
!c
!c     ifrag(kk)=k : l'orbitale kk appartient au fragment k
!      norb1=0
!      do k=1,norb
!         if(nbas(k).eq.0) then
!            nfrag=k-1
!            goto 2
!         endif
!         norb1=norb1+nbas(k)
!      enddo
! 2    continue
!      if(norb1.ne.norb) then
!         print*,'nbas incorrect',(nbas(k),k=1,nfrag)
!      endif
!      if(yw)print*,'nfrag',nfrag
!      do k=1,nfrag
!         do l=1,nbas(k)
!            kk=kk+1
!            ifrag(kk)=k
!         enddo
!      enddo
!      if(yw)print*,'ifrag',(ifrag(k),k=1,norb)
      open(8,status='unknown',form='unformatted',file='S')
      open(4,status='unknown',form='unformatted',file='S2')
c--------------------------------------------------------------
      kks=0
c      print*,'isym',isym
c      print*,'nsym',nsym
      do 100 is=1,nsym
      ndims=isym(is)
      write(8) 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     nouvel ifrag
!      do k=1,norb
!         ifragn(k)=ifrag(iord(k))
!      enddo
!      if(yw)print*,'nouvel ifrag',(ifragn(k),k=1,ndims)
!      open(9,file='ORD',status='unknown')
!      write(9,'(i4)') nfrag
!      write(9,'(20i4)') (ifragn(kk),kk=1,ndims)
!      close(9)
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)
      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
c     eventuellement, lecture d'orbitales
c
      if(ysch) then
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
      else
c
c--------------------------------------------------------
c     Orthogonalisation s**(-1/2)
c--------------------------------------------------------
c
         call smud(h(1:ndims,1:ndims),s(1:ndims,1:ndims),
     *   ur(1:ndims,1:ndims),wr,ndims)
      endif
      if(nprint.ge.1) then
         print*,' '
         print*,'orbitales orthogonalisees   symetrie',is
cc         if(orb.eq.' ') then
cc            s(1:norb,1:norb)=u(jord(1:norb),:)
cc         else
c            s(1:norb,1:norb)=u(jord(1:norb),jord(1:norb))
cc         endif
         call scripto(s(1:ndims,1:ndims)
     *   ,ndims,ndims,ndims,ndims,orbi(ndims0+1))
      endif
c
c--------------------------------------------------------
c     ecriture en format Orb molcas
c--------------------------------------------------------
c
c      yw=.true.
      if(ysch) then
         if(yw)print*,'ouverture 1'
         if(is.eq.1)open(1,file='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
      else
         if(yw)print*,'ouverture 1'
         if(is.eq.1)open(1,file='LOCORB',status='unknown')
         if(yw.and.is.eq.1)
     *   write(6,'(A28)') '* Orbitales Localisees S-1/2'
         if(is.eq.1)write(1,'(A28)') '* Orbitales Localisees S-1/2'
         do k=1,ndims
            if(yw)write(6,'(''* ORBITAL'',2i5)') is,k
            if(yw)write(6,1000)(s(l,(k)),l=1,ndims)
            write(1,'(''* ORBITAL'',2i5)') is,k
            write(1,1000)(s(l,(k)),l=1,ndims)
         enddo
      endif
 100  continue
      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
!         do k=1,natom1
!            print'(a,i6,2a,3f12.8,i5)','atom'
!     *   ,k,'  ',atom(k),coor(:,k),mult1(k)
!         enddo
      if(guess.eq.'SCF') then
         call scf(orb,norb)
         stop
!      else if (guess.eq.'ALAMAIN') then
!         call alamain(orb,norb)
      endif
!      deallocate(ideb,iord,ifrag,jord,ifragn)
      return
      end
