      subroutine sc04(hii,dum)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      parameter(idirac=15000,idirap=maxorb*maxorb)
      common/dim/iadri ; integer(8) iadri
c
c----------------------------------------------------------------
c     on a commence a remplir les 2 det
c     on finit de les remplir de facon semblable a droite et a
c     gauche
c----------------------------------------------------------------
c
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      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
      character*4 gener
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      common/sgn/ksgn(maxorb+maxorb),isgn0,intsgn
      common /icd3/ numta(maxorb),numca(maxorb),numpa(maxorb),
     *numtb(maxorb),numcb(maxorb),numpb(maxorb)
      common/compt/nt1,np1,nc1,nt2,np2,nc2,
     *nt1a,np1a,nc1a,nt1b,np1b,nc1b,
     *nt2a,np2a,nc2a,nt2b,np2b,nc2b,
     *nt3a,np3a,nc3a,nt3b,np3b,nc3b,
     *it1a(2),ip1a(2),ic1a(maxorbcas),it1b(2),ip1b(2),ic1b(maxorbcas),
     *it2a(2),ip2a(2),ic2a(maxorbcas),it2b(2),ip2b(2),ic2b(maxorbcas),
     *it3a(2),ip3a(2),ic3a(maxorbcas),it3b(2),ip3b(2),ic3b(maxorbcas)
      common /sy/ isint1,isint2,
     *isy1ta,isy1tb,isy1pa,isy1pb,isy1ca,isy1cb,
     *isy2ta,isy2tb,isy2pa,isy2pb,isy2ca,isy2cb
      common/rap/iadrp1(idirap),iadrp2(idirap)
     *,idebp(9),ifinp(9),mmax_p(2,idirap),isgnp(idirap),msyp(idirap)
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common /ctg/icateg(-2:2,maxsym,-2:2,41)
     *,niit(0:2,maxsym,-1:1)
      common/opt/ihab,calcul
      character*3 calcul
      dimension nst1a(2),nst1b(2)
      dimension it13(2)
      common/cd4/ncda,ncdb,ntda,ntdb,indp,isgn1tb,nt13,nt23
     *,np13,np23
     *,iadrt1,iadrt2,ist13,ist23,ispt1,ispt2,yt2p21,yt2p22,ys
     *,ytp31,ytp32,ytp21,ytp22
      common/mr4/ niit1,niit2,np123(idirap)
      common/test/itest(100)
      dimension iadrc1(idirac),iadrc2(idirac)
     *,melc(2,idirac),mscas(2,idirac),mspc1(2,idirac)
     *,idebc(25),ifinc(25),isyc(idirac)
      dimension hii(iadri)
      yw=.false.
      yw1=.false.
c     yw=(ip1b(1).eq.5.and.ip1b(2).eq.9).and.
c    *   (ip2b(1).eq.6.and.ip2b(2).eq.10)
c      write(6,*)'entree sc04'
c     call wrchy(ysgn)
      ncda=noac-nc1a-nc2a
      ncdb=noac-nc1b-nc2b
c
c----------------------------------------------------------------
c     on calcule les adresses des differents CAS possibles
      call sc04c
     *(iadrc1,iadrc2,melc,mscas,mspc1,idebc,ifinc,isyc)
      call sc04p
CYW      if(yw)write(6,*)'idebc',idebc
CYW      if(yw)write(6,*)'ifinc',ifinc
c----------------------------------------------------------------
c
c
c----------------------------------------------------------------
c     on rajoute des trous alpha
c----------------------------------------------------------------
c
      ntda=ninac-nt1a-nt2a
      ntdb=ninac-nt1b-nt2b
c     write(6,*)'ninac,nt1a,nt2a,ntda',ninac,nt1a,nt2a,ntda
c     write(6,*)'ninac,nt1b,nt2b,ntdb',ninac,nt1b,nt2b,ntdb
c     write(6,*)'nvirt,np1a,np2a,npda',nvirt,np1a,np2a,npda
c     write(6,*)'nvirt,np1b,np2b,npdb',nvirt,np1b,np2b,npdb
      maxt3a=2-max0(nt1,nt2)
      if(itest(11).eq.1) maxt3a=2-nt1
      do 3 nt3a=0,maxt3a
      if(yw)write(6,*)'sc04 nt3a',nt3a
      if(nt3a.gt.ntda) goto 3
      call combi0(nst1a,ntda,nt3a,ireta)
      goto 24
 4    call combi2(nst1a,ntda,nt3a,ireta)
c        numeros des trous rajoutes
 24   continue
      isy1ta=isint1
c        isgn=1
      do i=1,nt3a
         it3a(i)=numta(nst1a(i))
         isy1ta=its(isy1ta,itsym(it3a(i)))
c           isgn=isgn*ksgn((it3a(i)))
      enddo
      call union(nta13,nt1a,nt3a,it13,it1a,it3a)
      nta23=nt2a+nt3a
c        isgn1ta=isgn
c
c----------------------------------------------------------------
c     on rajoute des trous beta
c----------------------------------------------------------------
c
      maxt3b=2-max0(nt1+nt3a,nt2+nt3a)
      if(itest(11).eq.1) maxt3b=2-(nt1+nt3a)
      do 5 nt3b=0,maxt3b
      if(yw)write(6,*)'sc04 nt3b,ntdb',nt3b,ntdb
      if(nt3b.gt.ntdb) goto 5
      call combi0(nst1b,ntdb,nt3b,iretb)
      goto 26
 6    call combi2(nst1b,ntdb,nt3b,iretb)
c           numeros des trous rajoutes
 26   continue
CYW            if(yw)write(6,*)'iretb',iretb,(nst1b(k),k=1,nt3b)
      isy1tb=isy1ta
c           isgn=isgn1ta
      do i=1,nt3b
         it3b(i)=numtb(nst1b(i))
         isy1tb=its(isy1tb,itsym(it3b(i)))
c              isgn=isgn*ksgn((norb+it3b(i)))
      enddo
      ntb13=0
      if(nta13.ne.2) then
         call union(ntb13,nt1b,nt3b,it13(nta13+1),it1b,it3b)
      endif
      ispt23=nt2a+nt3a-nt2b-nt3b
      ispt13=nt1a+nt3a-nt1b-nt3b
      nt13=nta13+ntb13
      ntb23=nt2b+nt3b
      nt23=nta23+ntb23
CYW            if(yw)write(6,*)'nt13,nt23',nt13,nt23
c           isgn1tb=isgn
CYW      if(yw)write(6,*)'ispt13,ispt23',ispt13,ispt23
      ist13=1
      ispt1=ispt13
      if(nt13.eq.1)then
         ist13=itsym(iorb(it13(1)))
      else
         if(nt13.eq.2)then
            ist13=its(itsym(iorb(it13(1))),itsym(iorb(it13(2))))
            ispt1=ispt13/nt13
         endif
      endif
      call adrt(nt13,it13,ispt13,iadrt1)
      if(gener.eq.'MR') then
c        print*,'nt13,ist13,ispt13',nt13,ist13,ispt13
c        print*,'nt23,ist23,ispt23',nt23,ist23,ispt23
         niit1=niit(nt13,ist13,ksp(ispt13))
         niit2=niit(nt23,ist23,ksp(ispt23))
      endif
CYW      if(yw)write(6,*)'ispt1,nt23,iadrt1',ispt1,nt23,iadrt1
      npda=nvirt-np1a-np2a
      npdb=nvirt-np1b-np2b
c
c----------------------------------------------------------------
c     on rajoute des particules alpha
c----------------------------------------------------------------
c
      maxp3a=2-max0(np1,np2)
      if(itest(11).eq.1) maxp3a=2-np1
      do 7 np3a=0,maxp3a
c       write(6,*)'nt3a,np3a',nt3a,np3a
      if(yw)write(6,*)'sc04 np3a,npda',np3a,npda
      if(np3a.gt.npda) goto 7
c       write(6,*)'1np3a',np3a
      nc3a=nca0+nt3a+nt1a-np1a-np3a-nc1a
c       write(6,*)'nc3a,ncda',nc3a,ncda,nc1a,nc2a
      if(nc3a.gt.ncda) goto 7
c       write(6,*)'2np3a',np3a
      if(nc3a.lt.0) goto 7
c       write(6,*)'3np3a',np3a
c              on verifie qu'il n'y a pas trop d'el alpha
      if(nc1a+np1a+np3a-nt1a-nt3a.gt.noca-ninac) goto 7
c       write(6,*)'4np3a',np3a
c???           if(nc2a+np2a+np3a-nt2a-nt3a.gt.noca-ninac) goto 7
c
c----------------------------------------------------------------
c     on rajoute des particules beta
c----------------------------------------------------------------
c
      maxp3b=2-max0(np1+np3a,np2+np3a)
      if(itest(11).eq.1) maxp3b=2-(np1+np3a)
      do 9 np3b=0,maxp3b
      if(yw)write(6,*)'sc04 np3b',np3b
      if(np3b.gt.npdb) goto 9
      nc3b=ncb0+nt3b+nt1b-np1b-np3b-nc1b
c                 on verifie qu'il n'y a pas trop d'el beta
      if(nc1b+np1b+np3b-nt1b-nt3b.gt.nocb-ninac) goto 9
c???              if(nc2b+np2b+np3b-nt2b-nt3b.gt.nocb-ninac) goto 9
      np13=np1a+np1b+np3a+np3b
      np23=np2a+np2b+np3a+np3b
      yt2p21=np13.eq.2.and.nt13.eq.2
      yt2p22=np23.eq.2.and.nt23.eq.2
      ytp21=nt13.gt.1.or.np13.gt.1
      ytp22=nt23.gt.1.or.np23.gt.1
      ys=nt23.le.2.and.np23.le.2
c                 le determinant 1 doit appartenir a S
c                 le determinant 2 ne doit pas appartenir a S
      if(gener.eq.'TOUS') then
         if(yt2p22) goto 9
      endif
      if(gener.eq.'PERT'.or.gener.eq.'MR') then
         if(yt2p21) then
            if(nc1a+nc3a.ne.nca0) goto 9
            if(nc1b+nc3b.ne.ncb0) goto 9
         endif
         if(yt2p22) then
            if(nc2a+nc3a.ne.nca0) ys=.false.
            if(nc2b+nc3b.ne.ncb0) ys=.false.
c           ys=.false. : on est deja sur que le det
c           n'appartient pas a S
         endif
      endif
      if(gener.eq.'DDCI') then
         if(np13+nt13.gt.3) goto 9
         if(np23+nt23.le.3) goto 9
      else if(gener.eq.'DDC2') then
         if(np13+nt13.gt.2) goto 9
         if(np23+nt23.le.2) goto 9
      else if(ygmono) then
         if(nt13.gt.1.or.np13.gt.1) goto 9
         if(nt13.le.1.and.np13.le.1) goto 9
      endif
      if(gener.eq.'PERT'.or.gener.eq.'DDci'
     *.or.ygmono.or.gener.eq.'MR') then
         if(iabs(nc1a+nc3a-nc1b-nc3b-nca0+ncb0).gt.2) goto 9
         if(iabs(nc2a+nc3a-nc2b-nc3b-nca0+ncb0).gt.2)
     *   ys=.false.
      endif
      if(nc3b.gt.ncdb) goto 9
      if(nc3b.lt.0) goto 9
      if(ys.and..not.yt2p22) goto 9
c
c----------------------------------------------------------------
c     boucles sur les differentes combinaisons
c----------------------------------------------------------------
c
      indp=np3b+1+3*(np3a)
CYW                  if(yw)write(6,*)'indp,idebp(indp),ifinp(indp)'
CYW     *            ,indp,idebp(indp),ifinp(indp)
CYW                  if(yw)write(6,'('' ys'',l2)') ys
      call sc04i(hii,dum
     *,iadrc1,iadrc2,melc,mscas,mspc1,idebc,ifinc,isyc)
 9    continue
 7    continue
CYW            if(yw)write(6,*)'iretb',iretb
      if(iretb.eq.0) goto 6
 5    continue
CYW         if(yw)write(6,*)'ireta',ireta
      if(ireta.eq.0) goto 4
 3    continue
      return
      end
