      program SCHMUDORT
      use mod_lirorb
      use mod_script
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter (maxsym=8,maxorbcas=300)
      character*1280 namel
      dimension isym(maxsym),isymt(0:maxsym)
      dimension nsoc(maxsym),nsal(maxsym)
      dimension nsoc0(0:maxsym),nsal0(0:maxsym)
      dimension iocp(maxsym),ialp(maxsym)
!      dimension ipr1(nfix),ipr2(nfix)
      dimension icore(maxsym),numac(maxorbcas+1)!,ivirt(nfix)
      dimension jcore(0:maxsym)
!      dimension occup(nfix),w1(nfix),occup3(1:nfix),occup4(1:nfix)
      character*8 orbi!(nfix)
      character*80 orb
!      character*6 tipo(nfix),tipo1(nfix),tipo3(nfix)
      character*18 tipo,tipo1,tipo3
      character*18 tipol,tipol3
!      dimension yocc(nfix),yact(nfix),ycor(nfix)
      double precision,dimension(:,:),allocatable :: s,u,u1,v,u2
      integer,dimension(:),allocatable :: jord!,iord
      allocatable ipr1(:),ipr2(:),ivirt(:), occup(:)
     *,w1(:),occup3(:),occup4(:),tipol(:),tipol3(:)
     *,orbi(:),tipo(:),tipo1(:),tipo3(:),yocc(:),yact(:),ycor(:)
      character*80 prefix
      integer prec_hier
!      namelist/ort/ ipr1,ipr2,icore,numac
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       SCHMUDORT'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '
c      call sto5
      yw=.false.
      yverif=.false.
      nprint=0
      open(8,status='old',form='unformatted',file='S')
c
c---------------------------------------------------------------
! lecture de nsym
c---------------------------------------------------------------
c
      read(8) ibid,nsym
      rewind 8
c
c---------------------------------------------------------------
! lecture des orbitales locales non orthogonales
c---------------------------------------------------------------
c
      call lirorb('NONORLOC',norb,nsym_bid,isym,53,54)
c
c---------------------------------------------------------------
c     nombre d'orbitales ; allocations
c---------------------------------------------------------------
c
      if(yw)print*,'norb',norb
      allocate(ipr1(norb),ipr2(norb),ivirt(norb), occup(norb)
     *,w1(norb),occup3(norb),occup4(norb)
     *,orbi(norb),tipo(norb),tipo1(norb),tipo3(norb),tipol(norb)
     *,tipol3(norb)
     *,yocc(norb),yact(norb),ycor(norb))
      allocate (u(norb,norb))
c
c---------------------------------------------------------------
c     lecture des donnees
c---------------------------------------------------------------
c
      call LECNAM('&ORT ',namel,5,ierr,1)
      if(ierr.eq.1) then
         print*,'namelist ORT non trouvee'
         stop
      endif
      ipr1=0
      ipr2=0
      icore=-1
      numac=0
      prec_hier=8
      call nameli(namel,IPR1,'IPR1',4)
      call nameli(namel,IPR2,'IPR2',4)
      call nameli(namel,ICORE,'ICORE',4)
      call nameli(namel,NUMAC,'NUMAC',4)
      call nameli(namel,NPRINT,'NPRINT',4)
      call nameli(namel,PREC_HIER,'PREC_HIER',4)
      if(PREC_HIER/=8) then
         print*,'namel,PREC_HIER /= 8 : utiliser schmudort16'
         stop
      endif
      noac=1
      do while (numac(noac).ne.0)
         noac=noac+1
      enddo
      noac=noac-1

c
c---------------------------------------------------------------
! lecture des orbitales locales non orthogonales (suite)
c---------------------------------------------------------------
c
      open(1,status='old',form='formatted',file='LOCOA')
      open(54,status='scratch',form='unformatted')
      open(55,status='scratch',form='unformatted')
      open(56,status='scratch',form='unformatted')
      open(57,status='scratch',form='unformatted')
      open(58,status='scratch',form='unformatted')
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         read(53) u(1:ndims,1:ndims)
         write(57) u(1:ndims,1:ndims)
      enddo
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         read(53) occup(1:ndims)
         write(58) occup(1:ndims)
      enddo
!     nsoc=fermi
c
c---------------------------------------------------------------
! lecture du niveau de Fermi
c---------------------------------------------------------------
c
      open(2,file='SCH_FERMI',status='old')
      call LECNAM('&FERM ',namel,2,ierr,1)
      if(ierr==1) stop' namelist &ferm non trouvee dans SCH_FERMI'
      call nameli(namel,nsoc,'FERMI',4)
      close(2)
! 
!---------------------------------------------
! on note les actives dans yact
!---------------------------------------------
!
      ynoac0=noac==0
      yact(1:norb)=.false.
      if(.not.ynoac0) then
         ! numac est en donnee dans &ort
         yact(numac(1:noac))=.true.
      else
         kk=0
         do is=1,nsym
            ndims=isym(is)
            if(ndims==0) cycle
            read(53) tipol(1:ndims)
            do k=1,ndims
               kk=kk+1
               if(tipol(k)(1:2)=='A_') yact(kk)=.true.
            enddo
         enddo
         do is=1,nsym
            if(isym(is).ne.0) then
               backspace 53
            endif
         enddo
      endif
!
!-------------------------------------------------
! On met des "A_" aux labels des actives
! (ca ne change rien si noac n'est pas en donnee)
!-------------------------------------------------
!
      kk=0
      rewind 57
      rewind 58
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         read(57) u(1:ndims,1:ndims)
         read(58) occup(1:ndims)
         read(53) tipol(1:ndims)
         do k=1,ndims
            kk=kk+1
            if(yact(kk)) then
               tipol(k)(1:2)='A_'
            else
               if(tipol(k)(1:2)=='A_') tipol(k)(1:2)='O_'
            endif
         enddo
         ! on reordonne les orbitales pour
         ! placer les actives pres du niveau de fermi
         kkk=0
         allocate(u1(ndims,ndims))
         do k=1,nsoc(is)
            if(tipol(k)(1:2)=='A_') cycle
            kkk=kkk+1
            u1(:,kkk)=u(1:ndims,k)
            occup3(kkk)=occup(k)
            tipol3(kkk)=tipol(k)
         enddo
         do k=1,nsoc(is)
            if(tipol(k)(1:2)/='A_') cycle
            kkk=kkk+1
            u1(:,kkk)=u(1:ndims,k)
            occup3(kkk)=occup(k)
            tipol3(kkk)=tipol(k)
         enddo
         do k=1+nsoc(is),ndims
            if(tipol(k)(1:2)/='A_') cycle
            kkk=kkk+1
            u1(:,kkk)=u(1:ndims,k)
            occup3(kkk)=occup(k)
            tipol3(kkk)=tipol(k)
         enddo
         do k=1+nsoc(is),ndims
            if(tipol(k)(1:2)=='A_') cycle
            kkk=kkk+1
            u1(:,kkk)=u(1:ndims,k)
            occup3(kkk)=occup(k)
            tipol3(kkk)=tipol(k)
         enddo
         tipol(1:ndims)=tipol3(1:ndims)
         write(54) u1(1:ndims,1:ndims)
         write(55) occup3(1:ndims)
         write(56) tipol(1:ndims)
         deallocate(u1)
!        numac recupere a partir des labels
         do k=1,ndims
            if(tipol(k)(1:2)=='A_') then
               noac=noac+1
               numac(noac)=k+sum(isym(1:is-1))
            endif
         enddo
!        nsal recupere a partir des labels
         ! On considere que les orbitales marquees T_ n'ont pas ete
         ! donnees a la main et sont donc a deduire de nsal
         nsal(is)=isym(is)-nsoc(is)
         do k=1,ndims
            if(tipol(k)(1:2)=='T_') then
               nsal(is)=nsal(is)-1
            endif
         enddo
         !print*,'nsal,nsoc',nsal(is),nsoc(is)
!        icore recupere a partir des labels
         ! On considere que les orbitales marquees C_ et G_ sont des
         ! orbitales de coeur
         if(icore(is)==-1) then
            icore(is)=0
            do k=1,nsoc(is)
               if(tipol(k)(1:2)=='C_'.or.tipol(k)(1:2)=='G_') then
                  icore(is)=icore(is)+1
               endif
            enddo
         endif
      enddo
      !print*,'numac',numac(1:noac)
      !print*,'icore',icore(1:nsym)
      deallocate(tipol)
      rewind 54
      rewind 55
      rewind 56
      close(53,status='delete')
      read(1,'(a)')
      open(2,file='LOCORB',status='unknown')
!         print*,'nsoc',nsoc(1:nsym)
!         print*,'nsal',nsal(1:nsym)
!      open(50,file='OAO',status='old',form='unformatted')
!      read(50) mvirt,ivirt(1:mvirt)
!      read(50) nsoc(1:nsym),nsal(1:nsym)
!         print*,'nsoc',nsoc(1:nsym)
!         print*,'nsal',nsal(1:nsym)
      jcore(0)=0
      do k=1,nsym
         jcore(k)=jcore(k-1)+icore(k)
      enddo
      ncore=sum(icore(1:nsym))
      nsoc0(0)=0
      nsal0(0)=0
      do k=1,nsym
         nsoc0(k)=nsoc(k)+nsoc0(k-1)
         nsal0(k)=nsal(k)+nsal0(k-1)
      enddo
      nsal0=nsal0+nsoc0(nsym)
      if(yw) then
         print*,'ivirt',ivirt(1:mvirt)
         print*,'nsoc',nsoc(1:nsym)
         print*,'nsal',nsal(1:nsym)
         print*,'nsoc0',nsoc0(0:nsym)
         print*,'nsal0',nsal0(0:nsym)
         print*,'icore',icore(1:nsym)
         print'(a,20i3)','numac',numac(1:noac)
         print*,'isym',isym(1:nsym)
      endif
c
c---------------------------------------------------------------
c     calculs preliminaires
c---------------------------------------------------------------
c
      ndims0=0
      isymt(0)=0
      kk=0
      do is=1,nsym
         read(8) ndims
         if(ndims.eq.0) cycle
         isym(is)=ndims
         read(8)
         nd1=ndims0+1
         nd2=ndims0+ndims
         read(8) orbi(nd1:nd2)
         isymt(is)=ndims0
         do k=1,icore(is)
            kk=kk+1
            ipr1(kk)=nsoc0(is-1)+k
         enddo
         ndims0=ndims0+ndims
      enddo
      ndim=ndims0
      yact(1:ndim)=.false.
      if(yw)print*,'yact',yact(1:ndim)
      yact(numac(1:noac))=.true.
      if(yw)print*,'yact',yact(1:ndim)
      ycor(1:ndim)=.false.
      if(yw)print*,'ycor',ycor(1:ndim)
      ycor(ipr1(1:ncore))=.true.
      if(yw)print*,'ycor',ycor(1:ndim)
      do k=1,ndim
         yocc(k)=.not.(ycor(k).or.yact(k))
      enddo
      if(yw)print*,'yocc',yocc(1:ndim)
      allocate(s(ndim,ndim))
      allocate(u1(ndim,ndim))
      allocate(u2(ndim,ndim))
      allocate(v(ndim,ndim))
      if(yw)print*,'ndim',ndim
      if(yw)print*,'isym',isym(1:nsym)
      if(yw)print*,'ipr1',ipr1(1:ncore)
      kkvirt=0
c
c---------------------------------------------------------------
c     boucle sur les symetries
c---------------------------------------------------------------
c
      open(99,form='unformatted',file='ECRIORB99',status='unknown')
      do is=1,nsym
         tipo='vir'
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is)
         nd1=ndims0+1
         nd2=ndims0+ndims
         u=0.d0
         occup=0.d0
c        lecture des orbitales occupees, puis virtuelles
         ioc=nsoc(is)
         ial=ndims-ioc
         if(yw)print*,'ioc,ial,ndims',ioc,ial,ndims
         read(54) u(1:ndims,1:ndims)
         read(55) occup(1:ndims)
         read(56) tipo(1:ndims)
!         read(50) ioc,ndims,u(1:ndims,1:ioc),occup(1:ioc),tipo(1:ioc)
!         read(50) ial,ndims,u(1:ndims,ioc+1:ioc+ial),
!     *   occup(ioc+1:ioc+ial),tipo(ioc+1:ioc+ial)
         if(yw)print*,'tipo',tipo(1:ioc+ial)
c        on complete les OL virtuelles par des OAO
!         do k=ioc+ial+1,ndims
!            kkvirt=kkvirt+1
!            u(ivirt(kkvirt)-ndims0,k)=1.d0
!            if(yw)print*,'ivirt(kkvirt)-ndims0,k',ivirt(kkvirt)-ndims0,k
!         enddo
c        cas ou on a fait une projection sur les orb SCF
         ial1=ial
         do k=ioc+1,ndims
            if(tipo(k)(1:1).eq.'R') then
               ial=ial-ndims+k-1
               if(yw)print*,'ial recalcule (proj SCF)',ial,ioc,ial1
               nsal(is)=ial
               exit
            endif
         enddo
c        mise des virtuelles gelees a la fin
         u1(1:ndims,ioc+1:ndims)=u(1:ndims,ioc+1:ndims)
         tipo1(ioc+1:ndims)=tipo(ioc+1:ndims)
         occup4(ioc+1:ndims)=occup(ioc+1:ndims)
         kk=ioc
         do k=ioc+1,ndims
            ll=index(tipo1(k),'_')
            if(ll.eq.0) ll=len_trim(tipo1(k))
            if(index(tipo1(k)(1:ll),'G').eq.0) then
               kk=kk+1
               u(1:ndims,kk)=u1(1:ndims,k)
               occup(kk)=occup4(k)
               tipo(kk)=tipo1(k)
            endif
         enddo
         do k=ioc+1,ndims
            ll=index(tipo1(k),'_')
            if(ll.eq.0) ll=len_trim(tipo1(k))
            if(index(tipo1(k)(1:ll),'G').ne.0) then
               kk=kk+1
               u(1:ndims,kk)=u1(1:ndims,k)
               tipo(kk)=tipo1(k)
               occup(kk)=occup4(k)
            endif
         enddo
c
         
         if(yw)print3001,'occupation',occup(1:ndims)
 3001    format(a20,10(f8.4),/)
         if(yw)print*,'ioc,ial',ioc,ial
         print*,'**************************************'
         write(75,*)'*********** symetrie',is,'  ***************$'
         call scril
         print*,'**************************************'
         if(nprint.ge.1) then
!             call script(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
!             print*,'ndims,ndim',ndims,ndim
!             print*,'occup',occup(1:ndims)
!             print*,'tipo',tipo(1:ndims)
            print*,'ORB AVANT ORTHOGONALISATION (base des OAO) sym',is
!            call scripto(u(1:ndims,1:ndims)
!     *      ,ndims,ndims,ndims,ndims,orbi(nd1:nd2))
            call scriptol(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims,
     *      orbi(nd1:nd2)
     *      ,(/(i,i=1,ndims)/),tipo(1:ndims),occup(1:ndims))
         endif
 
c        recherche des actives dans cette symetrie
!         allocate(iord(ndims))
         allocate(jord(ndims))
         kk=nd1-1
         nact=0
!         nacto=0
         do k=1,ndims
            kk=kk+1
            if(yact(kk)) then
               nact=nact+1
!               if(k.le.nsoc(is)) nacto=nacto+1
!               iord(nact)=k
            endif
         enddo
!         kk=nd1-1
!         i=nact
!         do k=1,ndims
!            kk=kk+1
!            if(.not.yact(kk)) then
!               i=i+1
!               iord(i)=k
!            endif
!         enddo
!         ncor=icore(is)
!         nocc=nsoc(is)-nacto-ncor
!         nactv=nact-nacto
!         nval=nsal(is)-nactv
         ycao=.false.
c        on met les actives apres le coeur
!         if(ycao) then
!            jord(1:nact)=iord(1:nact)
!            iord(1:nocc)=iord(nact+1:nact+nocc)
!            iord(nocc+1:nocc+nact)=jord(1:nact)
!         endif
         if(yw)print*,'nact,ncor,nocc,nval',nact,ncor,nocc,nval
!         if(yw)print*,'nacto,nactv',nacto,nactv
!         if(yw)print3000,'iord',iord(1:ndims)
 3000    format(a10,10(10i4,/))
c        on reordonne u
!         u(1:ndims,1:ndims)=u(1:ndims,iord(1:ndims))



c        recouvrement entre les ORBITALES apres reordonnancement
!         s(1:ndims,1:ndims)
!     *   =matmul(transpose(u(1:ndims,1:ndims)),u(1:ndims,1:ndims))
!         w1(1:ndims)=occup(iord(1:ndims))
!         tipo1(1:ndims)=tipo(iord(1:ndims))
!         if(yw)print3001,'w1',w1(1:ndims)
c        recouvrement entre les ORBITALES locales en entree
         s(1:ndims,1:ndims)
     *   =matmul(transpose(u(1:ndims,1:ndims)),u(1:ndims,1:ndims))
         if(nprint.ge.2) then
!            print*,' ORBITALES locales en entree'
!            call script(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
            print*,'recouvrement'
            call script(s(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
         endif
         do k=1,ndims
            do l=1,k-1
               if(dabs(s(k,l)).gt.0.5d0) then
!                   print*,'ORBITALES',iord(k),iord(l),
                   print'(a,2i5,a,f8.4)','ORBITALES',k,l,
     *             ' GRAND RECOUVREMENT',s(k,l)
                    call scriptol2(u(1:ndims,(/k,l/)),ndims,2,ndims,2,
     *              orbi(nd1:nd2),(/k,l/),tipo((/k,l/)),(/0.,0./))
C                   print'(12x,a6,4x,a6)',tipo(k)(1:6),tipo(l)(1:6)
C                   if(len_trim(tipo(k))>6.or.len_trim(tipo(l))>6)
C     *             print'(12x,a6,4x,a6)',tipo(k)(7:12),tipo(l)(7:12)
C                   if(len_trim(tipo(k))>6.or.len_trim(tipo(l))>6)
C     *             print'(12x,a6,4x,a6)',tipo(k)(13:18),tipo(l)(13:18)
C                   do kkk=1,ndims
C                      if(dabs(u(kkk,k)).gt.1.d-2.or.
C     *                dabs(u(kkk,l)).gt.1.d-2)
C     *                print'(a,2f10.6)',orbi(nd1-1+kkk),
C     *                u(kkk,k),u(kkk,l)
C                   enddo
c                   call scripto(u(:,(/k,l/)),ndims,2,ndims,2,
c     *             orbi(nd1:nd2))
               endif
            enddo
         enddo
!         deallocate (iord)
         if(yw)print*,'rec des orb permutees'
         if(yw)call script(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
c
c---------------------------------------
c        ORTHOGONALISATION
c---------------------------------------
c
c     mise a zero des orb
         v(1:ndims,1:ndims)=0.d0
         do i=1,ndims
            v(i,i)=1.d0
         enddo


         ! Utilisation de hier pour les orthogonalisation
         !ordre des orthognalisations :
         ! 1. gelees occ
         ! 2. gelees virt
         ! 3. actives
         ! 4. valence
         ! 5. diffuses
         ! on met dans jord les numeros des orbitales dans l'ordre gel,
         ! coeur,actives,valence,diffuses
         !
         ! On travaille dans la base des OAO, la mat de rec est donc
         ! unite. on la met dans u1
         u1(1:ndims,1:ndims)=0.d0
         do k=1,ndims
            u1(k,k)=1.d0
         enddo
         !
         ! on etablit les limites des classes d'orthogonalisation
         !
         kk=0
         ngo=0
         do k=1,nsoc(is)
            if(tipo(k)(1:1)=='G') then
               kk=kk+1
               ngo=ngo+1
               jord(kk)=k
            endif
         enddo
         ngv=0
         do k=1+nsoc(is),ndims
            if(tipo(k)(1:1)=='G') then
               kk=kk+1
               jord(kk)=k
               ngv=ngv+1
            endif
         enddo
         nc=0
         do k=1,ndims
            if(tipo(k)(1:1)=='C') then
               kk=kk+1
               nc=nc+1
               jord(kk)=k
            endif
         enddo
         na=0
         do k=1,ndims
            if(tipo(k)(1:1)=='A') then
               kk=kk+1
               na=na+1
               jord(kk)=k
            endif
         enddo
         no=0
         do k=1,ndims
            if(tipo(k)(1:1)/='G'.and.tipo(k)(1:1)/='C'.and.
     *      tipo(k)(1:1)/='A'.and.tipo(k)(1:1)/='T') then
               kk=kk+1
               no=no+1
               jord(kk)=k
            endif
         enddo
         nt=0
         do k=1,ndims
            if(tipo(k)(1:1)=='T') then
               kk=kk+1
               nt=nt+1
               jord(kk)=k
            endif
         enddo
         noo=0
         do k=1,ndims
            if(tipo(k)(1:1)=='A') exit
            if(tipo(k)(1:1)/='G'.and.tipo(k)(1:1)/='C'.and.
     *      tipo(k)(1:1)/='T') then
               noo=noo+1
            endif
         enddo
         ng=ngo+ngv
         !print*,'jord'
         !print'(20i4)',jord
         !print*,'ngo,ngv,na,no',ngo,ngv,na,no
         ! orthogonalisation des gelees virt aux gelees occ
!         print*,'U',u(1,111:112)
         print*,'ortho gelees occ et virt:'
         call flush(6)
         call hier3(u(1:ndims,1:ndims),ndims,jord,0,ngo,ngo+ngv,
     *   u1(1:ndims,1:ndims),1,1,1)
!         print*,'U',u(1,111:112)
         print*,'ortho actives'
         call flush(6)
         ! orthogonalisation des actives
         call hier3(u(1:ndims,1:ndims),ndims,jord,ngo,ng,ng+na,
     *   u1(1:ndims,1:ndims),0,1,1)
!         print*,'U',u(1,111:112)
         print*,'orthogonalisation des valence'
         call flush(6)
         ! orthogonalisation des valence
         call hier3(u(1:ndims,1:ndims),ndims,jord,ng,ng+na,ng+na+no,
     *   u1(1:ndims,1:ndims),0,1,1)
!         print*,'U',u(1,111:112)
         print*,'orthogonalisation des "T_" (diffuses)'
         call flush(6)
         ! orthogonalisation des "T_" (diffuses)
         call hier3(u(1:ndims,1:ndims),ndims,jord,ng+na,ng+na+no,
     *   ndims,u1(1:ndims,1:ndims),0,1,1)
!         print*,'U',u(1,111:112)
         call flush(6)

            
            


         
!
!         i11=1
!         print*,'avant hiersmud2 nact,ncor,nval',nact,ncor,nval
!         ! orthogonalisation des coeur aux actives
!         call hiersmud2(nact,nact+ncor,ndims,s(1:ndims,1:ndims),
!     *   v(1:ndims,1:ndims),u1(1:ndims,1:ndims),u2(1:ndims,1:ndims)
!     *   ,i11)
!         stop
!         ! orthogonalisation de la valence aux coeur + actives
!         call hiersmud2(nact+ncor,nact+ncor+nocc+nval,
!     *   ndims,s(1:ndims,1:ndims),v(1:ndims,1:ndims),
!     *   u1(1:ndims,1:ndims),u2(1:ndims,1:ndims),i11)
!         ! Orthogonalisation du reste
!         call hiersmud2(nact+ncor+nocc+nval,ndims,
!     *   ndims,s(1:ndims,1:ndims),v(1:ndims,1:ndims),
!     *   u1(1:ndims,1:ndims),u2(1:ndims,1:ndims),i11)
         
         deallocate (jord)
c         print*,'nact',nact
!         if(yw)print*,'orb sortie hiersmud2'
!         if(yw)call scripto(v,ndims,ndims,ndim,ndim,orbi(nd1:nd2))
c      on place les actives au niveau de fermi
!         nnn=nsoc(is)-nacto
!         nboatot=nnn+nact
!         nactv=nact-nacto
!         if(yw)
!     *   print*,'nact,nboctot,nbocatot,nnn',nact,nboctot,nbocatot,nnn
!         u1(1:ndims,1:nact)=v(1:ndims,1:nact)
!         occup(1:nsoc(is)-nacto)=w1(nact+1:nsoc(is)+nactv)
!         tipo(1:nsoc(is)-nacto)=tipo1(nact+1:nsoc(is)+nactv)
!         v(1:ndims,1:nsoc(is)-nacto)
!     *   =v(1:ndims,nact+1:nsoc(is)+nactv)
!         if(yw)call scripto(v,ndims,ndims,ndim,ndim,orbi(nd1:nd2))
!         occup(nsoc(is)-nacto+1:nsoc(is)+nactv)=w1(1:nact)
!         tipo(nsoc(is)-nacto+1:nsoc(is)+nactv)=tipo1(1:nact)
!         v(1:ndims,nsoc(is)-nacto+1:nsoc(is)+nactv)
!     *   =u1(1:ndims,1:nact)
!         occup(nsoc(is)+nactv+1:ndims)=w1(nsoc(is)+nactv+1:ndims)
!         tipo(nsoc(is)+nactv+1:ndims)=tipo1(nsoc(is)+nactv+1:ndims)
!         if(yw)call scripto(v,ndims,ndims,ndim,ndim,orbi(nd1:nd2))
!         if(yw)print3001,'w1',w1(1:ndims)
!         if(yw)print3001,'occup',occup(1:ndims)
!         !if(yw)print3001,'tipo',tipo(1:ndims)
!         if(yw)print*,'orb sortie hiersmud2 reord'
!         if(yw)call scripto(v,ndims,ndims,ndim,ndim,orbi(nd1:nd2))
         if(yw) then
            print*,'ORBITALES  (base des OAO)'
            call scripto(u,ndims,ndims,ndim,ndim,orbi(nd1:nd2))
         endif
!         u1(1:ndims,1:ndims)=matmul(u(1:ndims,1:ndims)
!     *   ,v(1:ndims,1:ndims))
!         if(yw.or.nprint.ge.2) then
!            print*,'orbitales orthogonales dans la base des orb  s(-1/2)
!     &      '
!            call scripto(u1,ndims,ndims,ndim,ndim,orbi(nd1:nd2))
!            call scripto(u,ndims,ndims,ndim,ndim,orbi(nd1:nd2))
!         endif
c     passage dans la base des OA
 1000    format(4d18.12)
         do k=1,ndims
            read(1,'(a)') orb
            call flush(6)
            read(1,1000)(v(l,k),l=1,ndims)
         enddo
         u1(1:ndims,1:ndims)=matmul(v(1:ndims,1:ndims)
!     *   ,u1(1:ndims,1:ndims))
     *   ,u(1:ndims,1:ndims))
         print*,' '
         print*,'ORBITALES ORTHOGONALES DANS LA BASE DES OA  SYM',is
!         if(ncor.gt.0)write(6,'(a18,i4,''  - '',i3)')
!     *   'coeur :         ',1,ncor
!         if(nnn.gt.ncor)write(6,'(a18,i4,''  - '',i3)')
!     *   'occupees :      ',1+ncor,nnn
!         if(nact.ge.1)write(6,'(a18,i4,''  - '',i3)')
!     *   'actives :       ',nnn+1,nnn+nact
!         if(nval.ge.1)write(6,'(a18,i4,''  - '',i3)')
!     *   'valences virt : ',nnn+nact+1,nnn+nacto+nsal(is)
!         !print*,'nnn,nacto,nsal(is)',nnn,nacto,nsal(is)
         print*,' '
         print*,'priorites d''orthogonalisation : gelees, actives,'
     *   //'valence, diffuses'
         if(ngo.gt.0)write(6,'(a18,i4,''  - '',i3)')
     *   'gelees occ      ',1,ngo
         n=ngo
         if(nc.gt.0)write(6,'(a18,i4,''  - '',i3)')
     *   'coeur           ',n+1,n+nc
         n=n+nc
         if(no+na.gt.0)write(6,'(a18,i4,''  - '',i3,i4,''  - '',i3)')
     *   'valence         ',n+1,n+no+na
         n=n+noo
         if(na.gt.0)write(6,'(a18,i4,''  - '',i3)')
     *   'dont actives    ',n+1,n+na
         n=n-noo+no+na
         if(nt.gt.0)write(6,'(a18,i4,''  - '',i3)')
     *   'diffuses        ',n+1,n+nt
         n=n+nt
         if(ngv.gt.0)write(6,'(a18,i4,''  - '',i3)')
     *   'gelees virt     ',n+1,n+ngv
         n=ngv

         print*,' '
         print*,'OCCUPATIONS '
         print'(15x,10a8)', tipo(1:ndims)(1:6)
         print*,' '
         print'(15x,10f8.4)', occup(1:ndims)
         call scriptol2(u1,ndims,ndims,ndim,ndim,orbi(nd1:nd2)
     *   ,(/(i,i=1,ndims)/),tipo(1:ndims),occup(1:ndims))
         occup3(nd1:nd2)=occup(1:ndims)
         tipo3(nd1:nd2)=tipo(1:ndims)
         !write(4)nnn,nact,ndims
         if(yverif) then
            rewind 8
            do k=1,3*(is-1)+1
               read(8)
            enddo
            read(8) s(1:ndims,1:ndims)
            u2(1:ndims,1:ndims)=matmul(transpose(u1(1:ndims,1:ndims))
     *      ,matmul(s(1:ndims,1:ndims),u1(1:ndims,1:ndims)))
            print*,'verif'
            call script(u2,ndims,ndims,ndim,ndim)
         endif
c-----------------------------------------
c     ecriture des orbitales
c-----------------------------------------
         
         write(99) u1(1:ndims,1:ndims)
!         if(yw)
!     *   write(6,'(A)') '* Orbitales de liaison'
!         if(is.eq.1)write(2,'(A)') '* Orbitales de liaison'
!         do k=1,ndims
!            if(yw)write(6,'(''* ORBITAL'',2i5)') is,k
!            if(yw)write(6,1000)(u1(l,k),l=1,ndims)
!            write(2,'(''* ORBITAL'',2i5)') is,k
!            write(2,1000)(u1(l,k),l=1,ndims)
!         enddo
      enddo
!      if(yw)write(6,'(''* OCCUPATION NUMBERS'')')
!      write(2,'(''* OCCUPATION NUMBERS'')')
      if(yw)print*,'occup3',occup3(1:ndim)
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is)
         nd1=1+ndims0
         nd2=ndims+ndims0
         if(yw)print*,'nd1,nd2',nd1,nd2
         if(yw)write(6,1000)occup3(nd1:nd2)
!         write(2,1000)occup3(nd1:nd2)
         write(99) occup3(nd1:nd2)
      enddo
!      write(2,'(''* LABELS'')')
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is)
         nd1=1+ndims0
         nd2=ndims+ndims0
         if(yw)print*,'nd1,nd2',nd1,nd2
         if(yw)write(6,'(4a18)')tipo(nd1:nd2)
!         write(2,'(4a18)')tipo3(nd1:nd2)
         write(99) tipo3(nd1:nd2)
      enddo
      !inquire(99,name=orb);print*,'name',orb;stop
      call ecriorb('* Orbitales de liaison schmudort','LOCORB',
     *nsym,isym,99,2,newformat='LOCORB_newformat')
      close(99,status='delete')
      call titre('Fin Schmudort#',40)
      end
