      subroutine combinorb
      use mod_lirorb
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension isym(8)
      character(100000) namel
      character(80) orb
      allocatable ol(:,:),occup(:),ol2(:,:)
      character(18),allocatable,dimension(:) :: tipo
      character(8),allocatable,dimension(:) :: orbi
      character(8) :: label(9)
      logical(1),allocatable,dimension(:) :: y,y2
      integer,allocatable,dimension(:) :: jrot
      dimension irot(8)
      character sgn(8)
      integer,dimension(8,8) :: isgn2,isgn=  reshape(
     *                                      (/ 1, 1, 1, 1, 1, 1, 1, 1,
     *                                         1,-1, 1,-1, 1,-1, 1,-1,
     *                                         1, 1,-1,-1, 1, 1,-1,-1,
     *                                         1,-1,-1, 1, 1,-1,-1, 1,
     *                                         1, 1, 1, 1,-1,-1,-1,-1,
     *                                         1,-1, 1,-1,-1, 1,-1, 1,
     *                                         1, 1,-1,-1,-1,-1, 1, 1,
     *                                         1,-1,-1, 1,-1, 1, 1,-1/),
     *                                         (/8,8/))
      call titre('COMBINORB#',30)
      call lirorb('DESYMORB',noa,nsym,isym,99,98,ifiloc=97,ifillab=96)
      allocate(ol(noa,noa),occup(noa),tipo(noa),orbi(noa))
      allocate(ol2(noa,noa),y(noa),y2(noa),jrot(noa))
      yw=.false.
      orbi=' '
      read(99) ol
      close(99,status='delete')
      ol2=ol
      read(97) occup
      close(97,status='delete')
      read(96) tipo
      close(96,status='delete')
      close(98)
      open(98,file='DESYMORB2',status='old',form='unformatted')
      read(98)
      read(98) orbi
      close(98)
!
      if(yw)call scriptol(ol,noa,noa,noa,noa,orbi
     *,(/(k,k=1,noa)/),tipo(:)(1:12),occup)
      rewind 93
      call LECNAM('&COMBINORB ',namel,93,ierr,1)
      if(ierr==1) then
         print*,'======================================================'
         print*,'ycombinorb=t, mais il n''y a pas de namelist COMBINORB'
         print*,'======================================================'
         stop
      endif
      y=.false.
      y2=.false.
      open(99)
      do
         read(93,1000) orb
 1000    format(a80)
         orb=adjustl(orb)
         l=len_trim(orb)
         call suppdb(orb,l)
         l=len_trim(orb)
         call maj(orb,l)
         if(orb(1:3)=='FIN') exit
         print*,'donnee  ',trim(orb)
         ii=index(orb,' ')
         read(orb,*) n
         sgn(1:n)='+'
         if(ichar(orb(ii+1:ii+1))<58.and.ichar(orb(ii+1:ii+1))>47) then
            ! On a donne des numeros
            read(orb,*) n,irot(1:n)
            ii=min(index(orb,'+'),index(orb,'-'))
            if(ii/=0) read(orb(ii:ii-1+n),'(8a1)') sgn(1:n)
            print'(a,8a1)','donnee  '//orb(1:ii-1),sgn(1:n)
         else
            ! On a donne des labels
            label=' '
            read(orb,*) n
            ideb=ii+1
            do k=1,n
               read(orb(ideb:80),'(a)') label(k)
               ideb=index(orb(ideb:80),' ')+ideb
            enddo
            read(orb(ideb:80),'(8a1)') sgn(1:n)
            kk=0
            do k=1,n
               do l=1,noa
                  if(y2(l)) cycle
                  if(label(k)==tipo(l)) then
                     kk=kk+1
                     irot(kk)=l
                     y2(l)=.true.
                  endif
               enddo
            enddo
         endif
         write(99,*) n,irot(1:n)
         isgn2=isgn
         do k=1,n
            if(sgn(k)=='-') then
               isgn2(:,k)=-isgn2(:,k)
            endif
         enddo
         y(irot(1:n))=.true.
         if(yw)print*,'irot',irot(1:n)
         do k=1,n
            ol2(:,irot(k))=0.d0
            do l=1,n
               ol2(:,irot(k))=ol2(:,irot(k))+isgn2(k,l)*ol(:,irot(l))
            enddo
            ol2(:,irot(k))=ol2(:,irot(k))/dsqrt(1.d0*n)
         enddo
      enddo
      n=0
      do k=1,noa
         if(y(k)) then
            n=n+1
            jrot(n)=k
         endif
      enddo
      print*,'orbitales a combiner'
      call scriptol(ol(:,jrot(1:n)),noa,n,noa,n,orbi
     *,jrot(1:n),tipo(jrot(1:n))(1:12),occup(jrot(1:n)))
      call ren_norot(tipo,noa,n,jrot)
      print*,'orbitales recombinees'
      call scriptol(ol2(:,jrot(1:n)),noa,n,noa,n,orbi
     *,jrot(1:n),tipo(jrot(1:n))(1:12),occup(jrot(1:n)))
      print*,tipo(jrot(1:n))
      open(98,form='unformatted',file='TIPOCOMBINORB',status='unknown')
      write(98) tipo
      close(98)
      open(98,form='unformatted',file='COMBINORB',status='unknown')
      write(98) n,jrot(1:n),ol2(:,jrot(1:n))
      rewind 99
      do
         read(99,*,end=1) n,irot(1:n)
         write(98) n,irot(1:n)
      enddo
 1    continue
      close(98)

      
         
      return
      end
      
      subroutine ren_norot(tipo,noa,n,jrot)
      character(18),dimension(noa) :: tipo
      dimension jrot(n)
      character(80),dimension(16) :: ac1
      integer,dimension(16) :: iac1
      logical yw
      yw=.false.
      ac1=' '
      if(yw) print*,'ren_norot n',n
      do k=1,n
         ac1(k)(1:18)=tipo(jrot(k))
      enddo
      do k=1,n
         if(yw)print*,'avant',trim(ac1(k))
      enddo
      do k=1,n
         do l=1,k-1
            if(ac1(k)==ac1(l)) call incr_name2(ac1(k),0)
            if(ac1(k)==ac1(l)) print*,'a renommer',k,l
         enddo
      enddo
      do k=1,n
         if(yw)print*,'apres',trim(ac1(k)),k,jrot(k)
         tipo(jrot(k))=ac1(k)
      enddo
      return
      end
