      subroutine sc2(esp1,iesp,iesp2,yesp,ndet,ierr)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      parameter (maxda3=300)
      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
c     common/files/det,info
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      dimension esp1(iadri*2),iesp(iadri*2),yesp(iadri*8)
      integer*2 iesp2(iadri*8)
      common/test/itest(100)
      yw=.false.
      write(6,*)' '
      write(6,*)'           #####   #####   #####'
      write(6,*)'          #     # #     # #     #'
      write(6,*)'          #       #             #'
      write(6,*)'           #####  #        #####'
      write(6,*)'                # #       #'
      write(6,*)'          #     # #     # #'
      write(6,*)'           #####   #####  #######'
      write(6,*)' '
      nv2=norb-noca
      norbs=norb*2
      nocas=noca*2
      nvs=nv2*2
      conv=10.d0**(-ipresc)
      write(6,*)' *******SC2 maxith',maxith,'       conv',conv,'  ****'
c--   ouverture fichier temporaire pour stocker la 1ere diagonale
      open(29,file='BID29',form='UNFORMATTED')
c--   lecture du vecteur propre
      rewind 11
      read(11)nicdi,metat
      read(11) e0
      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--   iteration d'habillage
      iprec0=iprec
      do 1 iterh=1,maxith
c--   on remet la precision a la valeur demandee
      if(itest(36).eq.1) then
         iprec=iprec0+ihprec-ihprec/(iterh+iterh)
      else
         if(iterh.eq.1) then
            iprec=iprec0
         else
            print*,'del',del
            prec=-log10(dabs(del/100))
            print*,'prec',prec
            iprec=prec
            iprec=max(iprec,iprec0)
            iprec=min(iprec,iprec0+ihprec)
         endif
      endif
      noczz=nocas*(nocas+1)/2
      nvzz=nvs*(nvs+1)/2
      i2=noczz+1
      i3=i2+nvzz
      i4=i3+nocas*nvs
      i5=i4+noczz*nvs
      i6=i5+nocas*nvzz
      write(6,*)'dimension tot des tableaux de sc2',i6
      i6=max0(ndet,i6)
      i7=i6+ndet
      ierr=0
      write(6,1000) iterh
 1000 format(//,70('*'),/,20x,'ITERATION HABILLAGE',i3,/,70('*'))
      call verdim('depassement sc2    tableaux   iadri*2  ',i7,iadri*2)
      if(ytana)write(6,*)'appel sc2'
      call sc2ci(esp1,esp1(i2),esp1(i3),esp1(i4),esp1(i5)
     *,esp1(i6),esp1
     *,nocas,noczz,nvs,nvzz)
      if(ytana)write(6,*)'appel david'
      call david(esp1,esp1(nicdi+1),iesp,iesp2,yesp)
c--   test d'arret
      rewind 11
      read(11)nicdi,metat
      read(11) e
      write(6,'('' energie a l iteration     '',f12.8)') e
      del=e-e0
      write(6,'('' DELTAE'',f10.6)') del
      e0=e
      if(dabs(del).lt.conv) then
         write(6,'(''CONVERGENCE HABILLAGE ATTEINTE ENERGIE'',F12.8)') e
c        if(ywvec) call wvec(esp1,esp2)
c         stop
         return
      endif
      if(yw)write(6,*)'nicdi,metat',nicdi,metat
 1    continue
      write(6,*)'NON CONVERGE'
      stop
      end
       subroutine sc2ci(ect,ecp,ectp,eoov,eovv,
     *c,hoi,nocz,noczz,nvz,nvzz)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (nexci=2,ngru3=2048)
c      parameter (nvz=120,nocz=20)
c      parameter (noczz=nocz*(nocz+1)/2)
c      parameter (nvzz=nvz*(nvz+1)/2)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      logical verif
      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/csc2/ nicdi,nv2,norbs,nocas,nvs,ii28,itptp1,itptp2
      dimension it(2),ip(2)
      dimension ect(noczz),ecp(nvzz),ectp(nocz,nvz)
      dimension eoov(noczz,nvz),eovv(nocz,nvzz)
      dimension nt(2),np(2)
      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
      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
c      common/espa/ c(iadri),hoi(iadri)
      dimension c(nicdi),hoi(nicdi)
      common /ijd/itab,jtab,dtab
      dimension ITAB(2048),JTAB(2048)
      DIMENSION DTAB(2048)
      real*4 dtab
      ia(i)=i*(i-1)/2
      yw=.false.
      yw1=.false.
      if(yw)print*,'entree sc2ci'
      if(yw)write(6,*) 'norb,noca,nicdi',norb,noca,nicdi
C------------------------------------------------------------
C       relecture des coefficients de l'IC et denormalisation
C------------------------------------------------------------
      verif=.false.
      rewind 11
      read(11)
      read(11)
      read(11) (hoi(i),i=1,nicdi)
      call reocip(hoi,c,itab,nicdi,1)
c     call lire(c,1,nicdi,21)
      if(yw) then
         do kkk=1,nicdi
            write(6,'('' c'',f12.8,i8)') c(kkk),kkk
         enddo
      endif
      if(yw1)WRITE(6,*)'COEF FONDA = ',C(1)
      c0=c(1)
      do i=1,nicdi
         c(i)=c(i)/c0
      end do
C------------------------------------------------------------
cc--   on stocke le vecteur denormalise
cC------------------------------------------------------------
c      open(59,status='unknown',file='BID59',form='UNFORMATTED')
c      call ecrr(c,nicdi,59)
c----------------------------------------------------
c     extraction de la 1ere colonne et stockage dans hoi
c----------------------------------------------------
      open(42,file='CDI_3311',status='OLD',form='UNFORMATTED')
      if(yw)write(6,*)'l3311,le3311',l3311,le3311
      if(yw)write(6,*)'i3311,ie3311',i3311,ie3311
      do ln=1,l3311+1
         call lirin4(inti,intj,intk,intl,aaint,42)
c         read(42)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.l3311+1) lfini=i3311
         do in=1,lfini
            it(1)=inti(in)
            it(2)=intj(in)
            ip(1)=intk(in)
            ip(2)=intl(in)
            if(yw)write(6,*)'it,ip',it,ip
            a=aaint(in)
            if(yw1)call wrdet(0,0,ica,icb,1,1,it(1),
     *      it(2),1,1,ip(1),ip(2))
            call adrdet(0,ica,0,icb,2,it,0,2,ip,0,iadr,
     *      mhdum,mtdum)
            if(yw1)write(6,*)'iadr,a',iadr,a
            hoi(iadr)=a
            if(it(1).ne.it(2).or.ip(1).ne.ip(2)) then
               iii=it(1)
               it(1)=it(2)
               it(2)=iii
               iii=ip(1)
               ip(1)=ip(2)
               ip(2)=iii
               if(yw1)call wrdet(0,0,ica,icb,1,1,it(1),
     *         it(2),1,1,ip(1),ip(2))
               call adrdet(0,ica,0,icb,2,it,0,2,ip,0,iadr,
     *      mhdum,mtdum)
               if(yw1)write(6,*)'iadr,a',iadr,a
               hoi((iadr))=a
            endif
         enddo
      enddo
      close(42)
      open(42,file='CDE_3311',status='OLD',form='UNFORMATTED')
      do ln=1,le3311+1
         call lirin4(inti,intj,intk,intl,aaint,42)
c         read(42)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.le3311+1) lfini=ie3311
         do in=1,lfini
            it(1)=inti(in)
            it(2)=intj(in)
            ip(1)=intk(in)
            ip(2)=intl(in)
            call reor(2,it,isgnt)
            call reor(2,ip,isgnp)
            if(yw)write(6,*)'it,ip',it,ip
            a=aaint(in)*isgnt*isgnp
            if(yw1)call wrdet(0,0,ica,icb,2,0,it,
     *      idum,2,0,ip,idum)
            call adrdet(0,ica,0,icb,2,it,2,2,ip,2,iadr,
     *      mhdum,mtdum)
            hoi(iadr)=a
            call adrdet(0,ica,0,icb,2,it,-2,2,ip,-2,iadr,
     *      mhdum,mtdum)
            if(yw1)write(6,*)'iadr,a',iadr,a
            hoi(iadr)=a
         enddo
      enddo
      close(42)
      if(yw)write(6,*)' '
      do jj=1,noca
         it(1)=jj
         isgn=1-2*mod(noca-it(1),2)
         do ja=noca+1,norb
            ip(1)=ja
            if(its(itsym(it(1)),itsym(ip(1))).ne.is0) goto 10
            if(yw)write(6,*)'ip(1),ia(ip(1)),it(1),f',ip(1)
     *      ,ia(ip(1)),it(1),f(ia(ip(1))+it(1))
            call adrdet(0,ica,0,icb,1,it(1),1,1,ip(1),1,iadr,
     *      mhdum,mtdum)
            hoi(iadr)=f(ia(ip(1))+it(1))*isgn
            if(yw1)write(6,*)'iadr,f',iadr,
     *      hoi(iadr)
            call adrdet(0,ica,0,icb,1,it(1),-1,1,ip(1),-1,iadr,
     *      mhdum,mtdum)
            hoi(iadr)=f(ia(ip(1))+it(1))*isgn
            if(yw1)write(6,*)'iadr,f',iadr,
     *      hoi(iadr)
 10         continue
         enddo
      enddo
      rewind 25
      read(25) hoi(1)
      if(yw) then
         do kkk=1,nicdi
            write(6,'('' hoi'',f12.8,i8)') hoi(kkk),kkk
         enddo
      endif
c----------------------------------------------------
c     hoi contient la premiere colonne de la matrice
c----------------------------------------------------
c
c----------------------------------------------------
c     on met hoi*c dans c
c----------------------------------------------------
c
      do i=1,nicdi
         c(i)=hoi(i)*c(i)
      enddo
c----------------------------------------------------
c     hoi*c est remis au signe cipsi (on ecrase hoi
c     pour avoir de l'espace
c----------------------------------------------------
c
      call sgncip(c,hoi,nicdi)
c
c----------------------------------------------------
C     calcul de Evar
c----------------------------------------------------
c
      evar=0.d0
      do  i=1,nicdi
         evar=evar+c(i)
c        if(yw)write(6,*) i,c(i),hoi(i),evar
      end do
      if(yw)write(6,*) 'evar',evar
C
C-----------------------------------------------------------------------
C     boucle sur les determinants pour construire ect,ecp,ectp,eoov,eovv
C-----------------------------------------------------------------------
C
      if(yw)write(6,*)'nocas,nvs',nocas,nvs
      do i=1,nocas*(nocas+1)/2
         ect(i)=0.d0
      end do
      do i=1,nvs*(nvs+1)/2
         ecp(i)=0.d0
      end do
      do i=1,nocas
         do j=1,nvs
            ectp(i,j)=0.d0
         end do
      end do
C
      do i=1,nocas*(nocas+1)/2
         do j=1,nvs
            eoov(i,j)=0.d0
         end do
      end do
C
      do i=1,nocas
         do j=1,nvs*(nvs+1)/2
            eovv(i,j)=0.d0
         end do
      end do
C
      call rew61
      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(ne.eq.2) then
            dum=c(i)
            it1=nt(1)
            it2=nt(2)
            ip1=np(1)-noca
            ip2=np(2)-noca
            if(it1.gt.norb)it1=it1-nv2
            if(it2.gt.norb)it2=it2-nv2
            if(ip1.gt.norb)ip1=ip1-noca
            if(ip2.gt.norb)ip2=ip2-noca
            it11=ia(it1)+it1
            it22=ia(it2)+it2
            ip11=ia(ip1)+ip1
            ip22=ia(ip2)+ip2
            if(it1.gt.it2) then
               it12=ia(it1)+it2
            else
               it12=ia(it2)+it1
            end if
            if(ip1.gt.ip2) then
               ip12=ia(ip1)+ip2
            else
               ip12=ia(ip2)+ip1
            end if
            ect(it11)=ect(it11)+dum
            ect(it22)=ect(it22)+dum
            ect(it12)=ect(it12)+dum
            ecp(ip11)=ecp(ip11)+dum
            ecp(ip22)=ecp(ip22)+dum
            ecp(ip12)=ecp(ip12)+dum
            ectp(it1,ip1)=ectp(it1,ip1)+dum
            ectp(it2,ip1)=ectp(it2,ip1)+dum
            ectp(it1,ip2)=ectp(it1,ip2)+dum
            ectp(it2,ip2)=ectp(it2,ip2)+dum
            eoov(it12,ip1)=eoov(it12,ip1)+dum
            eoov(it12,ip2)=eoov(it12,ip2)+dum
            if(yw)write(6,4000)'it1,ip12,eovv,dum',it1,ip12,
     *      eovv(it1,ip12),eovv(it1,ip12)+dum
 4000       format(a20,2i5,2f12.8)
            eovv(it1,ip12)=eovv(it1,ip12)+dum
            if(yw)write(6,4000)'it2,ip12,eovv,dum',it2,ip12,
     *      eovv(it2,ip12),eovv(it2,ip12)+dum
            eovv(it2,ip12)=eovv(it2,ip12)+dum
         end if
      end do
      if(yw) then
         write(6,*) ' ect'  ,(ect(i),i=1,nocas*(nocas+1)/2)
         write(6,*) ' ecp'  ,(ecp(i),i=1,nvs*(nvs+1)/2)
         write(6,*) ' ectp'  ,((ectp(i,j),i=1,nocas),j=1,nvs)
         write(6,*) ' eoov'  ,((eoov(i,j),i=1,nocas*(nocas+1)/2),j=1,nvs
     &   )
         write(6,*) ' eovv'  ,((eovv(i,j),i=1,nocas),j=1,nvs*(nvs+1)/2)
      end if
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
      do i=1,nicdi
         ii=ii+1
         hii=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,*)'nt,np',(nt(k),k=1,ne),(np(k),k=1,ne)
         if(ne.eq.2) then
            hii=evar
            if(yw)write(6,*)'hii1',hii
            it1=nt(1)
            it2=nt(2)
            ip1=np(1)-noca
            ip2=np(2)-noca
            if(it1.gt.norb)it1=it1-nv2
            if(it2.gt.norb)it2=it2-nv2
            if(ip1.gt.norb)ip1=ip1-noca
            if(ip2.gt.norb)ip2=ip2-noca
            it11=ia(it1)+it1
            it22=ia(it2)+it2
            ip11=ia(ip1)+ip1
            ip22=ia(ip2)+ip2
            if(it1.gt.it2) then
               it12=ia(it1)+it2
            else
               it12=ia(it2)+it1
            end if
            if(ip1.gt.ip2) then
               ip12=ia(ip1)+ip2
            else
               ip12=ia(ip2)+ip1
            end if
            hii=hii-ect(it11)-ect(it22)-ecp(ip11)-ecp(ip22)
     *      +ect(it12)+ecp(ip12)
     *      +ectp(it1,ip1)+ectp(it1,ip2)
     *      +ectp(it2,ip1)+ectp(it2,ip2)
     *      -(eoov(it12,ip1)+eoov(it12,ip2)
     *      +eovv(it1,ip12)+eovv(it2,ip12))
     *      +c(i)
            if(yw) then
               write(6,*)'i,hii2',i,hii
               write(6,*)-ect(it11)-ect(it22)-ecp(ip11)-ecp(ip22)
               write(6,*)+ect(it12)+ecp(ip12)
               write(6,*)+ectp(it1,ip1)+ectp(it1,ip2)
               write(6,*)+ectp(it2,ip1)+ectp(it2,ip2)
               write(6,*)-(eoov(it12,ip1)+eoov(it12,ip2))
               write(6,*)+eovv(it1,ip12)+eovv(it2,ip12)
               write(6,*)+c(i)
            endif
         else if(ne.eq.1) then
            hii=evar
            if(yw)write(6,*)'hii3',hii
            it1=nt(1)
            ip1=np(1)-noca
            if(yw)write(6,*)'it1,ip1',it1,ip1
            if(it1.gt.norb)it1=it1-nv2
            if(ip1.gt.norb)ip1=ip1-noca
            if(yw)write(6,*)'it1,ip1',it1,ip1
            it11=ia(it1)+it1
            ip11=ia(ip1)+ip1
            if(yw)write(6,*)'it11,ip11',it11,ip11
            if(yw)write(6,*)'ect(it11),ecp(ip11)',ect(it11),ecp(ip11)
            hii=hii-ect(it11)-ecp(ip11)
     *      +ectp(it1,ip1)
            if(yw)write(6,*)'hii4',hii,ectp(it1,ip1)
         end if
         ei(ii)=hii
         if(yw)write(6,*)'i,ei',i,ei(i)
         if(ii.eq.ngru3) then
            write(42) ei
            ii=0
         endif
      end do
      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
      if(iterh.eq.1) then
         rewind 25
c           write(6,*)'avant lir8bl'
         call lir8bl(hoi,nicdi,25)
c           write(6,*)'avant ecr8bl'
         call ecr8bl(hoi,nicdi,29)
c           write(6,*)'apres ecr8bl'
      else
         rewind 29
c           write(6,*)'avant lir8bl'
         call lir8bl(hoi,nicdi,29)
c           write(6,*)'apres lir8bl'
      endif
      if(yw) then
         do kkk=1,nicdi
            write(6,'('' diagon lue'',f12.8,i8)') hoi(kkk),kkk
         enddo
      endif
c--      on corrige la diagonale en lisant les corrections sur 42
c        et on met la diagonale corrigee dans hoi
      ii=0
      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,nicdi
                  write(6,'('' ei '',f12.8,i8)') ei(kkk),kkk
               enddo
            endif
         endif
         ii=ii+1
         hoi(i)=hoi(i)+ei(ii)
      enddo
      if(yw) then
         do kkk=1,nicdi
            write(6,'('' diagon corrigee '',f12.8,i8)') hoi(kkk),kkk
         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
      rewind 25
      call ecr8bl(hoi,nicdi,25)
c        calcul de ecor
      ecor=0.d0
      rewind 42
c      rewind 61
c      ii=0
c      if(yw) then
c         do i=1,nicdi
c            read(61) ne
c            if(ne.ne.0) read(61)
c            if(mod(ii,ngru3).eq.0) then
c               read(42) ei
c               ii=0
c            endif
c            ii=ii+1
c            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         enddo
c         write(6,*) 'EVAR=',evar,'VAL. MOYEN DE V TILDA SUR LES DI
c     *   ',ecor
c      endif
      close(42,status='DELETE')
      end
