      subroutine s2casdi_sub(noac,norb,ndet,ms2
     *,ivec,coefmin,det1,vec,noc,iout_in,mult)
      USE venond
      implicit none
      integer,parameter :: maxorbcas=16
      integer ifil_det,ne,ne0,ne0p,nep
      integer,dimension(maxorbcas+2) :: ntv,npv,ntv0,npv0,ntv1,npv1
      integer i,ierr,ii,j,isgn,ntrouv,ifil_trouv,norb,ms2,noac,noc
      integer ndet,iout,iout_in
      logical yw,yco,yw1
      integer nco,ico(maxorbcas+2)
      real(8),allocatable :: vecos(:)
      integer,allocatable :: ntvos(:,:),npvos(:,:)
      logical,allocatable :: yspin(:,:)
      integer ivec
      real(8) coefmin,vec(ndet)
      character(*) det1
      real(8) mult
      yw=.true.
      yw1=.true.
      if(iout_in/=6) then
         call open_chose_number(iout,'S2CASDI_OUT'
     *   ,'unknown','formatted')
      else
         iout=6
      endif
!***********************
! read determinants
! search determinant with coef > coefmin
!***********************
      call open_chose_number(ifil_det,det1,'old','unformatted')
      call venond_init(norb,ms2,noac,ifil_det)
      if(yw) then
         write(iout,*)' '
         write(iout,*)'**********************************'
         write(iout,*)'search determinant with coef > ',coefmin
      endif
      do i=1,ndet
         call venond2(ne0,ntv0,npv0,ierr)
         ne0p=ne0-mod(-ms2,2)
         !if((ntv0(1)/=10))cycle
         !if((ntv0(2)/=11))cycle
         !if((npv0(1)/=22))cycle
         !if(ne0<4) cycle
         if(yw1) then
            write(iout,'(a)',advance='no') ' cherche   '
            write(iout,'(i8,4x,20i4)',advance='no') i,ntv0(1:ne0)
            write(iout,'(a,20i4)',advance='no') ' --> ',npv0(1:ne0p)
            write(iout,'(4F10.6)') vec(i)
         endif
         if(abs(vec(i))>coefmin) then
            ii=i
            exit
         endif
         if(i==ndet) then
            write(iout,*)'no determinant found with this criterion'
            write(iout,*)'coefmin=',coefmin
            stop
         endif
      enddo
      if(yw) then
         write(iout,'(a)',advance='no') ' trouve !  '
         write(iout,'(i8,4x,20i4)',advance='no') i,ntv0(1:ne0)
         write(iout,'(a,20i4)',advance='no') ' --> ',npv0(1:ne0p)
         write(iout,'(4F10.6)') vec(ii)
      endif
      ntv0(1:ne0)=mod(ntv0(1:ne0)-1,norb)+1
      npv0(1:ne0p)=mod(npv0(1:ne0p)-1,norb)+1
      if(yw) then
         write(iout,'(a)',advance='no') ' ss spin:  '
         write(iout,'(i8,4x,20i4)',advance='no') i,ntv0(1:ne0)
         write(iout,'(a,20i4)',advance='no') ' --> ',npv0(1:ne0p)
         write(iout,'(4F10.6)') vec(ii)
         write(iout,*)'**********************************'
         write(iout,*)' '
      endif
!****************************
! search open shells in the determinant
!****************************
      write(iout,*)' '
      write(iout,*)'**********************************'
      write(iout,*)'search open shells in the determinant'
      nco=0
      do i=1,ne0
         yco=.true.
         do j=1,ne0
            if(i==j) cycle
            if(ntv0(i)==ntv0(j)) then
               yco=.false.
               exit
            endif
         enddo
         if(yco) then
            nco=nco+1
            ico(nco)=mod(ntv0(i),norb)
         endif
      enddo
      do i=1,ne0p
         yco=.true.
         do j=1,ne0p
            if(i==j) cycle
            if(npv0(i)==npv0(j)) then
               yco=.false.
               exit
            endif
         enddo
         if(yco) then
            nco=nco+1
            ico(nco)=mod(npv0(i),norb)
         endif
      enddo
      if(yw) then
         write(iout,'(a,20i4)')' ico',ico(1:nco)
         write(iout,*)'**********************************'
         write(iout,*)' '
      endif
      call reor(ne0,ntv0,isgn)
      call reor(ne0p,npv0,isgn)
!****************************
! search determinants with same space part
!****************************
      if(yw) then
         write(iout,*)' '
         write(iout,*)'**********************************'
         write(iout,*)'search determinants with same space part'
         if(yw1) write(iout,'(i8,4x,20i4)',advance='no')
     *   1000000000,ntv0(1:ne0)
         if(yw1)write(iout,'(a,20i4)') ' --> ',npv0(1:ne0p)
      endif
      call open_chose_number(ifil_trouv,'TROUV','unknown','unformatted')
      ntrouv=0
      call venond_init(norb,ms2,noac,ifil_det)
      do i=1,ndet
         call venond2(ne,ntv,npv,ierr)
         nep=ne-mod(-ms2,2)
         ntv1(1:ne)=mod(ntv(1:ne)-1,norb)+1
         npv1(1:nep)=mod(npv(1:nep)-1,norb)+1
         call reor(ne,ntv1,isgn)
         call reor(nep,npv1,isgn)
         if(ne==ne0) then
            if(all(ntv1(1:ne)==ntv0(1:ne))) then
               if(all(npv1(1:nep)==npv0(1:nep))) then
                  if(yw) then
                     write(iout,'(i8,4x,20i4)',advance='no') i,ntv(1:ne)
                     write(iout,'(a,20i4)',advance='no') ' --> '
     *               ,npv(1:nep)
                     write(iout,'(4F10.6,a)') vec(i)
                  endif
                  ntrouv=ntrouv+1
                  write(ifil_trouv) ntv(1:ne),npv(1:nep),vec(i)
               endif
            endif
         endif
      enddo
      write(iout,*)'**********************************'
      write(iout,*)' '
      
!****************************
! reorder open shell orbitals, signs
!****************************
      write(iout,*)' '
      write(iout,*)'************************************************'
      write(iout,*)'reorder open shell orbitals, signs '
      rewind ifil_trouv
      allocate(vecos(ntrouv))
      allocate(ntvos(ne0,ntrouv))
      allocate(npvos(ne0,ntrouv))
      allocate(yspin(ne0+ne0,ntrouv))
      call reor_OS(ifil_trouv,ne0,ne0p,ntvos,npvos,vecos,norb,ntrouv,
     *yspin(1:ne0+ne0p,:),noc,iout)
      write(iout,*)' '
      if(yw)write(iout,*)'Vecteur renormalise, phase corrigee'
      do i=1,ntrouv
         write(iout,'(i8,4x,20l2)',advance='no') i,yspin(1:nco,i)
         write(iout,'(4F10.6,a)') vecos(i)
      enddo
      write(iout,*)' '
      write(iout,*)'end reorder open shell orbitals'
      write(iout,*)'************************************************'
      write(iout,*)' '
      
! S2
      call S2(nco,yspin(1:nco,:),ntrouv,vecos,ms2,mult,iout)
      
      deallocate(vecos)
      deallocate(ntvos)
      deallocate(npvos)
      deallocate(yspin)
      end
!*****************************************************************
       subroutine reor_OS(ifil,ne,nep,ntv,npv,vec,norb,mdet,
     *yspin,noc,iout)
!
!====================================================
! en entree, ne couches ouvertes ecrites en T/P
! les spins beta sont reperes par un shift de +norb
! le det est reecrit en occupation
! les spinorbitales sont reordonnees en fonction de leur partie d'espace
!====================================================
!
      implicit none
      integer,parameter :: maxorbcas=16
      
! variables en entree
      integer norb,mdet,ifil,ne,ntv(ne,mdet),npv(ne,mdet),nep,noc
      integer iout
      
! variables en sortie
      logical yspin(ne+nep,mdet),yw,yw1
      real(8) vec(mdet)
      
! variables internes
      integer i,j,k,isgn,nocc,nocc1,nea,neb,jsgn
      integer iocc(maxorbcas+2)
      integer iocc1(maxorbcas+2)
      real(8) anorm
      integer,allocatable :: ibid(:),ibid1(:)
      yw=.true.
      yw1=.true.
      allocate(ibid(noc+noc))
      allocate(ibid1(noc+noc))
      
      
! Lecture du bloc de  determinants de meme partie d'espace
      rewind ifil
      do i=1,mdet
         read(ifil) ntv(:,i),npv(1:nep,i),vec(i)
         if(nep/=ne) npv(ne,i)=norb+norb+1
      enddo
      
! Ecriture en occupations
!   Determinant de reference (avant excitations T/P)
      do i=1,mdet
         if(yw1) then
            write(iout,*)' '
            write(iout,*)'det en entree, a reecrire en occupations'
            write(iout,'(i8,4x,20i4)',advance='no') i,ntv(1:ne,i)
            write(iout,'(a,20i4)',advance='no') ' --> ',npv(1:nep,i)
            write(iout,'(F10.6,a)') vec(i)
         endif
c   --on occupe jusqu'a noca0
         do k=1,noc
            ibid(k)=k
            ibid(k+noc)=k+norb
         enddo
         if(yw1) then
            write(iout,*)'det de ref ecrit en occupations'
            write(iout,'(a,150i3)')'ibid',ibid(1:noc)
            write(iout,'(a,150i3)')'ibid',ibid(1+noc:noc+noc)
         endif
c   --on place les part dans les trous (mode cipsi)
         nea=0
         do k=1,ne
            if(ntv(k,i).le.norb)ibid(ntv(k,i))=npv(k,i)
            if(ntv(k,i).le.norb) nea=nea+1
            if(ntv(k,i).gt.norb)ibid(mod(ntv(k,i)-1,norb)
     *      +1+noc)=npv(k,i)
         enddo
         if(yw1) then
            write(iout,*)'det en entree ecrit en occupations'
            write(iout,*)'il correspond au signe cipsi, lu de casdi'
            write(iout,'(a,150i3)')'ibid1',ibid(1:noc)
            write(iout,'(a,150i3)')'ibid1',ibid(1+noc:noc+noc)
         endif
         neb=ne-nea
      
! On reordonne le determinant dans l'ordre des orbitales
! on met le meme numero aux spinorbitales alpha et beta
         ibid1=ibid
         where(ibid1>norb) ibid1=ibid1-norb
         if(yw1) then
            write(iout,*)
     *      'si on supprime le spin :'
            write(iout,'(a,150i3)')'ibid5A',ibid1(1:noc)
            write(iout,'(a,150i3)')'ibid5A',ibid1(1+noc:noc+noc)
         endif
c   --on reordonne
         call reordoubleij(noc+noc,ibid1,ibid,isgn)
         if(yw1) then
            write(iout,*)'det en entree ecrit en occupations, '//
     *      'reordonne en partie d''espace'
            write(iout,*)'sans spin, puis avec spin'
            write(iout,'(a)',advance='no')'ibid2'
            write(iout,'(150i3)'),ibid1(1:noc+noc)
            write(iout,'(a)',advance='no')'ibid2'
            write(iout,'(150i3)'),ibid(1:noc+noc)
            write(iout,*)'isgn',isgn
         endif
! Eliminer les couches fermees
         if(yw1)write(iout,*)'Eliminer les couches fermees'
         nocc1=noc+noc
         do k=1,noc+noc
            do j=k+1,noc+noc
               if(abs(ibid(j)-ibid(k))==norb) then
                  !if(abs(ibid(j)-ibid(k))==0) then
                     nocc1=nocc1-2
                     ibid(k)=0
                     ibid(j)=0
                     ibid1(k)=0
                     ibid1(j)=0
                  endif
               enddo
            enddo
            if(yw1) then
               write(iout,'(a)',advance='no')'ibid4'
               write(iout,'(150i3)'),ibid1(1:noc+noc)
               write(iout,'(a)',advance='no')'ibid4'
               write(iout,'(150i3)'),ibid(1:noc+noc)
            endif
            nocc=0
            do k=1,noc+noc
               if(ibid(k)/=0) then
                  if(ibid1(k)<=norb) then
                     nocc=nocc+1
                     iocc(nocc)=ibid1(k)
                     yspin(nocc,i)=ibid(k)<=norb
                  endif
               endif
            enddo
            if(yw1)write(iout,'(a,20i4)',advance='no')
     *      ' Elim CF : Det ecrit en occupations, spins',iocc(1:nocc)
            if(yw1) write(iout,*)'   ',yspin(1:nocc,i)
!
! On reordonne dans l'ordre des orbitales
            call reordoubleil(nocc,iocc,yspin(:,i),jsgn)
            if(yw) then
               write(iout,*)' '
               write(iout,*)
     *         'Det ecrit dans l''ordre des orbitales,spins,signe'
               write(iout,'(20i4)',advance='no') iocc(1:nocc)
               write(iout,'(20l2)',advance='no') yspin(1:nocc,i)
               write(iout,'(i8)') isgn
            endif
            vec(i)=vec(i)*isgn*jsgn
         enddo
         deallocate(ibid,ibid1)
! normalisation de vec
         anorm=sqrt(dot_product(vec,vec))
         vec=vec/anorm
      
         end
!*************************************************************
         subroutine reordoubleil(n,it,yt,isgn)
         integer it(n)
         logical yt(n),yy
         isgn=1
         do 1 i=1,n-1
         do 2 j=i+1,n
         if(it(j).ge.it(i)) goto 2
         isgn=-isgn
         ii=it(i)
         it(i)=it(j)
         it(j)=ii
         yy=yt(i)
         yt(i)=yt(j)
         yt(j)=yy
 2       continue
 1       continue
         return
         end
!*************************************************************
         subroutine reordoubleij(n,it,jt,isgn)
         integer it(n)
         integer jt(n),ii
         isgn=1
         do 1 i=1,n-1
         do 2 j=i+1,n
         if(it(j).ge.it(i)) goto 2
         isgn=-isgn
         ii=it(i)
         it(i)=it(j)
         it(j)=ii
         ii=jt(i)
         jt(i)=jt(j)
         jt(j)=ii
 2       continue
 1       continue
         return
         end
