      subroutine S2(n_OpSh,det,ndet,vec,ms2,mult,iout)
      implicit real(8) (a-h,o-z)
      logical det(n_OpSh,ndet),d(10),yw,yverif
      real(8) VEC(*),mult
      real(8),allocatable :: S2VEC(:)
      yw=.true.
      yverif=.false.
      
      write(iout,*)' '
      write(iout,*)'======================='
      write(iout,*)'S2  S2  S2  S2  S2  S2 '
      write(iout,*)'======================='
      write(iout,*)' '
      allocate(S2VEC(ndet))
      S2VEC=0.d0
      
      write(iout,*)'n_OpSh',n_OpSh
      write(iout,*)'input determinants'
      do k=1,ndet
         write(iout,'(i4,3x,20l2)',advance='no')  k,det(1:n_OpSh,k)
         write(iout,'(f10.6)') vec(k)
      enddo
      
      nba=(n_OpSh+ms2)/2
      nbb=(n_OpSh-ms2)/2
      
      do k=1,ndet
         do l=1,n_OpSh
            do m=l+1,n_OpSh
               d(1:n_OpSh)=det(:,k)
               if(d(l)) then
                  if(.not.d(m)) then
                     d(l)=.false.
                     d(m)=.true.
                     n=k
                     call cherche(d,det,n,n_OpSh,ndet)
                     S2VEC(n)=S2VEC(n)+vec(k)
C                     write(iout,*)'trouve en',n
                  endif
               else
                  if(d(m)) then
                     d(l)=.true.
                     d(m)=.false.
                     call cherche(d,det,n,n_OpSh,ndet)
                     S2VEC(n)=S2VEC(n)+vec(k)
C                     write(iout,*)'trouve en',n
                  endif
               endif
            enddo
         enddo
      enddo
      
      write(iout,*)' '
      write(iout,*)'VEC, S2*VEC'
      do k=1,ndet
         S2VEC(k)=S2VEC(k)+(ms2*ms2+nba*2+nbb*2)*0.25*vec(k)
      enddo
      do k=1,ndet
         write(iout,'(i4,20l2)',advance='no') k,det(:,k)
         write(iout,'(2f10.6)')VEC(k),S2VEC(k)
      enddo
! Verif fonction propre
      do k=1,ndet
         if(abs(vec(k))<1.d-6) cycle
         a=S2VEC(k)/VEC(k)
         kbon=k
         exit
      enddo
      if(yverif) then
         do k=1,ndet
            if(abs(vec(k))<1.d-6) then
               if(abs(S2vec(k))>1.d-6) then
                  write(iout,*)'non vecteur propre nou/non nul'
     *            ,VEC(k),S2VEC(k)
                  !stop
               endif
            endif
            if(abs(S2VEC(k)/VEC(k)-a)>1.d-6) then
               write(iout,*)'non vecteur propre',a,S2VEC(k)/VEC(k)
               !stop
            endif
         enddo
      endif
      
! Resolution de S*(S+1)=S2VEC(k)/VEC(K)
      SV=S2VEC(kbon)/VEC(kbon)
      delta=1.d0+4*SV
C      write(iout,*)'delta',delta
      S=(-1+sqrt(delta))/2
      mult=S+S+1
      write(iout,*)' '
      write(iout,*)'======================='
      write(iout,'(a,f10.4)')'    S=',S
      write(iout,'(a,f10.4)')' mult=',mult
      write(iout,*)'======================='
      
      end
!*************************************************************
       subroutine cherche(d,det,n,norb,ndet)
      logical det(norb,ndet),d(10)
      do k=1,ndet
         if(all(det(:,k).eqv.d(1:norb))) then
            n=k
            exit
         endif
      enddo
      end
