      subroutine c_hab(ne,it,ip,nt,np,dum,it4,ip4,nocz,nvz,
     *sttvpp,stvpp,sttvp,stvp,sttv,stv,sttppv,
     *sttpv,stppv,stpv,sppv,spv,stvtvpp,stvtvp,stvtv,sttpvpv,stpvpv,
     *spvpv,sttvppv,sttvpv,stvppv,stvpv,stvtvppv,stvtvpv,sttvpvpv,
     *stvpvpv,stvtvpvpv)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (nexci=2,ngru3=2048)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      dimension it4(2),ip4(2)
      dimension it(2),ip(2)
c      dimension ecp(nvz),ect(nocz)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      common /cstes_hab/sttpp,sttp,stt,stpp,stp,st,spp,sp
      real*4 sttvpp(nocz),stvpp(nocz),sttvp(nocz),
     *stvp(nocz),sttv(nocz),stv(nocz),sttppv(nvz),sttpv(nvz),
     *stppv(nvz),stpv(nvz),sppv(nvz),spv(nvz)
      real*4 stvtvpp(nocz,nocz),stvtvp(nocz,nocz),
     *stvtv(nocz,nocz),
     *sttpvpv(nvz,nvz),stpvpv(nvz,nvz),spvpv(nvz,nvz),
     *sttvppv(nocz,nvz),sttvpv(nocz,nvz),stvppv(nocz,nvz),
     *stvpv(nocz,nvz)
      real*4 stvtvppv(nocz,nocz,nvz),
     *stvtvpv(nocz,nocz,nvz),
     *sttvpvpv(nocz,nvz,nvz),stvpvpv(nocz,nvz,nvz)
      real*4 stvtvpvpv(ii28)
c      real*4 stvtvpvpv(nocz*(nocz+1)/2,nv2*(nv2+1)/2)
c      real*4 stvtvpvpv(nocz,nocz,nvz,nvz)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/l40/ hmono(maxorb*(maxorb+1)/2),aj(maxorb*(maxorb+1)/2)
     *,ak(maxorb*(maxorb+1)/2),f(maxorb*(maxorb+1)/2),e0
     *,ajk(maxorb*(maxorb+1)/2),escf
      yw=.false.
c      write(6,'('' it,ip,it4,ip4 '',4i3,2x,4i3)')it,ip,it4,ip4
c
      if(nt.eq.0.and.np.eq.0) return
c--   calcul stvtvpvpv
      jt1=it4(1)
      jt2=it4(2)
      jp1=ip4(1)
      jp2=ip4(2)
      if(jt1.le.noca.and.jt2.le.noca) then
c        D+ tout alpha
         it1=max0(jt1,jt2)
         it2=min0(jt1,jt2)
         ip1=max0(jp1,jp2)
         ip2=min0(jp1,jp2)
c        print*,'1it1,it2,ip1,ip2',it1,it2,ip1,ip2
         itp=(it1-2)*(it1-1)/2+it2+(noca*(noca-1)/2)*
     *   ((ip1-2)*(ip1-1)/2+ip2-1)
      else if(jt1.gt.noca.and.jt2.gt.noca) then
c        D+ tout beta
         it1=max0(jt1,jt2)-noca
         it2=min0(jt1,jt2)-noca
         ip1=max0(jp1,jp2)-nv2
         ip2=min0(jp1,jp2)-nv2
c        print*,'2it1,it2,ip1,ip2',it1,it2,ip1,ip2
         itp=(it1-2)*(it1-1)/2+it2+(nocb*(nocb-1)/2)*
     *   ((ip1-2)*(ip1-1)/2+ip2-1)+itptp2
      else
c        D+ de spins differents
         jt1=it(1)
         jt2=it(2)-noca
         jp1=ip(1)
         jp2=ip(2)-nv2
c        print*,'3it1,it2,ip1,ip2',jt1,jt2,jp1,jp2
         itp=jt1+(jt2-1)*noca+(jp1-1)*noca*nocb+(jp2-1)*noca*nocb*nv2
     *   +itptp1
      endif
      goto 2000
 
 
 
 
 
      it1=max0(it4(1),it4(2))
      it2=min0(it4(1),it4(2))
      ip1=max0(ip4(1),ip4(2))
      ip2=min0(ip4(1),ip4(2))
      nv2b=norb-nocb
      if(it1.gt.noca) then
         it1=it1-noca
         ip1=ip1-nv2
         if(it2.gt.noca) then
            it2=it2-noca
            ip2=ip2-nv2
            itp=(it1-2)*(it1-1)/2+it2+(nocb*(nocb-1)/2)*
     *      ((ip1-2)*(ip1-1)/2+ip2-1)
     *      +itptp2
         else
            it1=it4(1)
            it2=it4(2)
            ip1=ip4(1)
            ip2=ip4(2)
c       print*,'1it1,it2,ip1,ip2',it1,it2,ip1,ip2
            if(it1.gt.noca) it1=it1-noca
            if(it2.gt.noca) it2=it2-noca
            if(ip1.gt.nv2) ip1=ip1-nv2
            if(ip2.gt.nv2) ip2=ip2-nv2
            if(it2.le.0.or.ip2.le.0) stop
c       print*,'2it1,it2,ip1,ip2',it1,it2,ip1,ip2
            itp=it1+(it2-1)*noca+(ip1-1)*noca*nocb+(ip2-1)*noca*nocb*nv2
     *      +itptp1
         endif
      else
         itp=(it1-2)*(it1-1)/2+it2+(noca*(noca-1)/2)*
     *   ((ip1-2)*(ip1-1)/2+ip2-1)
      endif
 
 
 
 2000 continue
 
c     itt=it1*(it1-1)/2+it2
c     ipp=ip1*(ip1-1)/2+ip2
c     stvtvpvpv(itt,ipp)=dum
c      write(6,'(a15,i3,2f12.8)')'calc stvtvpvpv',
c     *itp,dum
      stvtvpvpv(itp)=dum
c     *  stvtvpvpv(it4(1),it4(2),ip4(1),ip4(2))+dum
c      write(6,'(a15,i3,2f12.8)')'calc stvtvpvpv',
c     *itp,dum,stvtvpvpv(itp)
c
c      print*,'c_hab  nt,np',nt,np
      if(nt.eq.2)then
         if(np.eq.2)then
c******* nt=2 np=2
c ------ cstes
            sttpp=sttpp+dum
c        print*,'hhab sttpp',sttpp,dum
c ------ epv : 1 dimension : 1t ou 1p varie
c ------ epv : 2 dimensions: 2t ou 2p ou 1t/1p varient
c ------ epv : 3 dimensions: 2t/1p ou 1t/2p varient
c ------ epv : 4 dimensions: 2t/2p varient
            do k=1,nt
               sttvpp(it4(k))=sttvpp(it4(k))+dum
               do k2=1,np
                  sttvppv(it4(k),ip4(k2))=sttvppv(it4(k),ip4(k2))+dum
               enddo
               sttvpvpv(it4(k),ip4(1),ip4(2))=sttvpvpv(it4(k),ip4(1),ip4
     &         (2))
     *         +dum
            enddo
c
            do k=1,np
               sttppv(ip4(k))=sttppv(ip4(k))+dum
c        print*,'hhab sttppv',ip4(k),sttppv(ip4(k)),dum
c   if(yw)write(6,*)'it,ip,sttppv(',ip4(k),')',it,ip,dum
               if(yw) then
                  if(ip4(k).eq.1)
     *            write(6,'('' 1 it,ip,sttppv '',4i3,f10.6)') it,ip,dum
                  if(ip4(k).eq.10)
     *            write(6,'('' 10 it,ip,sttppv '',4i3,f10.6)') it,ip,dum
c       if(yw)write(6,'(''hoi,ci'',2f10.6)') hoi(i),c(i)
               endif
               stvtvppv(it4(1),it4(2),ip4(k))=stvtvppv(it4(1),it4(2),ip4
     &         (k))
     *         +dum
            enddo
c
            stvtvpp(it4(1),it4(2))=stvtvpp(it4(1),it4(2))+dum
c
            sttpvpv(ip4(1),ip4(2))=sttpvpv(ip4(1),ip4(2))+dum
c
c
c
c******* nt=2 np=1
         else if(np.eq.1)then
c ------ epv : 1 dimension : 1t ou 1p
c ------ epv : 2 dimensions: 2t ou 1t/1p
c ------ epv : 3 dimensions: 2t/1p
c ------ cstes
            sttp=sttp+dum
c --- + CAS
            sttppv(ip4(2))=sttppv(ip4(2))+dum
c        print*,'hhab sttppv',ip4(2),sttppv(ip4(2)),dum
c            ecp(ip4(2))=ecp(ip4(2))+dum
            if(yw) then
               if(ip4(2).eq.1)
     *         write(6,'('' 1 C it,ip,sttppv '',4i3,f10.6)') it,ip,dum
               if(ip4(2).eq.10)
     *         write(6,'('' 10 C it,ip,sttppv '',4i3,f10.6)') it,ip,dum
c      if(yw)write(6,*)'it,ip,sttppv:ecp(',ip4(2),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
            endif
c
            do k=1,nt
               sttvp(it4(k))=sttvp(it4(k))+dum
               sttvpv(it4(k),ip4(1))=sttvpv(it4(k),ip4(1))+dum
c --- + CAS
               sttvppv(it4(k),ip4(2))=sttvppv(it4(k),ip4(2))+dum
               sttvpvpv(it4(k),ip4(1),ip4(2))=sttvpvpv(it4(k),ip4(1),ip4
     &         (2))
     *         +dum
            enddo
c
            stvtvp(it4(1),it4(2))=stvtvp(it4(1),it4(2))+dum
c --- + CAS
            stvtvppv(it4(1),it4(2),ip4(2))=stvtvppv(it4(1),it4(2),ip4(2)
     &      )
     *      +dum
c
            sttpv(ip4(1))=sttpv(ip4(1))+dum
c      if(yw)write(6,*)'it,ip,sttpv(',ip4(1),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
c --- + CAS
            sttpvpv(ip4(1),ip4(2))=sttpvpv(ip4(1),ip4(2))+dum
            stvtvpv(it4(1),it4(2),ip4(1))=stvtvpv(it4(1),it4(2),ip4(1))
     *      +dum
c       write(6,'('' 1stvtvpv'',3i4,2f12.8)')it4(1),it4(2),ip4(1),
c       *stvtvpv(it4(1),it4(2),ip4(1)),dum
c
c
c******* nt=2 np=0
         else if(np.eq.0)then
c ------ epv : 1 dimension : 1t
c ------ epv : 2 dimensions: 2t
c ------ cstes
            stt=stt+dum
c --- + CAS
            sttpv(ip4(1))=sttpv(ip4(1))+dum
c            ecp(ip4(1))=ecp(ip4(1))+dum
c            if(yw)write(6,*)'it,ip,sttpv:ecp(',ip4(1),')',it,ip,dum
c      if(yw)write(6,*)'it,ip,sttpv(',ip4(1),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
            sttpv(ip4(2))=sttpv(ip4(2))+dum
c            ecp(ip4(2))=ecp(ip4(2))+dum
c            if(yw)write(6,*)'it,ip,sttpv:ecp(',ip4(2),')',it,ip,dum
c      if(yw)write(6,*)'it,ip,sttpv(',ip4(2),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
            sttpvpv(ip4(1),ip4(2))=sttpvpv(ip4(1),ip4(2))+dum
c ---
c
            do k=1,nt
               sttv(it4(k))=sttv(it4(k))+dum
c --- + CAS
               do k2=1,2
                  sttvpv(it4(k),ip4(k2))=sttvpv(it4(k),ip4(k2))+dum
               enddo
               sttvpvpv(it4(k),ip4(1),ip4(2))=sttvpvpv(it4(k),ip4(1),ip4
     &         (2))
     *         +dum
c ---
            enddo
            stvtv(it4(1),it4(2))=stvtv(it4(1),it4(2))+dum
c --- + CAS
            do k=1,2
               stvtvpv(it4(1),it4(2),ip4(k))=stvtvpv(it4(1),it4(2),ip4(k
     &         ))+dum
c       write(6,'('' 2stvtvpv'',3i4,2f12.8)')it4(1),it4(2),ip4(k),
c       *stvtvpv(it4(1),it4(2),ip4(k)),dum
            enddo
c ---
         endif
c
c
c******* nt=1 np=2
      else if(nt.eq.1)then
         if(np.eq.2)then
c ------ epv : 1 dimension : 1t ou 1p
c ------ epv : 2 dimensions: 2p ou 1t/1p
c ------ epv : 3 dimensions: 1t/2p
c ------ cstes
            stpp=stpp+dum
c ---    + CAS
            sttvpp(it4(2))=sttvpp(it4(2))+dum
c            ect(it4(2))=ect(it4(2))+dum
c            if(yw)write(6,*)'it,ip,sttvpp:ect(',it4(2),')',it,ip,dum
c ---
            do k=1,np
               stppv(ip4(k))=stppv(ip4(k))+dum
c        if(yw)write(6,*)'it,ip,stppv(',ip4(k),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
               stvppv(it4(1),ip4(k))=stvppv(it4(1),ip4(k))+dum
c ---      + CAS
               sttvppv(it4(2),ip4(k))=sttvppv(it4(2),ip4(k))+dum
               stvtvppv(it4(1),it4(2),ip4(k))=stvtvppv(it4(1),it4(2),ip4
     &         (k))
     *         +dum
c ---
            enddo
c
            stpvpv(ip4(1),ip4(2))=stpvpv(ip4(1),ip4(2))+dum
            stvpp(it4(1))=stvpp(it4(1))+dum
c ---      + CAS
            sttvpvpv(it4(2),ip4(1),ip4(2))=sttvpvpv(it4(2),ip4(1),ip4(2)
     &      )
     *      +dum
            stvtvpp(it4(1),it4(2))=stvtvpp(it4(1),it4(2))+dum
c ---
            stvpvpv(it4(1),ip4(1),ip4(2))=stvpvpv(it4(1),ip4(1),ip4(2))
     *      +dum
c
c******* nt=1 np=1
         else if(np.eq.1)then
c ------ epv : 1 dimension : 1t ou 1p
c ------ epv : 2 dimensions: 1t/1p
c ------ cstes
            stp=stp+dum
c ---      + CAS
            sttvp(it4(2))=sttvp(it4(2))+dum
c            ect(it4(2))=ect(it4(2))+dum
c            if(yw)write(6,*)'it,ip,sttvp:ect(',it4(2),')',it,ip,dum
            stppv(ip4(2))=stppv(ip4(2))+dum
c            ecp(ip4(2))=ecp(ip4(2))+dum
c            if(yw)write(6,*)'it,ip,stppv:ecp(',ip4(2),')',it,ip,dum
c      if(yw)write(6,*)'it,ip,stppv(',ip4(k),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
            sttvppv(it4(2),ip4(2))=sttvppv(it4(2),ip4(2))+dum
c ---
            stpv(ip4(1))=stpv(ip4(1))+dum
c      if(yw)write(6,*)'it,ip,stpv(',ip4(1),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
            stvp(it4(1))=stvp(it4(1))+dum
            stvpv(it4(1),ip4(1))=stvpv(it4(1),ip4(1))+dum
c ---      + CAS
            stpvpv(ip4(1),ip4(2))=stpvpv(ip4(1),ip4(2))+dum
            stvppv(it4(1),ip4(2))=stvppv(it4(1),ip4(2))+dum
            stvpvpv(it4(1),ip4(1),ip4(2))=stvpvpv(it4(1),ip4(1),ip4(2))+
     &      dum
            sttvpv(it4(2),ip4(1))=sttvpv(it4(2),ip4(1))+dum
            stvtvp(it4(1),it4(2))=stvtvp(it4(1),it4(2))+dum
            stvtvpv(it4(1),it4(2),ip4(1))=stvtvpv(it4(1),it4(2),ip4(1))+
     &      dum
c       write(6,'('' 3stvtvpv'',3i4,2f12.8)')it4(1),it4(2),ip4(1),
c       *stvtvpv(it4(1),it4(2),ip4(1)),dum
            sttvpvpv(it4(2),ip4(1),ip4(2))=sttvpvpv(it4(2),ip4(1),ip4(2)
     &      )
     *      +dum
            stvtvppv(it4(1),it4(2),ip4(2))=stvtvppv(it4(1),it4(2),ip4(2)
     &      )
     *      +dum
c ---
c******* nt=1 np=0
         else if(np.eq.0)then
c ------ epv : 1 dimension : 1t
c ------ cstes
            st=st+dum
c ---      + CAS
            do k=1,ne
               stpv(ip4(k))=stpv(ip4(k))+dum
c               ecp(ip4(k))=ecp(ip4(k))+dum
c               if(yw)write(6,*)'it,ip,sttpv:ecp(',ip4(k),')',it,ip,dum
c        if(yw)write(6,*)'it,ip,stpv(',ip4(k),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
               stvpv(it4(1),ip4(k))=stvpv(it4(1),ip4(k))+dum
               sttvpv(it4(2),ip4(k))=sttvpv(it4(2),ip4(k))+dum
            enddo
            sttv(it4(2))=sttv(it4(2))+dum
c            ect(it4(2))=ect(it4(2))+dum
c            if(yw)write(6,*)'it,ip,sttv:ect(',it4(2),')',it,ip,dum
            stpvpv(ip4(1),ip4(2))=stpvpv(ip4(1),ip4(2))+dum
            sttvpvpv(it4(2),ip4(1),ip4(2))=sttvpvpv(it4(2),ip4(1),ip4(2)
     &      )
     *      +dum
            stvtv(it4(1),it4(2))=stvtv(it4(1),it4(2))+dum
            stvtvpv(it4(1),it4(2),ip4(1))=stvtvpv(it4(1),it4(2),ip4(1))
     *      +dum
c       write(6,'('' 4stvtvpv'',3i4,2f12.8)')it4(1),it4(2),ip4(1),
c       *stvtvpv(it4(1),it4(2),ip4(1)),dum
            stvtvpv(it4(1),it4(2),ip4(2))=stvtvpv(it4(1),it4(2),ip4(2))
     *      +dum
c       write(6,'('' 5stvtvpv'',3i4,2f12.8)')it4(1),it4(2),ip4(2),
c       *stvtvpv(it4(1),it4(2),ip4(2)),dum
            stvpvpv(it4(1),ip4(1),ip4(2))=stvpvpv(it4(1),ip4(1),ip4(2))
     *      +dum
c ---
            stv(it4(1))=stv(it4(1))+dum
c ---
         endif
c******* nt=0 np=2
      else if(nt.eq.0)then
         if(np.eq.2)then
c ------ epv : 1 dimension : 1p
c ------ epv : 2 dimensions: 2p
c ------ cstes
            spp=spp+dum
c ---      + CAS
            stvpp(it4(1))=stvpp(it4(1))+dum
c            ect(it4(1))=ect(it4(1))+dum
c            if(yw)write(6,*)'it,ip,stvpp:ect(',it4(1),')',it,ip,dum
            stvpp(it4(2))=stvpp(it4(2))+dum
c            ect(it4(2))=ect(it4(2))+dum
c            if(yw)write(6,*)'it,ip,stvpp:ect(',it4(2),')',it,ip,dum
            stvtvpp(it4(1),it4(2))=stvtvpp(it4(1),it4(2))+dum
c ---
            do k=1,np
               sppv(ip4(k))=sppv(ip4(k))+dum
c        if(yw)write(6,*)'it,ip,sppv(',ip4(k),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
c ---      + CAS
               stvppv(it4(1),ip4(k))=stvppv(it4(1),ip4(k))+dum
               stvppv(it4(2),ip4(k))=stvppv(it4(2),ip4(k))+dum
               stvtvppv(it4(1),it4(2),ip4(k))=stvtvppv(it4(1),it4(2),ip4
     &         (k))
     *         +dum
c ---
            enddo
            spvpv(ip4(1),ip4(2))=spvpv(ip4(1),ip4(2))+dum
c ---      + CAS
            stvpvpv(it4(1),ip4(1),ip4(2))=stvpvpv(it4(1),ip4(1),ip4(2))+
     &      dum
            stvpvpv(it4(2),ip4(1),ip4(2))=stvpvpv(it4(2),ip4(1),ip4(2))+
     &      dum
c ---
c******* nt=0 np=1
         else if(np.eq.1)then
c ------ epv : 1 dimension : 1p
c ------ cstes
            sp=sp+dum
c ---      + CAS
            sppv(ip4(2))=sppv(ip4(2))+dum
c            ecp(ip4(2))=ecp(ip4(2))+dum
c            if(yw)write(6,*)'it,ip,sppv:ecp(',ip4(2),')',it,ip,dum
c        if(yw)write(6,*)'it,ip,sppv(',ip4(2),')',it,ip,dum
c        if(yw)write(6,'(''it,ip,'',4i3,f10.6)') it,ip,dum
            stvtvp(it4(1),it4(2))=stvtvp(it4(1),it4(2))+dum
            stvtvppv(it4(1),it4(2),ip4(2))=stvtvppv(it4(1),it4(2),ip4(2)
     &      )
     *      +dum
            spvpv(ip4(1),ip4(2))=spvpv(ip4(1),ip4(2))+dum
            stvtvpv(it4(1),it4(2),ip4(1))=stvtvpv(it4(1),it4(2),ip4(1))
     *      +dum
c       write(6,'('' 6stvtvpv'',3i4,2f12.8)')it4(1),it4(2),ip4(1),
c       *stvtvpv(it4(1),it4(2),ip4(1)),dum
            do k=1,ne
               stvp(it4(k))=stvp(it4(k))+dum
c               ect(it4(k))=ect(it4(k))+dum
c               if(yw)write(6,*)'it,ip,stvp:ect(',it4(k),')',it,ip,dum
               stvpv(it4(k),ip4(1))=stvpv(it4(k),ip4(1))+dum
               stvppv(it4(k),ip4(2))=stvppv(it4(k),ip4(2))+dum
               stvpvpv(it4(k),ip4(1),ip4(2))=stvpvpv(it4(k),ip4(1),ip4(2
     &         ))
     *         +dum
            enddo
c ---
            spv(ip4(1))=spv(ip4(1))+dum
         endif
      endif
      return
      end
