      program INSERORB
      use mod_lirorb
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     lit deux fichiers d'obitales sur orbin1 et orbin2
!     choisit des orbitales dans un et l'autre fichier pour creer un
!     troisieme fichier
!     orthogonalise par Schmidt les secondes au premieres      
!     fichiers lus : orbin1 et orbin2      
!     les ecrit sur orbout
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!      
!
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      character(80) orbin1,orbin2,orbout,orb
      character(1000) namel
      dimension isym(8)
      allocatable id(:)
      double precision,allocatable,dimension(:) :: oc1,oc2,oco
      double precision,allocatable,dimension(:,:) :: uo,s
      double precision,allocatable,dimension(:,:,:) :: u
      integer,allocatable,dimension(:) :: j1
      character(6),allocatable,dimension(:) :: label
      character(18),allocatable,dimension(:) :: aao,aa1,aa2
      character(6) lab
      print*,' '
      print*,'------------------------------------------'
      print*,'                 INSERORB'
      print*,'------------------------------------------'
      print*,' '
!      
      yw=.false.
      orbin1=' '
      orbin2=' '
      orbout=' '
      call LECNAM('&INSOR',namel,5,ierr,1)
      call namela(namel,ORBIN1,'ORBIN1')
      call namela(namel,ORBIN2,'ORBIN2')
      call namela(namel,ORBOUT,'ORBOUT')
      print*,'Fichier 1 :  ',trim(ORBIN1)
      print*,'Fichier 2 :  ',trim(ORBIN2)
      print*,'Sortie    :  ',trim(ORBOUT)
!
      call lirorb(orbin1,norb,nsym,isym,2,1)
      call lirorb(orbin2,norb2,nsym2,isym,3,1)
      print*,'norb',norb
      print*,'nsym',nsym
      print'(a,8i3)','isym',isym(1:nsym)
      allocate (j1(norb),label(norb))
      if(norb2.ne.norb)
     *stop 'les 2 fichiers n''ont pas le meme nb d''orb'
      rewind 2
      rewind 3
!
!
!     decodage des donnees
!
      open(4,file='BID4',status='unknown')
      do is=1,nsym
         i=0
         if(yw)print*,'symetrie',is
         do    !boucle sur les donnees de la sym is
            orb=' '
            read(5,'(a)') orb     !lecture de la donnee
            write(lab,'(i4)') isym(is)
            call repl(orb,'$',lab,yrepl)
            orb=adjustl(orb)
            long=len_trim(orb)
            call maj(orb,long)
            call suppdb(orb,long)
            call repl(orb,'- ','-',yrepl)
            long=len_trim(orb)
            lab='??????'
            print*,trim(orb)
!           on cherche un label en donnee            
            indl=index(orb,'LABEL')
            if(yw)print*,'indl',indl
            if(indl.ne.0) then    !le label est-il donne ?
               lab=' '
               read(orb(indl+6:long),'(a)') lab
               orb(indl:long)=' '
               long=len_trim(orb)
            endif
            if(yw)print*,'orb,is',trim(orb),'         ',is
            read(orb,*) isl,if
            if(yw)print*,'isl,if',isl,if
            if(isl.ne.is) then   !test : la sym donne est-elle bonne ?
               print*,trim(orb)
               print*,'la symetrie donnee n''est pas bonne'
               stop
            endif
            m=index(trim(orb),'-')
!           cas ou on a donne une liste contigue         
            if(m.ne.0) then
               m2=long
               do k=m-1,1,-1
                  if(orb(k:k).eq.' ') then
                     m1=k
                     exit
                  endif
               enddo
               if(yw)print*,'m1,m2',m1,m2,orb(m1:m2)
               orb(m:m)=' '
               read(orb(m1:m2),*) i1,i2 ! bornes des orbitales contigues
               do k=i1,i2
                  i=i+1
                  write(4,'(3i5,1x,a)') is,if,k,lab
                  if(yw)write(6,'(3i5,1x,a)') is,if,k,lab
               enddo
            else
!              liste non contigue                 
               nbb=0
               do k=1,long
                  if(orb(k:k).eq.' ') nbb=nbb+1
               enddo
               nbd=nbb-1  ! orbitales non contigues
               if(yw)print*,'nbd',nbd
               allocate (id(nbd))
               read(orb,*)ibid,ibid,id(1:nbd)
               do k=1,nbd
                  i=i+1
                  write(4,'(3i5,1x,a)') is,if,id(k),lab
                  if(yw)write(6,'(3i5,1x,a)') is,if,id(k),lab
               enddo
               deallocate (id)
            endif
            if(yw)print*,'i,isym(is)',i,isym(is)
            if(i.eq.isym(is))exit
            if(i.gt.isym(is)) then
               print*,trim(orb)
               print*,
     *         'mauvaise donnee : trop d''orbitales dans la symetrie'
               stop
            endif
         enddo
      enddo

!
!     lecture des donnees
!
      rewind 4
      open(8,file='S',status='old',form='unformatted')
      open(10,file='BID10',status='unknown',form='unformatted')
      do is=1,nsym
!
!        lecture des orbitales
!      
         ndims=isym(is)
         allocate (u(isym(is),isym(is),2))
         allocate (uo(isym(is),isym(is)))
         allocate (s(isym(is),isym(is)))
         read(2)  u(:,:,1)
         read(3)  u(:,:,2)
         if(yw) then
            print*,'mat 1',' sym',is
            call script(u(:,:,1),isym(is),isym(is),isym(is),isym(is))
            print*,'mat 2',' sym',is
            call script(u(:,:,2),isym(is),isym(is),isym(is),isym(is))
         endif
         n1=0
         do i=1,isym(is)
            read(4,'(3i5,a)') is1,io,in,lab
            uo(:,i)=u(:,in,io)
            if(io.eq.1) then
               n1=n1+1
               j1(n1)=i
            endif
         enddo
         if(yw) then
            print*,'mat o',' sym',is
            call script(uo,isym(is),isym(is),isym(is),isym(is))
         endif
!        orthogonalisation
         read(8)
         read(8) s
         read(8)
         call hier2(uo,isym(is),n1,j1(1:n1),s)
         print*,'orbitales finales','    sym',is
         call script(uo(:,:),isym(is),isym(is),isym(is),isym(is))
         write(10) uo
         deallocate (u)
         deallocate (s)
         deallocate (uo)
      enddo
      rewind 4
      do is=1,nsym
!
!        lecture des occupations
!      
         ndims=isym(is)
         allocate (oc1(ndims),oc2(ndims),oco(ndims))
         read(2)  oc1
         read(3)  oc2
         if(yw)print*,'oc1',oc1
         if(yw)print*,'oc2',oc2
         do i=1,isym(is)
            read(4,'(3i5)') is1,io,in
            if(io.eq.1) oco(i)=oc1(in)
            if(io.eq.2) oco(i)=oc2(in)
         enddo
         if(yw)print*,'oco',oco
         write(10) oco
         deallocate (oc1,oc2,oco)
      enddo
!
!        lecture des labels
!      
      rewind 4
      iorb=0
      do is=1,nsym
         ndims=isym(is)
         allocate (aa1(ndims),aa2(ndims),aao(ndims))
         read(2,end=21)  aa1
         goto 22
 21      aa1='            ??????'        
 22      continue         
         read(3,end=20)  aa2
         goto 23
 20      aa2='??????'        
 23      continue         
         do i=1,ndims
            iorb=iorb+1
            read(4,'(3i5,1x,a)') is1,io,in,lab
            if(yw)print*,'llll',is1,io,in,lab,aa1(in),aa2(i)
            if(lab.eq.'??????') then
               if(io.eq.1) aao(i)=aa1(in)
               if(io.eq.2) aao(i)=aa2(in)
            else
               aao(i)=lab
            endif
         enddo
         write(10) aao
         if(yw)print*,'aao',aao
         deallocate (aa1,aa2,aao)
      enddo
      call ecriorb('*ORBITALES FUSIONNEES',orbout,
     *nsym,isym,10,11)
      close(10,status='delete')

      end
       subroutine suppdb(orb,long)
      character(*) orb
      j=1
      do i=2,long
         if(orb(i-1:i).ne.'  ') then
            j=j+1
            orb(j:j)=orb(i:i)
         endif
      enddo
      orb(j+1:long)=' '
      long=j
      return
      end
