      subroutine egaspi(v,y,ndim)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
c
c-------------------------------------------------------------
c     subroutine mettant toutes les composantes de spin
c     d'une meme partie d'espace egales
c-------------------------------------------------------------
c
      PARAMETER (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/pr/nprint,mprint(10)
      common/cas_spin/isz0
      integer(8) ndet ; common/det/ndet,mdet(50),nbdet_cas
      character*1 cdet(maxorb+maxorb)
      equivalence (cdet(1),ydet(1))
      dimension v(ndim),y(ndim),ydet(maxorb+maxorb),ico(maxorbcas+4)
      dimension ns1(maxorbcas+4),iequiv(2**(maxorbcas+4))
      dimension itv(maxorbcas+2),ipv(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas)
      dimension it(2),ip(2)
      yw=.false.
      yw1=.false.
      if(yw)print*,' entree egaspi'
      do k=1,ndet
         y(k)=.false.
      enddo
      call rew61
      do idet=1,ndet
         call venondloc(ne,itv,ipv,ierr)
c         read(61) ne
c         if(ne.ne.0)read(61) (itv(k),k=1,ne),(ipv(k),k=1,ne)
         if(yw)write(6,'('' ntv,npv'',12i3)')
     *   (itv(k),k=1,ne),(ipv(k),k=1,ne)
         call trad(ne,itv,ipv,nca,ica,ncb,icb,nt,it,
     *   ispt,np,ip,ispp,ierr)
         if(yw)write(6,'('' it'',12i3)')
     *   (it(k),k=1,nt)
         if(yw)write(6,'('' ip'',12i3)')
     *   (ip(k),k=1,np)
         call adrdet
     *   (nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *      mhdum,mtdum)
         if(yw)print*,'iadr1',iadr1
         if(y(iadr1)) goto 1
         y(iadr1)=.true.
c
c--      nombre de couches ouvertes
         call trady(nca,ica,ncb,icb,nt,it,np,ip
     *   ,ispt,ispp,ydet,ydet(norb+1),'tcp>y')
         nco=0
         do k=1,norb
            if(cdet(k).ne.cdet(k+norb)) then
               nco=nco+1
               ico(nco)=k
            endif
         enddo
         if(nco.eq.0) goto 1
         nalpha=nco/2+ms2/2
         if(yw)write(6,'('' co'',12i3)')(ico(k),k=1,nco)
c
c--      generation des autres configurations de spin
         do k=1,nco
            ydet(ico(k))=.false.
         enddo
         nequiv=0
         call combi0(ns1,nco,nalpha,iret)
         goto 24
 4       call combi2(ns1,nco,nalpha,iret)
 24      continue
         if(yw)print*,'ns1',(ns1(k),k=1,nalpha)
         do k=1,nalpha
            ydet(ico(ns1(k)))=.true.
         enddo
         do k=1,nco
            ydet(ico(k)+norb)=.not.ydet(ico(k))
         enddo
         if(yw)print*,'ydet',(ydet(k),k=1,norb)
         if(yw)print*,'ydet',(ydet(k+norb),k=1,norb)
         call trady(nca,ica,ncb,icb,nt,it,np,ip
     *   ,ispt,ispp,ydet,ydet(norb+1),'y>tcp')
         if(yw)write(6,'('' it'',12i3)')
     *   (it(k),k=1,nt)
         if(yw)write(6,'('' ip'',12i3)')
     *   (ip(k),k=1,np)
         if(yw)write(6,'('' ica'',12i3)')
     *   (ica(k),k=1,nca)
         if(yw)write(6,'('' icb'',12i3)')
     *   (icb(k),k=1,ncb)
         call adrdet
     *   (nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *      mhdum,mtdum)
         y(iadr1)=.true.
         nequiv=nequiv+1
         iequiv(nequiv)=iadr1
         do k=1,nalpha
            ydet(ico(ns1(k)))=.false.
         enddo
         if(iret.eq.0) goto 4
         if(yw1)write(6,'('' iequiv'',12i5)')(iequiv(k),k=1,nequiv)
         val=0.d0
         do k=1,nequiv
            val=val+v(iequiv(k))
            if(yw1)write(6,'('' v'',f12.8)') v(iequiv(k))
         enddo
         val=val/nequiv
         if(yw1)write(6,'('' v egal '',f12.8)') val
         do k=1,nequiv
            v(iequiv(k))=val
         enddo
 1       continue
      enddo
      return
      end
       subroutine trady(nca,ica,ncb,icb,nt,it,np,ip
     *,ispt,ispp,ya,yb,cas)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      PARAMETER (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      character*5 cas
      dimension it(2),ip(2),ica(maxorbcas),icb(maxorbcas)
      dimension ya(norb),yb(norb)
      yw=.false.
      if(cas.eq.'tcp>y') then
         do k=1,norb
            ya(k)=itype(k).eq.1
            yb(k)=itype(k).eq.1
         enddo
         nta=(nt+ispt)/2
         npa=(np+ispp)/2
         ntb=nt-nta
         npb=np-npa
         do k=1,nta
            ya(it(k))=.false.
         enddo
         do k=nta+1,nta+ntb
            it(k)=iorb(it(k))
            yb(it(k))=.false.
         enddo
         do k=1,npa
            ya(ip(k))=.true.
         enddo
         do k=npa+1,npa+npb
            ip(k)=iorb(ip(k))
            yb(ip(k))=.true.
         enddo
         do k=1,nca
            ya(ica(k))=.true.
         enddo
         do k=1,ncb
            yb(icb(k))=.true.
         enddo
         if(yw)print*,'nta,ntb,npa,npb',nta,ntb,npa,npb
         if(yw)print*,'nca,ncb',nca,ncb
         if(yw)print*,'ya',ya,'   yb',yb
      else if(cas.eq.'y>tcp') then
         nta=0
         ntb=0
         npa=0
         npb=0
         nca=0
         ncb=0
         if(yw)print*,'ya',ya,'   yb',yb
         do k=1,norb
            if(itype(k).eq.1) then
               if(.not.ya(k)) then
                  nta=nta+1
                  it(nta)=k
               endif
            else
               if(ya(k)) then
                  if (itype(k).eq.2) then
                     nca=nca+1
                     ica(nca)=k
                  else if (itype(k).eq.3) then
                     npa=npa+1
                     ip(npa)=k
                  endif
               endif
            endif
         enddo
         do k=1,norb
            if(itype(k).eq.1) then
               if(.not.yb(k)) then
                  ntb=ntb+1
                  it(nta+ntb)=k
               endif
            else
               if(yb(k)) then
                  if (itype(k).eq.2) then
                     ncb=ncb+1
                     icb(ncb)=k
                  else if (itype(k).eq.3) then
                     npb=npb+1
                     ip(npa+npb)=k
                  endif
               endif
            endif
         enddo
         if(yw)print*,'nta,ntb,npa,npb',nta,ntb,npa,npb
         nt=nta+ntb
         np=npa+npb
         ispt=nta+nta-nt
         ispp=npa+npa-np
      else
         stop 'cas non reconnu dans trady'
      endif
      return
      end
