      subroutine sc2casnj(iesp2,c,hoi,iesp,yesp,c4,hoi4,ierrdy)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     iesp2     |      hoi      |
c            c
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter (maxda3=300,maxorbcas=16)
      logical*1 bidia
      character*4 hab
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      common /det/ndet,mdet(50),nbdet_cas
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      dimension c(iadri),hoi(iadri)
      real*4 c4(iadri*2),hoi4(iadri*2)
c      equivalence (c4(1),c(1))
c      equivalence (hoi4(1),hoi(1))
      dimension iesp(iadri*2),yesp(*)
c      equivalence (iesp(1),c(1))
c      equivalence (yesp(1),c(1))
      common/opt/ihab,calcul
      common/pr/nprint,mprint(10)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      character*3 calcul
      common/test/itest(100)
      integer*2 iesp2(iadri*8)
      character*1280 namel
      namelist /deth/ith,iph
      yw=.false.
 
      if(yhmono) then
         write(6,*)'           Revestiment ab les MONOS
     &   '
      end if
      write(6,*)' '
      if(yw)write(6,*)'ndet 1',ndet
      nv2=norb-noca
      nv2b=norb-nocb
      norbs=norb*2
      nocas=noca0*2
      nocas=noca+nocb
      nvs=nv2+nv2b
      i2=nocas+1
      i3=i2+nocas
      i4=i3+nocas
      i5=i4+nocas
      i6=i5+nocas
      i7=i6+nocas
      i8=i7+nvs
      i9=i8+nvs
      i10=i9+nvs
      i11=i10+nvs
      i12=i11+nvs
      i13=i12+nvs
      i14=i13+nocas*nocas
      i15=i14+nocas*nocas
      i16=i15+nocas*nocas
      i17=i16+nvs*nvs
      i18=i17+nvs*nvs
      i19=i18+nvs*nvs
      i20=i19+nocas*nvs
      i21=i20+nocas*nvs
      i22=i21+nocas*nvs
      i23=i22+nocas*nvs
      i24=i23+nocas*nocas*nvs
      i25=i24+nocas*nocas*nvs
      i26=i25+nocas*nvs*nvs
      i27=i26+nocas*nvs*nvs
c     i28=i27+nocas*(nocas+1)*nvs*(nvs+1)/4
      ii28=noca*(noca-1)*nv2*(nv2-1)/4
     *+nocb*(nocb-1)*nv2b*(nv2b-1)/4
     *+noca*nocb*nv2*nv2b
c      print*,'noca,nocb,nv2,nv2b,ii28',noca,nocb,nv2,nv2b,ii28
      i28=i27+ii28
      i28=(i28+1)/2
      write(6,*)'dimension tot des tableaux de sc2',i28,'    en R8 :',
     *i28
      if(nprint.ge.2)print*,'ii28',ii28
      if(hab.eq.'SC2') then
         write(6,*)' '
         write(6,*)'   #####   #####   #####     ####     #     ##### '
         write(6,*)'  #     # #     # #     #   #    #   # #   #     #'
         write(6,*)'  #       #             #   #       #   #  #      '
         write(6,*)'   #####  #        ##### -- #      #     #  ##### '
         write(6,*)'        # #       #         #      #######       #'
         write(6,*)'  #     # #     # #         #    # #     # #     #'
         write(6,*)'   #####   #####  #######   #####  #     #  ##### '
         write(6,*)' '
      else if(hab.eq.'ACPF') then
         write(6,*)' '
         write(6,*)'   ##     ####   #####   ######'
         write(6,*)'  #  #   #    #  #    #  #'
         write(6,*)' #    #  #       #    #  #####'
         write(6,*)' ######  #       #####   #'
         write(6,*)' #    #  #    #  #       #'
         write(6,*)' #    #   ####   #       #'
         write(6,*)' '
      else if(hab.eq.'AQCC') then
         write(6,*)''
         write(6,*)'   ##     ####    ####    ####'
         write(6,*)'  #  #   #    #  #    #  #    #'
         write(6,*)' #    #  #    #  #       #'
         write(6,*)' ######  #  # #  #       #'
         write(6,*)' #    #  #   #   #    #  #    #'
         write(6,*)' #    #   ### #   ####    ####'
         write(6,*)''
      endif
      call verdim('depassement sc2    tableaux   iadri    ',i28,iadri)
      itptp1=(noca*(noca-1)/2)*(nv2*(nv2-1)/2)
      itptp2=itptp1+noca*nocb*nv2*nv2b
      conv=10.d0**(-ipresc)
      write(6,*)' *******SC2 maxith',maxith,'       conv',conv,'  ****'
c--   ouverture fichier temporaire pour stocker la 1ere diagonale
      if(yw)print*,'ouverture 29'
      open(29,file='BID29',form='UNFORMATTED')
c
c-----------------------------------------------------------
c                 ihab=2 habillage etat excite
c-----------------------------------------------------------
c
      if(ihab.eq.2) then
         write(6,*)'             ----------------------------'
         write(6,*)'             ihab=2 habillage etat excite'
         write(6,*)'             ----------------------------'
c--      lecture test pour verifier la conformite du fichier sc2ex
         rewind 12
         read(12) ndeth,noac2,nelac2,(ith(k),k=1,noac2)
c        print*,'ndeth,noac2,nelac2,ith',ndeth,noac2,nelac2,ith
         if(noac.ne.noac2) goto 2
         do k=1,noac
            if(ith(k).ne.numac(k)) goto 2
         enddo
         goto 3
 2       write(6,*)'le fichier sc2ex ne correspond pas a ce calcul'
         write(75,*)'dans sc2ex noac=',noac2,' numac=',
     *   (ith(k),k=1,noac2),'$'
         call scril
         write(75,*)'ici  noac=',noac,' numac=',
     *   (numac(k),k=1,noac),'$'
         call scril
         stop
 3       continue
c--      on transfere la diagonale sur file 29
         rewind 25
         call lir8bl(hoi,ndet,25)
         call ecr8bl(hoi,ndet,29)
         if(yw) then
            do k=1,ndet
               write(6,*)'diag0',k,hoi(k)
            enddo
         endif
c--      puis on met la file 25 a zero
         do k=1,ndet
            hoi(k)=0.d0
         enddo
         rewind 25
         call ecr8bl(hoi,ndet,25)
c        appel habillage
         do ideth=1,ndeth
c--         lecture du determinant habilleur
            read(12)neh,(ith(k),k=1,neh),(iph(k),k=1,neh)
            call xc2cicasnj(hoi4,hoi4(i2),hoi4(i3),hoi4(i4),hoi4(i5),
     *      hoi4(i6),hoi4(i7),hoi4(i8),hoi4(i9),hoi4(i10),hoi4(i11),
     *      hoi4(i12),hoi4(i13),hoi4(i14),hoi4(i15),hoi4(i16),hoi4(i17),
     *      hoi4(i18),hoi4(i19),hoi4(i20),hoi4(i21),hoi4(i22),hoi4(i23),
     *      hoi4(i24),hoi4(i25),hoi4(i26),hoi4(i27),nocas,nvs,c)
          print*,'sc2casn appel xc2cicas'
            call xc2cicas(hoi)
         enddo
c
c        la diagonale originale est sur 29
c        les corrections a la diagonale sont sur 25
c--      on fait la somme de 25 et 29 et on stocke sur 25
         call aldobl(c,yesp(iadri*8+1),ndet,25,29)
         if(yw) then
            rewind 25
            call lir8bl(hoi,ndet,25)
            do k=1,ndet
               write(6,*)'diag',k,hoi(k)
            enddo
         endif
         return
      endif
c
c-----------------------------------------------------------
c               fin  ihab=2 habillage etat excite
c
c               habillage ihab=1
c-----------------------------------------------------------
c
c--   lecture de l'energie de depart
      rewind 11
      read(11)nicdi,metat
      read(11) (e0,k=1,ihvec)
      write(6,'('' energie de depart'',f10.6)') e0
c--   on met le vecteur solution precedent en vecteur d'essai
      ifiess=11
      nessai=2
      rewind 11
c
c--   boucle : iteration d'habillage
c
      iprec0=iprec
      do 1 iterh=1,maxith
c--   on remet la precision a la valeur demandee
 1010 if(itest(36).eq.1) then
         iprec=iprec0+ihprec-ihprec/(iterh+iterh)
      else if(itest(36).eq.2) then
         iprec=iprec0+min(ihprec,iterh-1)
      else
         if(iterh.eq.1) then
            iprec=iprec0
         else
c            print*,'del',del
            prec=-log10(dabs(del/1000))
c            print*,'prec',prec
            iprec=prec
            iprec=max(iprec,iprec0)
            iprec=min(iprec,iprec0+ihprec)
            if(dabs(del).lt.conv.and.iprec.ne.iprec0+ihprec) then
               itest(36)=1
               goto 1010
            endif
         endif
      endif
      if(nprint.ge.2)write(6,*)'nocas',nocas,'  nvs',nvs
      write(6,1000) iterh
 1000 format(//,70('*'),/,20x,'Nad ITERATION HABILLAGE',i3,/,70('*'))
      if(ytana)write(6,*)'appel sc2'
      if(yw)write(6,*)'ndet 2',ndet
c
c--   on transfere la diagonale sur file 29
      rewind 25
      call lir8bl(hoi,nicdi,25)
      call ecr8bl(hoi,nicdi,29)
      if(yw) then
         do k=1,nicdi
            write(6,*)'diag0',k,hoi(k)
         enddo
      endif
c--   puis on met la file 25 a zero
      do k=1,nicdi
         hoi(k)=0
      enddo
      rewind 25
      call ecr8bl(hoi,nicdi,25)
c
c--   recherche du vecteur propre habilleur
      rewind 93
      do i=1,noac+2
         ith(i)=0
      enddo
c     read(93,deth,end=4)
      call LECNAM('&DETH',namel,93,ierr,0)
      if(ierr.ne.0) goto 4
      call nameli(namel,ITH,'ITH',4)
      call nameli(namel,IPH,'IPH',4)
      neh=noac+2
      if(yw)write(6,*)'lec 93'
      if(yw)write(6,deth)
      do k=1,noac+2
         if(ith(k).eq.0) then
            neh=k-1
            goto 4
         else
            if(ith(k).lt.0) ith(k)=-ith(k)+norb
            if(iph(k).lt.0) iph(k)=-iph(k)+norb
         endif
      enddo
 4    continue
      if(mod(-ms2,2).ne.0) iph(neh)=norb+norb+1
      call reor(neh,ith,idum)
      call reor(neh,iph,idum)
      if(yw)write(6,*)'neh',neh
      write(6,*)' '
      print*,'determinant habilleur'
      call conformh
      write(6,*)' '
c      write(6,*)'ith',(ith(k),k=1,neh)
c      write(6,*)'iph',(iph(k),k=1,neh)
c     print*,'ms2',ms2,mod(-ms2,2),neh,norb
      call vh(c,hoi)
      call lire(c,ihvec1,nicdi,21)
c
c-----------------------------------------------------------------
c     habillage multiref : calcul de la norme**2 des coefficients
c                          de reference (c2)
c                   NE MARCHE PAS    faire ndeth=1
c-----------------------------------------------------------------
c
      rewind 93
      c2=0.d0
c     boucle sur les det de reference
      do ideth=1,ndeth
c        adrh donne l'adresse du det de reference ideth
         call adrh
         c2=c2+c(iadrh)*c(iadrh)
         write(6,'(a48,i7,f10.6)')
     *   ' numero et coefficient du determinant habilleur '
     *   ,iadrh,c(iadrh)
      enddo
c      write(6,*)'c2',c2
c--   ecriture test pour verifier la conformite du fichier sc2ex
c     dans un eventuel calcul ulterieur
      rewind 12
      write(12) ndeth,noac,nelac,numac
c
c--   habillage multiref : boucle sur les determinants habilleurs
c
      rewind 93
      do ideth=1,ndeth
         call lire(c,ihvec1,nicdi,21)
c--      lecture et adresse du determinant habilleur
         call adrh
c--      ecriture du determinant habilleur
         write(12)neh,(ith(k),k=1,neh),(iph(k),k=1,neh)
c--   denormalisation
         c0=c(iadrh)
         do i=1,nicdi
            c(i)=c(i)/c0
         end do
c--      coefficient du determinant habilleur
c         coef=c0*c0/c2
c         write(6,*) 'coef',coef,c0,c0*c0,c2,iadrh
c--      habillage par les tableaux
         print*,'habillage par les tableaux'
         call sc2cicasnj(c4,c4(i2),c4(i3),c4(i4),c4(i5),
     *   c4(i6),c4(i7),c4(i8),c4(i9),c4(i10),c4(i11),
     *   c4(i12),c4(i13),c4(i14),c4(i15),c4(i16),c4(i17),
     *   c4(i18),c4(i19),c4(i20),c4(i21),c4(i22),c4(i23),
     *   c4(i24),c4(i25),c4(i26),c4(i27),nocas,nvs,c,hoi)
c         write(6,*)'ndet 3',ndet
c         write(6,*)'itest(11)',itest(11)
c--      habillage par application directe de la formule
c
c-----------appel habillage----------------------
c
         print*,'habillage par application directe de la formule'
         call sc2cicasj(c,hoi)
      enddo
c
c     la diagonale originale est sur 29
c     les corrections a la diagonale sont sur 25
c--   on fait la somme de 25 et 29 et on stocke sur 25
      call aldobl(c,yesp(iadri*8+1),nicdi,25,29)
c
c--   on diagonalise
      if(ytana)write(6,*)'sc2casn appel david'
      call david(c,hoi,iesp,iesp2,yesp)
      if(mprint(4).eq.1) call wvec(c,hoi,hoi)
c--   test d'arret
      rewind 11
      read(11)nicdi,metat
      read(11) e
      del=e-e0
      e0=e
      write(6,*)' '
      write(6,*)'------------------------------------------------------'
      write(6,1001) del
 1001 format('       fin de l''iteration d''habillage ',
     *'    DELTAE=',f10.6)
      write(6,*)'------------------------------------------------------'
      if(dabs(del).lt.conv) then
         if(iprec.ne.iprec0+ihprec) goto 1
         write(6,*)'-------------------------------------------------'
         write(6,'(''CONVERGENCE HABILLAGE ATTEINTE ENERGIE'',F12.8)') e
         write(6,*)'-------------------------------------------------'
         return
      endif
      if(yw)write(6,*)'nicdi,metat',nicdi,metat
 1    continue
      write(6,*)'        NON CONVERGE'
      write(6,*)'-------------------------------------------------'
      maxith=10
      close(11)
      call wvec(c,hoi,hoi)
      call fin
      end
c**********************************************************************
       subroutine sc2cicasnj(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,nocz,nvz,c,hoi)
      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)
      parameter (maxda3=300)
      common/dim/iadri ; integer(8) iadri
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/ ei(ngru3),adum(1024)
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      common /cstes_hab/sttpp,sttp,stt,stpp,stp,st,spp,sp
      logical*1 bidia
      character*4 hab
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      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)
c     real*4 stvtvpvpv(nocz*(nocz+1)/2,nvz*(nvz+1)/2)
      real*4 stvtvpvpv(ii28)
      dimension it4(maxorbcas+2),ip4(maxorbcas+2)
      dimension it2(maxorbcas+2),ip2(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas)
      dimension nt(maxorbcas+2),np(maxorbcas+2)
      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
      character*4 gener
      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
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common /nin/i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
      dimension c(iadri),hoi(iadri)
      common/test/itest(100)
      dimension yh(maxorb+maxorb)
      dimension itradh(maxorb*2)
      dimension iph2(maxorbcas+2)
      dimension ikl(1),jkl(1),it31l(1),ip31l(1)
      equivalence (ik,ikl(1)),(jk,jkl(1)),(it31,it31l(1))
     *,(ip31,ip31l(1))
      yw=.false.
      yw1=.false.
      if(yw1)write(6,*)'nocz',nocz,'  nvz',nvz
      if(yw)print*,'entree sc2cicasnj'
      if(yw)write(6,*) 'norb,noca,nicdi',norb,noca,nicdi
c
C--------------------------------------------------------------
c     mise a zero et calculs preliminaires
C--------------------------------------------------------------
c
c
c--   itradh : echange d'orbitales pour que le det de reference
c     soit bien ecrit dans l'ordre occ / vide
      call calyh(yh)
      do k=1,norb+norb
         itradh(k)=k
      enddo
      kk=0
      do k=noca+1,norb
         if(yh(k)) then
            kk=kk+1
            iph2(kk)=k
         endif
      enddo
      kk=0
      do k=1,noca
         if(.not.yh(k)) then
            kk=kk+1
            itradh(k)=iph2(kk)
            itradh(iph2(kk))=k
         endif
      enddo
      kk=0
      do k=nocb+1,norb
         if(yh(k+norb)) then
            kk=kk+1
            iph2(kk)=k
         endif
      enddo
      kk=0
      do k=1,nocb
         if(.not.yh(k+norb)) then
            kk=kk+1
            itradh(k+norb)=iph2(kk)+norb
            itradh(iph2(kk)+norb)=k+norb
         endif
      enddo
      if(yw) then
         write(6,'(a15,15i3)')'itradh',(itradh(k),k=1,norb)
         write(6,'(a15,15i3)')'itradh',(itradh(k+norb),k=1,norb)
      endif
      write(12) itradh
c
C--------------------------------------------------------------
C       relecture des coefficients de l'IC et "denormalisation"
C--------------------------------------------------------------
c
      coef=c0*c0/c2
c      write(6,*) 'coef',coef,c0,c0*c0,c2,iadrh
c--   mise a zero
      do i=1,nicdi
         hoi(i)=0.d0
      end do
      if(yw) then
         write(6,*)' '
         call rew61
         do kkk=1,nicdi
c            read(61) ne
c            if(ne.ne.0) read(61)(it4(k),k=1,ne),(ip4(k),k=1,ne)
            call venondloc(ne,it4,ip4,ierr)
            do i=1,ne
               if(it4(i).gt.norb) it4(i)=-(it4(i)-norb)
               if(ip4(i).gt.norb) ip4(i)=-(ip4(i)-norb)
            enddo
            write(6,'('' c'',f12.8,i8,3x,12i3)') c(kkk),kkk,
     *      (it4(k),k=1,ne),(ip4(k),k=1,ne)
         enddo
      endif
      call col1(c,hoi)
c----------------------------------------------------
C     calcul de Evar (ACPF ou AQCC)
c----------------------------------------------------
c
      evar=0.d0
      if(yw)write(6,*)'nicdi',nicdi
c     open(99,status='unknown',file='f99')
      if(hab.eq.'ACPF'.or.hab.eq.'AQCC') then
         nel=nelac+ninac*2
         call rew61
         do i=1,nicdi
            call venondloc(ne,nt,np,ierr)
            call trad(ne,nt,np,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
c           print*,'calcul evar hoi',i,hoi(i)
            if(nt2.ne.0.or.np2.ne.0) evar=evar+hoi(i)
            if(yw)write(6,'('' hoi,ci'',f12.8,2f10.6)') hoi(i),c(i)
c            write(99,'(2f10.6,i4)') dabs(c(i)),hoi(i),i
         end do
c        on ecrase hoi pour mettre les corrections a la diagonale
         call rew61
         do i=1,nicdi
            call venondloc(ne,nt,np,ierr)
            call trad(ne,nt,np,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
            if(nt2.ne.0.or.np2.ne.0) then
               if(hab.eq.'ACPF') then
                  hoi(i)=evar*(nel-2)/nel
               else
                  hoi(i)=evar*(nel-2)*(nel-3)/(nel*(nel-1))
               endif
            else
               hoi(i)=0.d0
            endif
         enddo
         write(6,*) 'evar',evar
         goto 3000
      endif
C
C-----------------------------------------------------------------------
C     boucle sur les determinants pour construire les epv
C-----------------------------------------------------------------------
C
c     Mise a zero des tableaux
      call epv_zero(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)
c
      call rew61
      iii=2
c       yw=.true.
c      write(6,*) 'Vaig a llegir tots els determinants'
      if(yw)write(6,*)'av c_hab'
      do i=1,nicdi
c         read(61) ne
c         if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
         call venondloc(ne,nt,np,ierr)
         if(yw)
     *   write(6,'(a10,12i3)')'noca,nocb',noca,nocb
         if(yw)
     *   write(6,'(a10,12i3)')'det lu',(nt(k),k=1,ne),(np(k),k=1,ne)
c            write(6,'(a10,12i3)')'hhab',(nt(k),k=1,ne),(np(k),k=1,ne),i
         call tradh(norb,ne,nt,np,ne2,it2,ip2,neh,iph,ith,isgn)
CJose    Estem llegint tots els determinants per a classificar-los com
CJose    Dj+ i ara hem de considerar tambe els que siguen Mj+ perque
CJose    Volem introduir les monoexcitacions. Per tant en estos moments
CJose    ens val tant ne2=2 com ne2=1
c         write(6,*) 'El determinant es una',ne2,' excitacio'
         if(yw)
     *   write(6,'(a15,12i3)')'ap tradh',(it2(k),k=1,ne2)
     *   ,(ip2(k),k=1,ne2)
         if(ne2.eq.2.or.(ne2.eq.1.and.yhmono)) then
            call trad(ne,nt,np,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
c           on garde la forme originale D+ pour stvtvpvpv
            do k=1,ne2
               nt(k)=itradh(it2(k))
               np(k)=itradh(ip2(k))
            enddo
            do j=1,ne2
               np(j)=np(j)-noca
               if(nt(j).gt.norb) nt(j)=nt(j)-nv2
               if(np(j).gt.norb) np(j)=np(j)-nocb
            enddo
            if(yw)write(6,*)'nca',(ica(k),k=1,nca)
            if(yw)write(6,*)'ncb',(icb(k),k=1,ncb)
            call adrdet
     *      (nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,ispp,iadr,
     *      mhdum,mtdum)
c            write(6,*) 'i l adresse',iadr
c --- rangement des trous et part par ordre T puis CAS et P puis CAS
            if(ne2.eq.1) then
               it4(1)=itradh(it2(1))
               ip4(1)=itradh(ip2(1))
               goto 310
            endif
            do k=1,2
               it4(k)=itype(iorb(it2(k)))
            enddo
            call reorr(2,it2,it4)
            do k=1,2
               ip4(k)=-itype(iorb(ip2(k)))
            enddo
            call reorr(2,ip2,ip4)
c              write(6,*)'ip4 apres',(ip4(k),k=1,2)
c            if(yw)write(6,*)'apres',np2,(ip4(k),k=1,ne)
            if(yw)
     *      write(6,'(a10,12i3)')'reorr',(it4(k),k=1,2),(ip4(k),k=1,2)
            do j=1,ne2
               it4(j)=itradh(it4(j))
               ip4(j)=itradh(ip4(j))
            enddo
            if(yw)
     *      write(6,'(a10,12i3)')'itradh',(it4(k),k=1,2),(ip4(k),k=1,2)
c --- fin de : rangement des trous et part par ordre T puis CAS et ...
 310        continue
            do j=1,ne2
               ip4(j)=ip4(j)-noca
               if(it4(j).gt.norb) it4(j)=it4(j)-nv2
               if(ip4(j).gt.norb) ip4(j)=ip4(j)-nocb
            enddo
            if(yw)
     *      write(6,'(a10,12i3)')'shift',(it4(k),k=1,2),(ip4(k),k=1,2)
            dum=hoi(iadr)*coef
c            write(6,*)'det ',iadr,dum,hoi(iadr),coef
CJose      Aci considerem del determinant que ens ha arribat si te un va
CJose     de hoi=0. Si es aixina es perque la seua contribucio va a ser
CJose     pel motiu que siga. Si es 0, en tal cas, no el considerem
            if(dum.ne.0.d0)then
CJose      Faig a fer la diferencia de que cride a c_hab o c_hab1 depene
CJose      de que tractem ab una diexcitacio o monoexcitacio,respectivam
               if(ne2.eq.2) then
                  call c_hab(ne2,nt,np,nt2,np2,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)
               else
                  if(yhmono) then
                     call c_hab1(nt,np,nt2,np2,dum,it4,ip4,nocz,nvz,
     *               stvp,stv,stpv,spv,stvpv)
                  endif
               end if
            endif
         end if
      end do
      if(yw)write(6,*)'ap c_hab'
c      yw=.false.
C
c------------------------------------------------------------------
c     Ecriture des epv sous la forme ect, ecp, ectp, eovv, eoov
c------------------------------------------------------------------
      if(yw)
     *call epv_ecr(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,ii28,stvtvpvpv)
c
c
c------------------------------------------------------------------
c--   ecriture des tableaux EPV
c------------------------------------------------------------------
c
      call ecrepv(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)
c
C
C-----------------------------------------------------------------------
C      modification de la diagonale
      call rew61
      Ecor=0.d0
c     on va stocker les corrections a la diagonale dans un fichier
c     temporaire 42
c     hoi contient la 1ere colonne
      open(42,file='BID42',form='UNFORMATTED')
      ii=0
c     yw=.true.
      do i=1,nicdi
         ii=ii+1
c        yw=ii.eq.48
         hii=0.d0
         ei(ii)=0.d0
c         read(61) ne
c         if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
         call venondloc(ne,nt,np,ierr)
         if(yw)write(6,*)'lu hii nt,np',(nt(k),k=1,ne),(np(k),k=1,ne)
         call tradh(norb,ne,nt,np,ne2,it2,ip2,neh,iph,ith,isgn)
         if(yw) then
            write(75,*)
     *      'apres itradh ne2,it2,ip2'
     *      ,ne2,(it2(k),k=1,ne2),' p',(ip2(k),k=1,ne2),'$'
            call scril
         endif
         call trad(ne,nt,np,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *   ispp,ierr)
         if(yw) then
            write(75,*)
     *      'ne2,it2,ip2',ne2,(it2(k),k=1,ne2),' p',(ip2(k),k=1,ne2),
     *      '  nca,ncb',nca,ncb,'ispt,ispp',ispt,ispp,'$'
            call scril
         endif
         hii=0.d0
c --- rangement des trous et part par ordre T puis CAS et P puis CAS
         do k=1,ne2
            it4(k)=itype(iorb(it2(k)))
         enddo
         call reorr(ne2,it2,it4)
         do k=1,ne2
            ip4(k)=-itype(iorb(ip2(k)))
         enddo
         call reorr(ne2,ip2,ip4)
         if(yw)
     *   write(6,'(a10,12i3)')'reorr',(it4(k),k=1,ne2),(ip4(k),k=1,ne2)
         do j=1,ne2
            it4(j)=itradh(it4(j))
            ip4(j)=itradh(ip4(j))
         enddo
         if(yw)
     *   write(6,'(a10,12i3)')'itradh',(it4(k),k=1,ne2),(ip4(k),k=1,ne2)
c
c --- fin de : rangement des trous et part par ordre T puis CAS et ...
c
         do j=1,ne2
            ip4(j)=ip4(j)-noca
            if(it4(j).gt.norb) it4(j)=it4(j)-nv2
            if(ip4(j).gt.norb) ip4(j)=ip4(j)-nocb
         enddo
         if(yw)
     *   write(6,'(a10,12i3)')'shift',(it4(k),k=1,2),(ip4(k),k=1,2)
c        print*,'avant c_hii ii',ii
         call c_hii(ne2,nt2,np2,it4,ip4,nocz,nvz,hii,
     *   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)
c        endif
         ei(ii)=hii
c        print*,'hii',hii,ii
         if(ii.eq.ngru3) then
            write(42) ei
            ii=0
         endif
      end do
      if(yw)write(6,*)'ap c_hii'
c     do k=1,nicdi
c        write(6,'('' fin sc2cas hii'',i6,f12.5)')k,ei(k)
c     enddo
c      yw=.false.
      write(42) ei
      rewind 42
      if(yw)write(6,*)'iterh',iterh
c--   fin du stockage des corrections a la diagonale sur la file 42
c
c--   on lit les elements diagonaux
c     if(iterh.eq.1) then
c           rewind 25
c           call lir8bl(hoi,nicdi,25)
c           call ecr8bl(hoi,nicdi,29)
c     else
c           rewind 29
c           call lir8bl(hoi,nicdi,29)
c     endif
      do k=1,nicdi
         hoi(k)=0
      enddo
      if(yw) then
         do kkk=1,nicdi
            call rew61
c            read(61) ne
c            if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
            call venondloc(ne,nt,np,ierr)
            if(ne.eq.2)
     *      write(6,'('' diagon lue'',f12.8,4i3)') hoi(kkk),
     *      (nt(k),k=1,2),(np(k),k=1,2)
            if(ne.eq.1)
     *      write(6,'('' diagon lue'',f12.8,2i3)') hoi(kkk),nt(1),np(1)
         enddo
      endif
c--      on corrige la diagonale en lisant les corrections sur 42
c        et on met la diagonale corrigee dans hoi
      ii=0
      if(itest(14).eq.1) then
         open(98,form='formatted',status='unknown',file='ein')
         open(97,form='formatted',status='unknown',file='einjl')
      endif
      call rew61
      do i=1,nicdi
         if(mod(ii,ngru3).eq.0) then
            if(yw)write(6,*)'lecture ei'
            read(42) ei
            ii=0
            if(yw) then
               do kkk=1,min(nicdi,2048)
                  write(6,'('' ei '',f12.8,i8)') ei(kkk),kkk
               enddo
            endif
         endif
         ii=ii+1
         hoi(i)=hoi(i)+ei(ii)
c         read(61) ne
c         if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
         call venondloc(ne,nt,np,ierr)
         if(itest(14).eq.1) then
            if(ne.eq.1)write(98,'(2i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),hoi(i)
            if(ne.eq.2)write(98,'(4i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),hoi(i)
            if(ne.eq.3)write(98,'(6i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),hoi(i)
            if(ne.eq.4)write(98,'(8i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),hoi(i)
            if(yw)write(6,'(''nt,np,ei'',f12.8,14i3)') ei(ii),
     *      (nt(k),k=1,ne),(np(k),k=1,ne),i
            if(ne.eq.1)write(97,'(2i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),ei(ii)
            if(ne.eq.2)write(97,'(4i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),ei(ii)
            if(ne.eq.3)write(97,'(6i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),ei(ii)
            if(ne.eq.4)write(97,'(8i3,f12.6)')
     *      (nt(k),k=1,ne),(np(k),k=1,ne),ei(ii)
            if(yw)write(6,'(''nt,np,ei'',f12.8,14i3)') ei(ii),
     *      (nt(k),k=1,ne),(np(k),k=1,ne),i
         endif
      enddo
      if(itest(14).eq.1) close(98)
      if(itest(14).eq.1) close(97)
      if(yw) then
         do kkk=1,nicdi
            write(6,'('' diagon corrigee '',f12.8,i8)') hoi(kkk)!,kkk
         enddo
      endif
 3000 continue
C
C        fin de la correction de la diagonale
C        la correction est dans hoi
C        on rajoute la correction hoi a la file 25
C        (hoi est ecrase)
C
      rewind 25
      call aldobl2(hoi,nicdi,25)
c--   on refabrique c qui a ete ecrase par les EPV
      call lire(c,ihvec1,nicdi,21)
      do i=1,nicdi
         c(i)=c(i)/c0
      end do
c        calcul de ecor
      ecor=0.d0
      rewind 42
      call rew61
      ii=0
      if(yw) then
         do i=1,nicdi
c            read(61) ne
c            if(ne.ne.0) read(61)
            call venondloc(ne,nt,np,ierr)
            if(mod(ii,ngru3).eq.0) then
               read(42) ei
               ii=0
            endif
            ii=ii+1
            if(ne.eq.2) ecor=ecor+c(i)*c(i)*ei(ii)*c0*c0
c           if(ne.eq.2)write(6,*)'c,ei,c0',i,c(i),ei(i),c0,ecor
c          if(iterh.eq.1) write(99,*)ei(i)
         enddo
         write(6,*) 'EVAR=',evar,' VAL. MOYEN DE V TILDA SUR LES DI
     *   ',ecor
      endif
      close(42,status='DELETE')
      return
      end
c**********************************************************************
       subroutine xc2cicasnj(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,nocz,nvz,c)
      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)
      common/dim/iadri ; integer(8) iadri
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/ ei(ngru3),adum(1024)
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      common /cstes_hab/sttpp,sttp,stt,stpp,stp,st,spp,sp
      dimension itradh(maxorb*2)
      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)
c     real*4 stvtvpvpv(nocz*(nocz+1)/2,nvz*(nvz+1)/2)
      real*4 stvtvpvpv(ii28)
c      real*4 stvtvpvpv(nocz,nocz,nvz,nvz)
      dimension it2(maxorbcas+2),ip2(maxorbcas+2)
      dimension it4(maxorbcas+2),ip4(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas)
      dimension nt(maxorbcas+2),np(maxorbcas+2)
      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
      character*4 gener
      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
      common /det/ndet,mdet(50),nbdet_cas
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common /nin/i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
      dimension c(iadri)
      common/test/itest(100)
      yw=.false.
      yw1=.false.
      print*,' x nocz,nvz',nocz,nvz
c      rewind 25
c      call lir8bl(hoi,ndet,25)
      do k=1,ndet
      enddo
      if(yw1)write(6,*)'nocz',nocz,'  nvz',nvz
      if(yw)print*,'entree xc2cicasn'
c
c--   itradh
      read(12) itradh
      if(yw) then
         write(6,'(a10,20i3)') 'itradh',(itradh(k),k=1,norb+norb)
      endif
c
c--   lecture des tableaux EPV
c
      read(12) sttpp,sttp,stt,stpp,stp,st,spp,sp
      read(12)sttvpp,stvpp,sttvp,stvp,sttv,stv,sttppv,
     *sttpv,stppv,stpv,sppv,spv
      read(12)stvtvpp,stvtvp,stvtv,sttpvpv,
     *stpvpv,spvpv,sttvppv,sttvpv,stvppv,stvpv
      read(12)stvtvppv,stvtvpv,sttvpvpv,stvpvpv
      read(12)stvtvpvpv
C
C-----------------------------------------------------------------------
C      modification de la diagonale
      call rew61
      if(yw)write(6,*)'ndet',ndet
      do i=1,ndet
         hii=0.d0
c         read(61) ne
         call venondloc(ne,nt,np,ierr)
         if(ne.ne.0) then
c            read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
            if(yw)write(6,*)'lu nt,np',(nt(k),k=1,ne),(np(k),k=1,ne)
            call tradh(norb,ne,nt,np,ne2,it2,ip2,neh,iph,ith,isgn)
            if(yw)write(6,*)'it2,ip2',(it2(k),k=1,ne),(ip2(k),k=1,ne)
            call trad(ne,nt,np,nca,ica,ncb,icb,nt2,it4,ispt,np2,ip4,
     *      ispp,ierr)
            if(yw) then
               write(75,*)
     *         'ne,nt,np',ne,(nt(k),k=1,ne),' p',(np(k),k=1,ne),
     *         'nca,ncb',nca,ncb,'ispt,ispp',ispt,ispp,'$'
               call scril
            endif
            hii=0.d0
c --- rangement des trous et part par ordre T puis CAS et P puis CAS
            do k=1,ne2
               it4(k)=itype(iorb(it2(k)))
            enddo
            call reorr(ne2,it2,it4)
            do k=1,ne2
               ip4(k)=-itype(iorb(ip2(k)))
            enddo
            call reorr(ne2,ip2,ip4)
            if(yw)write(6,*)'r it4,ip4',(it4(k),k=1,ne),(ip4(k),k=1,ne)
            do j=1,ne2
               it4(j)=itradh(it4(j))
               ip4(j)=itradh(ip4(j))
            enddo
c
c --- fin de : rangement des trous et part par ordre T puis CAS et ...
c
            do j=1,ne2
               ip4(j)=ip4(j)-noca
               if(it4(j).gt.norb) it4(j)=it4(j)-nv2
               if(ip4(j).gt.norb) ip4(j)=ip4(j)-nocb
            enddo
c     write(75,*)'it4,ip4',(it4(k),k=1,ne),(ip4(k),k=1,ne),'$'
c     call scril
            call c_hii(ne2,nt2,np2,it4,ip4,nocz,nvz,hii,
     *      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)
         endif
         c(i)=hii
      end do
      if(yw)write(6,*)'ap c_hii'
c--   fin du stockage des corrections a la diagonale sur la file 42
c
c--   on lit les elements diagonaux
c      rewind 25
c      call lir8bl(hoi,ndet,25)
c--   on corrige les elements diagonaux
c      do i=1,ndet
c         hoi(i)=hoi(i)+c(i)
c      enddo
      if(yw) then
         call rew61
         do kkk=1,ndet
c            read(61) ne
c            if(ne.ne.0) read(61)(nt(k),k=1,ne),(np(k),k=1,ne)
            call venondloc(ne,nt,np,ierr)
            if(ne.eq.2)
     *      write(6,'('' corr diag'',f12.8,4i3,i8)') c(kkk),
     *      (nt(k),k=1,2),(np(k),k=1,2),kkk
            if(ne.eq.1)
     *      write(6,'('' corr diag'',f12.8,2i3,i16)') c(kkk)
     *      ,nt(1),np(1),kkk
         enddo
c         do kkk=1,ndet
c            write(6,'('' diagon corrigee '',f12.8,i8)') hoi(kkk),kkk
c         enddo
      endif
C
C     fin de la correction de la diagonale
C     la diagonale corrigee est dans hoi
C     on stocke la diagonale corrigee sur 25
C
c      call ecr8bl(hoi,ndet,25)
      rewind 25
      call aldobl2(c,ndet,25)
      write(6,*)'fin habillage Nadia'
      call flush(6)
c      write(6,*)'iterh dans xc2casn',iterh
      iterh=1
      return
      end
 
 
 
 
 
       subroutine ecrepv(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)
      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)
c     *,stvtvpvpv(nocz,nocz,nvz,nvz)
c     real*4 stvtvpvpv(nocz*(nocz+1)/2,nvz*(nvz+1)/2)
      common/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      real*4 stvtvpvpv(ii28)
      yw=.false.
      write(12) sttpp,sttp,stt,stpp,stp,st,spp,sp
      write(12)sttvpp,stvpp,sttvp,stvp,sttv,stv,sttppv,
     *sttpv,stppv,stpv,sppv,spv
      write(12)stvtvpp,stvtvp,stvtv,sttpvpv,
     *stpvpv,spvpv,sttvppv,sttvpv,stvppv,stvpv
      write(12)stvtvppv,stvtvpv,sttvpvpv,stvpvpv
      write(12)stvtvpvpv
      call flush(12)
      if(.not.yw) return
      write(6,*) 'sttpp,sttp,stt,stpp,stp,st,spp,sp'
      write(6,1000) sttpp,sttp,stt,stpp,stp,st,spp,sp
      write(6,*)'sttvpp,stvpp,sttvp,stvp,sttv,stv,sttppv,
     *sttpv,stppv,stpv,sppv,spv'
      write(6,1000)sttvpp,stvpp,sttvp,stvp,sttv,stv,sttppv,
     *sttpv,stppv,stpv,sppv,spv
      write(6,*)'stvtvpp,stvtvp,stvtv,sttpvpv,
     *stpvpv,spvpv,sttvppv,sttvpv,stvppv,stvpv'
      write(6,1000)stvtvpp,stvtvp,stvtv,sttpvpv,
     *stpvpv,spvpv,sttvppv,sttvpv,stvppv,stvpv
      write(6,*)'stvtvppv,stvtvpv,sttvpvpv,stvpvpv'
      write(6,1000)stvtvppv,stvtvpv,sttvpvpv,stvpvpv
      write(6,*)'stvtvpvpv'
      write(6,1000)stvtvpvpv
 1000 format(5f12.8)
      return
      end
       subroutine tradh(norb,ne,nt,np,ne2,it2,ip2,neh,ith,iph,isgn)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      dimension nt(maxorbcas+2),np(maxorbcas+2)
      dimension it2(maxorbcas+2),ip2(maxorbcas+2)
      dimension ith(maxorbcas+2),iph(maxorbcas+2)
      yw=.false.
      isgn=0
      ii=0
      do i=1,ne
         if(nt(i).le.norb) then
            ii=ii+1
            it2(ii)=nt(i)
            ip2(ii)=np(i)
         endif
      enddo
      if(yw)write(6,*)'it2',(it2(k),k=1,ne),'  ip2',(ip2(k),k=1,ne)
      if(yw)write(6,*)'neh',neh
      do i=1,neh
         if(ith(i).le.norb) then
            ii=ii+1
            it2(ii)=ith(i)
            ip2(ii)=iph(i)
         endif
      enddo
      if(yw)write(6,*)'it2',(it2(k),k=1,ne),'  ip2',(ip2(k),k=1,ne)
      do i=1,ne
         if(nt(i).gt.norb) then
            ii=ii+1
            it2(ii)=nt(i)
            ip2(ii)=np(i)
         endif
      enddo
      if(yw)write(6,*)'it2',(it2(k),k=1,ne),'  ip2',(ip2(k),k=1,ne)
      if(yw)write(6,*)'neh',neh
      do i=1,neh
         if(ith(i).gt.norb) then
            ii=ii+1
            it2(ii)=ith(i)
            ip2(ii)=iph(i)
         endif
      enddo
      if(neh.eq.0) then
         do k=1,ne
            it2(k)=nt(k)
            ip2(k)=np(k)
         enddo
         ne2=ne
         isgn=1
         return
      endif
      if(yw)write(6,*)'it2',(it2(k),k=1,ne+neh),'  ip2',
     *(ip2(k),k=1,ne+neh)
      do i=1,ne+neh
         do j=1,ne+neh
            if(it2(i).ne.0.and.it2(i).eq.ip2(j)) then
               it2(i)=0
               ip2(j)=0
            endif
         enddo
      enddo
      if(yw)write(6,*)'it2',(it2(k),k=1,ne+neh),'  ip2',
     *(ip2(k),k=1,ne+neh)
      ne2=0
      do i=1,ne+neh
         if(it2(i).ne.0) then
            ne2=ne2+1
            it2(ne2)=it2(i)
         endif
      enddo
      ne2=0
      do i=1,ne+neh
         if(ip2(i).ne.0) then
            ne2=ne2+1
            ip2(ne2)=ip2(i)
         endif
      enddo
      call reor(ne2,it2,isgn1)
      call reor(ne2,ip2,isgn2)
c     isgn=1
      isgn=isgn1*isgn2
c     isgn=(1-2*mod(isgn,2))*isgn1*isgn2
      if(iabs(isgn).ne.1) stop 'ecrepv iabs(isgn).ne.1 '
      if(yw)write(6,*)'it2',(it2(k),k=1,ne2),'  ip2',
     *(ip2(k),k=1,ne2)
      return
      end
       subroutine vh(c,hoi)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      parameter (maxda3=300,maxorbcas=16)
      logical*1 bidia
      common/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      character*4 hab
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      dimension c(iadri),hoi(iadri)
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      dimension it(2),ip(2),ica(maxorbcas),icb(maxorbcas)
      yw=.false.
c
c----------------------------------------------------------
c      recherche du vecteur habilleur
c----------------------------------------------------------
c
c
c--   adresse du determinant habilleur
      if(yw)write(6,*)'dans vh neh,ith,iph',neh
      if(yw)write(6,*)'ith',(ith(k),k=1,neh)
      if(yw)write(6,*)'iph',(iph(k),k=1,neh)
      call trad(neh,ith,iph,nca,ica,ncb,icb,nt,it,ispt,np,ip,
     *ispp,ierr)
      call adrdet(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,
     *iadr
     *      ,mhdum,mtdum)
      if(ihvec.eq.1) then
         call lire(c,1,nicdi,21)
         ihvec1=1
         c0=c(iadr)
         goto 1
      endif
      c0=0.d0
      if(ihvec.gt.1)write(6,*)'recherche du vecteur habilleur'
      do k=ihvec,1,-1
         call lire(c,k,nicdi,21)
         write(6,'('' vecteur numero'',i3,'' coef,coef max'',2f10.6)')
     *   k,c(iadr),c0
         if(dabs(c(iadr)).gt.dabs(c0)) then
            c0=c(iadr)
            ihvec1=k
         endif
      enddo
      write(6,*)'on habille a partir du vecteur propre numero',ihvec1
 1    continue
c      write(6,'('' c0'',f10.6)') c0
      if(dabs(c0).lt.sh) then
         write(6,*)'le vecteur propre habilleur a un coefficient',
     *   c0,' sur le determinant fondamental, inferieur a sh  sh=',sh
         write(6,*)'sh peut etre modifie dans &dav'
         write(6,*)'attention  le vecteur habilleur peut aussi etre',
     *   ' devenu plus haut que ihvec'
         write(6,*)'vous pouvez repartir des vecteurs de davec'
         close(11)
         call wvec(c,hoi,hoi)
         call fin
      endif
      return
      end
       subroutine adrh
c
c--------------------------------------------------------
c     lecture et adresse du determinant habilleur
c--------------------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      parameter (maxorbcas=16)
      include 'maxorb.prm'
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension it(2),ip(2),ica(maxorbcas),icb(maxorbcas)
      character*1280 namel
      namelist /deth/ith,iph
      ith(1)=0
      if(ndeth.eq.1) then
c        read(93,deth,end=2)
         call LECNAM('&DETH',namel,93,ierr,0)
         if(ierr.ne.0) goto 2
         call nameli(namel,ITH,'ITH',4)
         call nameli(namel,IPH,'IPH',4)
 
 2       continue
      else
c        read(93,deth)
         call LECNAM('&DETH',namel,93,ierr,0)
         call nameli(namel,ITH,'ITH',4)
         call nameli(namel,IPH,'IPH',4)
      endif
      neh=noac
      do k=1,noac
         if(ith(k).eq.0) then
            neh=k-1
            goto 3
         endif
      enddo
 3    continue
      if(mod(-ms2,2).ne.0) iph(neh)=-norb-1
c     write(6,*)'neh',neh
      do k=1,neh
         if(ith(k).lt.0) ith(k)=-ith(k)+norb
         if(iph(k).lt.0) iph(k)=-iph(k)+norb
      enddo
c--   adresse du determinant habilleur
      call trad(neh,ith,iph,nca,ica,ncb,icb,nt,it,ispt,np,ip,
     *ispp,ierr)
      call adrdet(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,
     *iadrh
     *      ,mhdum,mtdum)
      return
      end
       subroutine aldobl(c,yesp,ndet,ifil1,ifil2)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
c
c----------------------------------------------
c     rajout de ifil2 a ifil1
c----------------------------------------------
c
      parameter (ngru3=2048)
      common /fpspi/yfpspi
      dimension c(ndet),ei(ngru3)
      yw=.false.
      rewind ifil1
      rewind ifil2
      call lir8bl(c,ndet,ifil1)
      if(yfpspi) call egaspi(c,yesp,ndet)
      ifin=0
      do k=1,ndet,ngru3
         ideb=ifin+1
         ifin=min(ideb-1+ngru3,ndet)
         long=ifin-ideb+1
         call lir8(ei,long,ifil2)
c         read(ifil2) ei
         if(yw)then
            do kk=1,ndet
               write(6,'(a10,i6,2f16.5)')'aldobl',kk,c(kk),ei(kk)
            enddo
         endif
c        do kk=1,ndet
c           write(99,'(2f10.6,i4)')ei(kk),c(kk),kk
c        enddo
 
c        do kk=1,ndet
c              write(6,'('' CORREC,DIAG'',i4,2f10.4)') kk,c(kk),ei(kk)
c           enddo
c           stop
 
 
 
         do l=ideb,ifin
            ll=l-(k-1)
            c(l)=c(l)+ei(ll)
         enddo
      enddo
         if(yw)then
            do kk=1,ndet
               write(6,'(a14,i6,2f16.5)')'aldobl corrtot',kk,c(kk)
            enddo
         endif
c      stop
      rewind ifil1
      call ecr8bl(c,ndet,ifil1)
      return
      end
       subroutine aldobl2(c,ndet,ifil)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
c
c----------------------------------------------
c     rajout de c a ifil
c----------------------------------------------
c
      common/dim/iadri ; integer(8) iadri
      parameter (ngru3=2048)
      common/ver3/ ei(ngru3),itab(ngru3)
      dimension c(iadri)
      yw=.false.
      rewind ifil
      ifin=0
      if(yw) then
         do k=1,ndet
            write(6,'(a20,i6,f12.5)')'corr0',k,c(k)
         enddo
      endif
      do k=1,ndet,ngru3
         ideb=ifin+1
         ifin=min(ideb-1+ngru3,ndet)
         long=ifin-ideb+1
         call lir8(ei,long,ifil)
         do l=ideb,ifin
            ll=l-(k-1)
            c(l)=c(l)+ei(ll)
            if(yw) write(6,'(a20,i6,f12.5)')'corr1',l,ei(ll)
         enddo
      enddo
      rewind ifil
      if(yw) then
         do k=1,ndet
            write(6,'(a20,i6,f12.5)')'corrtot',k,c(k)
         enddo
      endif
      call ecr8bl(c,ndet,ifil)
      return
      end
       subroutine conformh
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter (maxda3=300,maxorbcas=16)
      parameter(maxref=15000)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      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
      dimension it(2),ip(2)
      dimension ica(maxorbcas),icb(maxorbcas)
      dimension iocref(maxorbcas,maxref),iocc(maxorbcas)
      data iconfh /1/
      yw=.false.
      if(iconfh.eq.0) return
      iconfh=0
c
      call trad(neh,ith,iph,nca,ica,ncb,icb,nt,it,ispt,np,ip,
     *ispp,ierr)
      write(75,*)'nad ith,iph',(ith(k),k=1,neh),(iph(k),k=1,neh)
     *,'$'
      call scril
          nta=(nt+ispt)/2
          npa=(np+ispp)/2
           write(75,*)
     *   ' trou',(iorb(it(k)),k=1,nta),(-iorb(it(k)),k=nta+1,nt),
     *   ' CAS',(ica(k),k=1,nca),(-icb(k),k=1,ncb),
     *   ' part',(iorb(ip(k)),k=1,npa),(-iorb(ip(k)),k=npa+1,np)
     *   ,' $'
         call scril
      if(nt.ne.0.or.np.ne.0) then
         print*,'le determinant habilleur n''est pas dans le CAS'
         stop
      endif
      if(gener(1:2).eq.'MR'.and.gener(1:3).ne.'MRT') then
         open(50,form='formatted',file='OCCMRS',status='old')
         read(50,*) nmr
         do k=1,nmr
            read(50,'(80i1)')(iocref(i,k),i=1,noac)
            if(yw)print*,'iocref',(iocref(i,k),i=1,noac)
         enddo
         close (50)
         do k=1,noac
            iocc(k)=0
         enddo
         do k=1,nca
            iocc(itorbc(ica(k)))=1
         enddo
         do k=1,ncb
            iocc(itorbc(icb(k)))=iocc(itorbc(icb(k)))+1
         enddo
         if(yw)print*,'iocc',(iocc(i),i=1,noac)
         do iref=1,nmr
            do k=1,noac
               if(iocc(k).ne.iocref(k,iref)) goto 1
            enddo
            goto 2
 1          continue
         enddo
         print*,'le determinant habilleur n''est pas une reference'
         stop
 2       continue
      endif
      return
      end
 
