      subroutine sc04i(hii,dum
     *,iadrc1,iadrc2,melc,mscas,mspc1,idebc,ifinc,isyc)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      parameter(idirac=15000,idicmr=35000,idirap=maxorb*maxorb)
      common/dim/iadri ; integer(8) iadri
c
c      common/ver2/iadrver(500)
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/mr3/ maxcmr(-2:2,maxsym,-2:2),mixtpmr(idicmr)
     *,ndetc,ndetc0,iadrc_mr(idicmr)
      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 iadrc1(idirac),iadrc2(idirac)
     *,melc(2,idirac),mscas(2,idirac),mspc1(2,idirac)
     *,idebc(25),ifinc(25),isyc(idirac)
      common/opt/ihab,calcul
      character*3 calcul
      dimension hii(iadri)
      common/mr4/ niit1,niit2,np123(idirap)
      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/mxdetc/maxc(-2:2,maxsym,-2:2),
     *maxca(-2:2,maxsym,maxsym,-2:2)
      common /ctg/icateg(-2:2,maxsym,-2:2,41)
     *,niit(0:2,maxsym,-1:1)
      common/test/itest(100)
      common/scbid/in,jn,kn,ln
      common /ctg_mr/icateg_mr(idicmr,41)
      common /icd1/ispin(2)
      yw=.false.
      yw1=.false.
CYW      if(yw)write(6,*)'sc04i ispin',ispin
      do 11 imup=idebp(indp)+1,ifinp(indp)
      isyp=its(msyp(imup),isy1tb)
CYW               if(yw)write(6,*)'isyp',isyp
c
c----------------------------------------------------------------
c     on rajoute des electrons au CAS
c----------------------------------------------------------------
c
CYW                  if(yw)write(6,*)'raj el au CAS'
CYW                  if(yw)write(75,*)'nca0,nt3a,nt1a,np3a,np1a,nc1a','$
CYW               if(yw)call scril
CYW                  if(yw)write(75,*)nca0,nt3a,nt1a,np3a,np1a,nc1a,'$'
CYW               if(yw)call scril
CYW                  if(yw)write(75,*)'ncb0,nt3b,nt1b,np1b,np3b,nc1b','$
CYW               if(yw)call scril
CYW                  if(yw)write(75,*)ncb0,nt3b,nt1b,np1b,np3b,nc1b,'$'
CYW               if(yw)call scril
c                 (rem : on a nt1a-np1a-nc1a=nt2a-np2a-nc1a)
      kc3a=nt3a-np3a+3
      kc3b=nt3b-np3b+3
      indc=kc3b+5*(kc3a-1)
CYW                  if(yw)write(6,*)'nc1a,nc3a,nca0',nc1a,nc3a,nca0
CYW                  if(yw)write(6,*)'nc2a,nc3a,nca0',nc2a,nc3a,nca0
CYW                  if(yw)write(6,*)'nc1b,nc3b,ncb0',nc1b,nc3b,ncb0
CYW                  if(yw)write(6,*)'nc2b,nc3b,ncb0',nc2b,nc3b,ncb0
CYW                  if(yw)write(6,*)'ncda,ncdb',ncda,ncdb
CYW                  if(yw)write(6,*)'sc04 nc3a',nc3a
CYW                  if(yw)write(6,*)'sc04 nc3b',nc3b
CYW                  if(yw)write(6,*)'indc,idebc(indc),ifinc(indc)',
CYW     *            indc,idebc(indc),ifinc(indc)
      do 13 imuc=idebc(indc)+1,ifinc(indc)
CYW                     if(yw)write(6,*)'imup,imuc',imup,imuc
      if(its(isyc(imuc),isyp).ne.is0) goto 13
      if(gener.eq.'PERT'.or.gener.eq.'MR') then
         if(yt2p21) then
            if(mscas(1,imuc).ne.is0) goto 13
         endif
         if(yt2p22) then
            if(iadrc2(imuc).ne.-1.and.
     *      mscas(2,imuc).eq.is0.and.ys) goto 13
         endif
      endif
      if(gener.eq.'MR') then
         iadrcas1=iadrc1(imuc)
         call callim(mixtpmr(iadrcas1),maxt1,maxp1,
     *   mint1,minp1)
c        print*,'iadrcas1',iadrcas1,maxt1,maxp1,mint1,minp1
c        print*,'nt13,np13',nt13,np13
         if(nt13.gt.maxt1.or.nt13.lt.mint1) goto 13
         if(np13.gt.maxp1.or.np13.lt.minp1) goto 13
         iadrcas2=iadrc2(imuc)
         if(iadrcas2.ne.-1) then
            call callim(mixtpmr(iadrcas2),maxt2,maxp2,
     *      mint2,minp2)
c           print*,'iadrcas2',iadrcas2,maxt2,maxp2,mint2,minp2
c           print*,'nt23,np23',nt23,np23
            if(nt23.le.maxt2.and.nt23.ge.mint2) goto 13
            if(np23.le.maxp2.and.np23.ge.minp2) goto 13
         endif
      endif
CYW      if(yw)write(6,*)'adresses cpt1',
CYW     *iadrc1(imuc),iadrp1(imup),iadrt1
      if(gener.eq.'MR') then
         iadr1=icateg_mr(iadrcas1,niit1)+
     *   (iadrp1(imup)-1)+(iadrt1-1)*mmax_p(1,imup)+1
      else
         nelc=melc(1,imuc)
         iscas=mscas(1,imuc)
         ispc1=mspc1(1,imuc)
         iadrcat=iadrc1(imuc)
     *   +maxc(nelc,iscas,ispc1)
     *   *((iadrp1(imup)-1)+(iadrt1-1)*mmax_p(1,imup))
         iadr1=iadrcat
     *   +icateg(nelc,iscas,ispc1,niit(nt13,ist13,ispt1))
      endif
CYW      if(yw)write(6,*)
CYW     *'nelc,iscas,ispc1,nt13,ist13,ispt1,icateg',
CYW     *nelc,iscas,ispc1,nt13,ist13,ispt1,icateg(
CYW     *nelc,iscas,ispc1,niit(nt13,ist13,ispt1))
CYW      if(yw)write(6,*)'nelc,iscas,ispc1,maxc',
CYW     *maxc(nelc,iscas,ispc1)
CYW      if(yw)write(6,*)'adresses cpt2',
CYW     *iadrc2(imuc),iadrp2(imup),iadrt2
c     if(gener.eq.'PERT'.and.iadr1.eq.35)print*,'dumxx',dum,hii(iadr1)
c     if(gener.eq.'MR'.and.iadr1.eq.11)print*,'dumxx',dum,hii(iadr1)
c     *,iadrcas1
      hii(iadr1)=hii(iadr1)+dum
c
cnnnn                     if(iadr1.eq.4)call scril
cnnnn                     if(iadr1.eq.4)write(6,'(a20,2f15.8)')'nnnn'
cnnnn     *              ,dum,hii(iadr1)
c
CYW                  if(yw) then
CYW                     write(75,*)'habillage det',iadr1,dum,'$'
CYW                     call scril
CYW                     if(iadr1.eq.42.or.iadr1.eq.50) write(6,'(a10,
CYW  *                  i6,f12.8,6i3)')'contrib',iadr1,dum,in,jn,kn,ln
CYW  *                  ,ispin
CYW                  endif
 13   continue
 11   continue
      return
      end
