      subroutine sc04p
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      parameter(idirap=maxorb*maxorb)
      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)
      dimension nsp1a(2),nsp1b(2)
      dimension ip13(2)
      yw=.false.
      yw1=.false.
c
c----------------------------------------------------------------
c     on rajoute des particules alpha
c----------------------------------------------------------------
c
      imup=0
      npda=nvirt-np1a-np2a
      npdb=nvirt-np1b-np2b
      do 7 np3a=0,2-np1
CYW               if(yw)write(6,*)'sc04 np3a,npda',np3a,npda
      if(np3a.gt.npda) goto 7
c
c----------------------------------------------------------------
c     on rajoute des particules beta
c----------------------------------------------------------------
c
      do 9 np3b=0,2-(np1+np3a)
      indp=np3b+1+3*(np3a)
      idebp(indp)=imup
CYW                  if(yw)write(6,*)'sc04 np3b',np3b
      if(np3b.gt.npdb) goto 9
      call combi0(nsp1a,npda,np3a,irepa)
      goto 28
 8    call combi2(nsp1a,npda,np3a,irepa)
c                 write(6,*)'nsp1a',(nsp1a(k),k=1,np3a)
c              numeros des part rajoutees
 28   continue
CYW               if(yw)write(6,*)'nsp1a',(nsp1a(k),k=1,np3a)
      isy1pa=1
      isgn=1
      do i=1,np3a
         ip3a(i)=numpa(nsp1a(i))
         isy1pa=its(isy1pa,itsym(ip3a(i)))
         isgn=isgn*ksgn((ip3a(i)))
      enddo
      call union(npa13,np1a,np3a,ip13,ip1a,ip3a)
      call reor(npa13,ip13,idum)
cs               call union(npa23,np2a,np3a,ip23,ip2a,ip3a)
      npa23=np2a+np3a
cs               call reor(npa23,ip23,idum)
CYWc              if(yw)write(6,*)'npa13,npa23',npa13,'  ',npa23
c              write(6,*)'ip13,ip23',ip13,'  ',ip23
cs               isgn1pa=isgn
      call combi0(nsp1b,npdb,np3b,irepb)
c                 write(6,*)'nsp1b',(nsp1b(k),k=1,np3b)
      goto 30
 10   call combi2(nsp1b,npdb,np3b,irepb)
c                 write(6,*)'nsp1b',(nsp1b(k),k=1,np3b)
 30   continue
      isy1pb=isy1pa
cs                  isgn=isgn1pa
      do i=1,np3b
c                    write(6,*)'numpb(nsp1b(i))',numpb(nsp1b(i))
         ip3b(i)=numpb(nsp1b(i))
c                    write(6,*)'i,ip3b(i)',i,ip3b(i)
c                    write(6,*)'itsym(ip3b(i))',itsym(ip3b(i))
         isy1pb=its(isy1pb,itsym(ip3b(i)))
      enddo
      npb13=0
      if(npa13.ne.2) then
         call union(npb13,np1b,np3b,ip13(npa13+1),ip1b,ip3b)
         call reor(npb13,ip13(npa13+1),idum)
      endif
      npb23=0
cs                  if(npa23.ne.2) then
cs                     call union(npb23,np2b,np3b,ip23(npa23+1),ip2b,ip3
cs                     call reor(npb23,ip23(npa23+1),idum)
cs                  endif
      npb23=np2b+np3b
CYW                  if(yw)write(6,*)'npb13,npb23',npb13,'  ',npb23
CYW                  if(yw)write(6,*)'ip13',ip13
      ispp13=np1a+np3a-np1b-np3b
      np13=npa13+npb13
      ispp23=np2a+np3a-np2b-np3b
      np23=npa23+npb23
c-----------------------------------------------
c     on stocke les adresses
c-----------------------------------------------
      imup=imup+1
      if(imup.gt.idirap) goto 3
      isgnp(imup)=isgn
      msyp(imup)=isy1pb
CYW                  if(yw)write(6,*)'np13,ip13,ispp13,iadrp1(imup),imup
CYW     *            ,np13,ip13,ispp13,iadrp1(imup),imup
      call adrp(np13,ip13,ispp13,iadrp1(imup))
CYW                  if(yw)write(6,*)'np13,ip13,ispp13,iadrp1(imup),imup
CYW     *            ,np13,ip13,ispp13,iadrp1(imup),imup
cs                  call adrp(np23,ip23,ispp23,iadrp2(imup))
CYWcs                  if(yw)write(6,*)'np23,ip23,ispp23,iadrp2(imup)'
cs     *            ,np23,ip23,ispp23,iadrp2(imup),imup
      call calmpp(mmax_p(1,imup),np13,ip13,ispp13)
cs                  call calmpp(mmax_p(2,imup),np23,ip23,ispp23)
CYW                  if(yw)write(6,*)'irepb',irepb
      ifinp(indp)=imup
CYW                  if(yw)
CYW     *            write(6,*)'np3a,np3b,imup,idebp(indp),ifinp(indp)',
CYW     *            np3a,np3b,imup,idebp(indp),ifinp(indp)
 3    continue
      if(irepb.eq.0) goto 10
CYW               if(yw)write(6,*)'irepa',irepa
      if(irepa.eq.0) goto 8
 9    continue
 7    continue
CYW      if(yw)write(6,*)'ifinp',ifinp
CYW      if(yw)write(6,*)'idebp',idebp
      if(imup.gt.idirap) then
         write(6,*)'imup trop grand   imup,idirap',imup,idirap
         write(6,*)'augmenter idirap'
         stop
      endif
      return
      end
