       SUBROUTINE polspi(ab,maxdav) 
      use venond
      parameter (maxal=56)
      include 'maxorb.prm'
      parameter (maxorbcas=16,ngru3=2048)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      character*2 SPI
      character*4 gener
      common/dim/ iadri
      common /det/ndet,mdet(50),nbdet_cas
      common /orb/ enuc,eref,norb,noca,nocb
     *       ,iorb(2*maxorb),ninac,nvirt,noca0
      common /orbspi/ norbspi,iorbspi(10),spi
     *,y1h,y1p,y1h1p,y22h,y2p,y1h2p,y2h1p,yio
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /prep/ nca0,ncb0,ic0(maxorbcas),icamun(maxorb+maxorb)
     *      ,numt(maxorb),nump(maxorb),nv
     *      ,gener,yoc(maxorb+maxorb),yrefc(maxorbcas),yac(maxorb)
     *      ,ygmono,ygddci,ygddc2,ygcas,ygtous

      dimension ntv(10),npv(10)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      DIMENSION AB(MAXDAV)
      common/test/ itest(100)
c***************************************************************************
c  On mets a 0 tous les coeffs ioniques
c  CAS+SP
c  Si y1h --> CAS+SP+1h ne faisant intervenir aucun ionique
c  SI y1p --> CAS+SP+1P
c***************************************************************************
c***************************************************************************
      call rew61
      call venond_init(norb,ms2,noac,61)
c      write(6,*)'noca0',noca0
      do ll=1,ndet
          yykilled=.false.
C         write(6,*)'y22h',y22h
c         write(6,*)'abinit',ab(ll)
         call venond2(ne,ntv,npv,ierr)
         if(ierr.eq.1) goto 102
C        print'(a,20i4)','ll,ne,ntv,npv,ierr',
C     *    ll,ne,(ntv(k),k=1,ne),(npv(k),k=1,ne),ierr
        
c on compte le nbr d electrons dans l espace actif ::
         nbr=nelac
         ipascast=0
         ipascasp=0
          do k=1,ne
            yp=.false.
            yt=.false.
                do j=1,noac
                    if(iorb(ntv(k)).eq.iorbspi(j)) then 
                        yt=.true.
                    endif
                    if(iorb(npv(k)).eq.iorbspi(j)) then
                        yp=.true.
                    endif
                enddo
            if (.not.yt) then
                ipascast=ipascast+1
            endif
            if (.not.yp) then
                ipascasp=ipascasp+1
c                write(6,*)'dimoiquecla'
            endif
          enddo
c         write(6,*)'ipascast,ipascasp',ipascast,ipascasp
c Neutre :: Pascast0 et pascasp0 

         yyio=.false.
         yy1h=.false.
         yy1p=.false.
         yy1p1h=.false.
         yy2h=.false.
         yy2p=.false.
         yy2h1p=.false.
         yy1h2p=.false.
c on classe les determinants selon leur nombre de trous
c et de particules crees
c
c si y1h on laisse les 1h
c        IF(nbr.eq.(nelac+1).and.y1h) yy1h=.true.
         IF(yio) yyio=.true.
         IF(ipascast.eq.1.and.ipascasp.eq.0.and.y1h) yy1h=.true.
c si y1p on laisse les 1p         
c        IF(nbr.eq.(nelac-1).and.y1p) yy1p=.true.
         IF(ipascast.eq.0.and.ipascasp.eq.1.and.y1p) yy1p=.true.
c si y1p1h on laisse les 1p1h         
         IF(ipascast.eq.1.and.ipascasp.eq.1.and.y1h1p) yy1p1h=.true.
c si y22h on laisse les 2h
         IF(ipascast.eq.2.and.ipascasp.eq.0.and.y22h) yy2h=.true.
c si y2p on laisse les 2p         
         IF(ipascast.eq.0.and.ipascasp.eq.2.and.y2p) yy2p=.true.
c si y2h-1p on laisse les 2h1p
         IF(ipascast.eq.2.and.ipascasp.eq.1.and.y2h1p) yy2h1p=.true.
c si y1h2p on laisse les 1h2p         
         IF(ipascast.eq.1.and.ipascasp.eq.2.and.y1h2p) yy1h2p=.true.
          
c Les dets du cas (supprime tous les dets ioniques !)::

c                  write(6,*)' yy2p yy2h',yy2p,yy2h
         ioh=0
         iop=0
         do i=1,norbspi
c    les orbitales actives sous Fermi
            IF(iorbspi(i).le.noca0)then
               nel=2
               do k=1,ne
c                  write(6,*)'ne:',ne
                  if(iorb(ntv(k)).eq.iorbspi(i)) nel=nel-1
               enddo
               if(nel.ne.1) ioh=ioh+1
            ENDIF
C les lignes suivantes sont fausses
C si on veut tuer les ions sur les trous mais pas sur les part -> faux
          if(ipascast.ne.0.or.ipascasp.ne.0) goto 100
              if(ioh.gt.0) then 
                  ab(ll)=0.d0
                  yykilled=.true.
C              write(6,*)' det dead ioh',i,ll,ne,(iorb(ntv(kk)),kk=1,ne)
              endif
100         continue
               
c    les orbitales actives au dessus de Fermi
            IF(iorbspi(i).gt.noca0)then
               nel=0
               do k=1,ne
c                  write(6,*)'ne:',ne
                  if(iorb(npv(k)).eq.iorbspi(i)) nel=nel+1
               enddo
               if(nel.ne.1) iop=iop+1 
            ENDIF
          if(ipascast.ne.0.or.ipascasp.ne.0) goto 101
              if(iop.gt.0) then 
                  ab(ll)=0.d0
                  yykilled=.true.
C              write(6,*)' det dead iop',i,ll,ne,(iorb(npv(kk)),kk=1,ne)
              endif
101         continue         
         enddo
c  ioh nombre orbitales actives doublement occupees au depart
c qui sont au final (apres excit)  soit avec 2e soit 0e
c  iop nombre orbitales actives virtuelles au depart
c qui sont au final soit avec 2e ou 0e
c   
         iot=ioh+iop
c         write(6,*)'iot ioh iop',iot,ioh,iop
c On ne prend que les neutres ...
c         write(6,*)'yyio',yyio
         if(yyio) goto 103
         if((yy1h.or.yy1p).and.(iot.gt.1)) then
             ab(ll)=0.d0
             yykilled=.true.
             write(6,*)' det dead car 1h ou 1p'
         endif
         if((yy1p1h).and.(iot.gt.1)) then
             ab(ll)=0.d0
             yykilled=.true.
             write(6,*)' det dead car 1h1p'
         endif
         if((yy2h.or.yy2p).and.(iot.gt.2)) then
             ab(ll)=0.d0
             yykilled=.true.
             write(6,*)' det dead car 2h ou 2p'
         endif
c         if((yy2h1p.or.yy1h2p).and.(iot.gt.1)) then
         if(yy2h1p) then
             ab(ll)=0.d0
             yykilled=.true.
             write(6,*)' det dead car 2h1p'
         endif
         if(yy1h2p) then
             ab(ll)=0.d0
c             yykilled=.true.
c             write(6,*)' det dead car 1h2p'
         endif
103      continue
c      if (ab(ll).eq.0.d0) then
c          write(6,*)'     Ce det is dead :'
c      endif
       if (yykilled) then
         if (ne.eq.0) then
             write(6,*)'ll |nbr de holes|nbr particules'
             write(6,*)ll,ipascast,ipascasp
             write(6,*)'     -----------------------------'
         else
             write(6,*)'ll |nume |ntv |npv |ipascast |ipascasp '
           do k=1,ne
             write(6,*)ll,k,iorb(ntv(k)),iorb(npv(k)),ipascast,ipascasp
           enddo 
           write(6,*)'     -----------------------------'
         endif
       endif
c            write(6,*)'abfinal',ab(ll)
c            write(6,*)'     -----------------------------'
c      endif
      enddo
102   continue
      end

