      subroutine david4(B,iesp,AB,alam,THR,maxdav,maxda2,
     *NVEC,NITER,yesp,ytana)
C*************************
C
C     diagONALIZATION SUBROUTINE FOR LARGE SYMMETRIC MATRICES
C     E. R. DAVIDSON, J. COMP. PHYS 17, 87 (1975)
C
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      PARAMETER (ngru3=2048,maxorbcas=16)
      include 'maxorb.prm'
      parameter (maxda3=300)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c    |      yesp                     |
c
      dimension yesp(*)
      common/dim/iadri ; integer(8) iadri
      DIMENSION B(MAXDAV),AB(MAXDAV),iesp(maxdav*2),
     *diag(ngru3)
      dimension bab1(maxda3,maxda3)
      DIMENSION BAB(maxda3,maxda3),H(maxda3,maxda3),
     *alpha(maxda3,maxda3),alam(maxda3),p(maxda3)
      DIMENSION GUESS(maxda3*2,maxda3),ORTH(maxda3*2,maxda3),
     *GSYM(maxda3*2)
      COMMON /GAO/ GUESS,ORTH,GSYM,NGAO,NORTH
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /ijd/itab,jtab,dtab
      dimension itab(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      dimension sumq(maxda3)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sui/isuiv
      common/pert/schift,damp,ypertu,ycaspert
      common/pr/nprint,mprint(10)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/tps/ icpu(10)
      common /stoc/ jint,jnb(1024),jnb1
     *,iter,lonstc,maxstc,ystc,ystit1
      character*132 temps
      character*40 temps2
      character*40 form
      common/stp/stop
      character*8 stop
      common/pbconv/ coef0
      common/polspicom/ypolspi
      yw=.false.
      if(nvec.gt.1) then
         print*,' '
         print*,'La premiere energie est l''energie absolue'
         print*,'les valeurs suivantes sont les differences'//
     *   ' par rapport a la premiere'
      endif
      write(6,*)'ITER  M'
      call flush(6)
c----------------------------------
c     mises a zero
c----------------------------------
      icpu(1)=itemps(idum)
      lonstc=0
      jnb1=0
      icalc1=0
      m=nvec
      !ncv=0
      do kk=1,nvec
         ycvl(kk)=.false.
      enddo
      ITER=0
      m0=0
      m2=nvec
c-----------------------------------------
c     boucle sur les iterations
c-----------------------------------------
      do 200 iter1=1,niter
      iter=iter+1
c-----------------------------------------
c     appel H*Psi0
c-----------------------------------------
      if(mprint(5).eq.1) then
         do kk=m0+1,m
            call scrida('b avant mulmc$',b,ndet,21,kk)
         enddo
      endif
      if(itest(81).eq.m)call sauvcd(b,ndet,ab,ab(iadri/2+1))
c      print*,'avant mulmc2'
      call mulmc2(b,iesp,iter,nvec)
      if(mprint(5).eq.1) then
         do kk=m0+1,m
            call scrida('ab apres mulmc$',ab,ndet,22,kk)
         enddo
      endif
      if(ypolspi) then
         do kk=m0+1,m
            call lire(ab,kk,ndet,22)
            call polspi(ab,ndet)
            call ecr(ab,kk,ndet,22)
         enddo
      endif
      if(itest(82).eq.m) then
         call lire(ab,m,ndet,22)
         call sauvcd(ab,ndet,b,b(iadri/2+1))
      endif
      if(itest(80).ne.0) then
         do l=1,m
            anorm=0.d0
            rewind 87
            call lire(b,l,ndet,22)
            kk=2048
            do k=1,ndet
               kk=kk+1
               if(kk.eq.2049) then
                  kk=1
                  call liri(itab,2048,87)
               endif
               if(itab(kk).gt.itest(80)) b(k)=0.d0
               anorm=anorm+b(k)*b(k)
            enddo
            anorm=dsqrt(anorm)
c           print*,'anorm',anorm
            call ecr(b,l,ndet,22)
         enddo
      endif
      !if(itest(82).eq.m)call sauvcd(ab,ndet)
c      print*,'apres mulmc2'
c-----------------------------------------
c     calcul de l'hamiltonien effectif
c-----------------------------------------
      DO 60 L=1,M
      call lire(b,l,ndet,21)
      DO 60 LL=1,L
      BABL=0.d0
      call lire(ab,ll,ndet,22)
      DO 50 J=1,ndet
   50 BABL=BABL+B(J)*AB(J)
      BAB(LL,L)=BABL
   60 BAB(L,LL)=BABL
      if(mprint(4).eq.1) then
         write(6,*)'Heff'
         call SCRIPT(bab,m,m,maxda3,maxda3)
c        write(6,'('' alam avant riera'',4f8.4)')(alam(kk),kk=1,m)
      endif
c-----------------------------------------------
c     diagonalisation de l'hamiltonien effectif
c-----------------------------------------------
c     suivi de vecteurs : preparation avant diagonalisation
      if(isuiv.ne.0.and.m.gt.nvec) then
         do ii=1,nvec
            do kk=1,m
               bab1(kk,ii)=alpha(kk,ii)
            enddo
         enddo
         if(nprint.ge.2) then
            print*,'ancien vecteur'
            call script(bab1,m,nvec,maxda3,maxda3)
         endif
      endif
c     diagonalisation
      do k1=1,m
         do k2=1,m
            h(k2,k1)=bab(k2,k1)
         enddo
      enddo
      CALL RIERA(M,bab,alpha,alam,P,maxda3,ierr)
      if(ierr.eq.1) then
         print*,'...diagonalisation JACOBI'
         call hdiag(h,alpha,m,maxda3)
         do kk=1,m
            alam(kk)=h(m+1-kk,m+1-kk)
         enddo
         do kk=1,m/2
            do i=1,m
               vv=alpha(i,kk)
               alpha(i,kk)=alpha(i,m+1-kk)
               alpha(i,m+1-kk)=vv
            enddo
         enddo
      endif
c     suivi de vecteurs : apres diagonalisation
      if(isuiv.ne.0.and.m.gt.nvec) call davsuiv2
     *(alpha,alam,m,nvec,isuiv,bab1,mv)
      if(mprint(4).eq.1) then
         write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,m)
         write(6,*)'Veff'
         call SCRIPT(alpha,m,m,maxda3,maxda3)
c        write(6,*)'k',k
c        if(k.gt.1)write(6,*)'k,alpha(k,k),alpha(kk,k-1)',
c    *   k,alpha(k,k),(alpha(kk,k-1),kk=1,k-2)
      endif
   75 continue
c---------------------------------------------
c     test de convergence
c---------------------------------------------
      icpu1=itemps(idum)
      call dav4conv(b,ab,m,nvec,alam,alpha,sumq,ycv,thr,ncv)
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         write(6,*)'dav4conv      cpu',icpu2
      endif
c---------------------------------------------
c     ecriture des energies a cette iteration
c---------------------------------------------
      if(iter.eq.1.or.M.gt.nvec) then
         icpu(1)=itemps(idum)-icpu(1)
         icpu1=icpu(1)
         if(icpu1.eq.0) icpu1=1
         longt2=int(log10(float(icpu1)))+2
         write(form,15)'(a5,i',longt2,',a4)'
         write(temps2,form) '  cpu',icpu(1),' sec'
         icpu(1)=itemps(idum)
         if(nvec.le.5) then
            write(temps,14)iter,alam(1)+enuc+eref,
     *      (alam(kk)-alam(1),kk=2,min(5,nvec))
            longt=min(5,nvec)*14+9
            write(6,'(a)') temps(1:longt)//temps2(1:longt2+10)
         else
            write(6,14) iter,alam(1)+enuc+eref,
     *      (alam(kk)-alam(1),kk=2,min(5,nvec))
         endif
         write(6,12) m,(sumq(kk),kk=1,min(5,nvec))
         ifin=5
         do k=6,nvec-5,5
            ideb=ifin+1
            ifin=min(ideb+4,nvec)
            write(6,11)(alam(kk)-alam(1),kk=ideb,ifin)
            write(6,121)(sumq(kk),kk=ideb,ifin)
         enddo
         if(nvec.gt.5) then
            ideb=ifin+1
            ifin=min(ideb+4,nvec)
            write(temps,11)(alam(kk)-alam(1),kk=ideb,ifin)
            longt=mod(nvec,5)*14+9
            if(longt.eq.9) longt=79
            write(6,'(a)') temps(1:longt)//temps2(1:longt2+10)
            write(6,121)(sumq(kk),kk=ideb,ifin)
         endif
         write(6,*)' '
      endif
11    format(9x,5F14.9)
14    format('##',i4,f17.9,4F14.9)
 13   format(a4,i8,a4)
12    format(i6,3x,5D14.2)
121   format(9x,5D14.2)
 15   format(a5,i1,a4)
      call flush(6)
c-------------------------------------------------
c     on interromp le processus dans quelques cas
c-------------------------------------------------
c...  si convergence
      IF (ycv) GO TO 210
c...
c...  si l'hamiltonien effectif devient trop grand
c      IF (M+nvec-ncv.Gt.MAXDA2) goto 210
c...
c...  si on a fait toutes les iterations
      IF (iter.eq.niter) goto 210
c----------------------------------------------------
c     on calcule PSI et H*PSI (b,ab) comme combinaisons
c     lineaires des vecteurs de chaque iteration
c----------------------------------------------------
      if(m.gt.nvec) then
         yecr=m+nvec-ncv.gt.maxda2
         !print*,'yecr',yecr,m,nvec,ncv,maxda2
         icpu1=itemps(idum)
         call davregrou(alpha,alam,m,nvec,isuiv,bab1,b,b,ab,ab,yecr
     *   ,yesp,mv,iter)
         if(ytana) then
            icpu2=itemps(idum)-icpu1
            write(6,*)'davregrou     cpu',icpu2
         endif
         if(yecr) m=nvec
      endif
      icpu1=itemps(idum)
c----------------------------------------------------
c     calcul des vecteurs Psi(m+1)
c----------------------------------------------------
      m0=m
      icpu1=itemps(idum)
      do k=1,nvec
         if(ycvl(k)) goto 155
         iq=0
c        on lit le vecteur (H-E)*PSI
         call lire(ab,k,ndet,23)
         rewind 25
         nsh=0
         nlimit=0
c        boucle sur les blocs de det pour le calcul de (H-E)*PSI/DeltaE
         do ii=1,ndet,ngru3
            if(iq+ngru3.gt.ndet) then
               ilong=ndet-iq
            else
               ilong=ngru3
            endif
            call lir8(diag,ilong,25)
c           boucle sur les det du bloc
            DO I=1,ilong
               iq=iq+1
c               write(6,'('' david diag '',2f12.8,i8)')
c     *         ab(iq),diag(i),iq
               IF (DABS(ab(Iq))-coef0) 95,95,97
   95          ab(Iq)=0.d0
               GO TO 100
 97            continue
               if(alam(K)-diag(I).gt.-1.d-5) then
                  nsh=nsh+1
c                   print'(a,2i6,f12.8)',
c      *            'alam(K)-diag(I)',k,i,alam(K)-diag(I)
c                  if(dabs(alam(K)-diag(I)).lt.1.d-5) then
c                     ab(Iq)=ab(Iq)/(-1.d-5)
c                  else
c                     ab(Iq)=ab(Iq)/(-alam(K)+diag(I))
c                  endif
c                  if(dabs(ab(iq)).gt.1.d0) then
c                     ab(iq)=1.d0
c                     nlimit=nlimit+1
c                  endif
                  ab(Iq)=ab(Iq)/(-1.d-5)
               else
                  ab(Iq)=ab(Iq)/(alam(K)-diag(I))
               endif
  100          CONTINUE
c               write(6,'('' david ab '',f12.8,i8)')ab(iq),iq
            enddo
         enddo
c     ab contient le nouveau vecteur Psi
         if(itest(72).eq.1)call syspin12(ab,ndet)
         if(nprint.ge.1) then
            if(nsh.ne.0) then
               write(75,*) 'Vecteur',k,' : ',nsh,' denominateurs',
     *         ' modifies$'
               call scril
            endif
            if(nlimit.ne.0) then
               write(75,*)
     *         'Vecteur',k,' : ',nlimit,'  coefficients limites a 1$'
               call scril
            endif
         endif
c----------------------------------------------
c     calcul perturbatif (modifs marie 10-2-00)
c----------------------------------------------
         if(ypertu) then
            nbschift=0
            schifmax=0.d0
            call lire(ab,1,ndet,22)
            call lire(b,1,ndet,21)
            do kk=1,ndet
c            print'(a10,3f10.6,i6)',
c     *      'marie b ab',b(kk),ab(kk),ab(kk)-b(kk)*alam(K),kk
            enddo
            rewind 25
            iq=0
            kk=0
            e2=0.d0
            do 990 ii=1,ndet,ngru3
            if(iq+ngru3.gt.ndet) then
               ilong=ndet-iq
            else
               ilong=ngru3
            endif
            iq=iq+ngru3
            call lir8(diag,ilong,25)
            do i=1,ilong
               kk=kk+1
               ab(kk)=ab(kk)-b(kk)*alam(K)
c            print'(a20,2f10.6,i6)','marie ab,dele',
c     *         ab(kk),(alam(K)-diag(i)),kk
               den=-(alam(K)-diag(i))
               if(schift.gt.0.d0) then
                  if(den.gt.schift) then
                     den=schift
                     nbschift=nbschift+1
                     schifmax=den-0.1
                  endif
               endif
               if(dabs(ab(kk)).gt.1.d-8) ab(kk)=-ab(kk)/den
               ab(kk)=ab(kk)*damp
c            print'(a20,2f10.6)','marie ab',
c     *         ab(kk)
               e2=e2-ab(kk)*ab(kk)*den
               if(alam(K)-diag(i).gt.0d0)print*,'kk,alam,diag',
     *         kk,alam(k),diag(i)
 2222          format(a6,i5,6f10.6)
            enddo
 990        continue
            print*,'*******************************************'
            print*,'  ENERGIE PERTURBATIVE',e2
            print*,'  ENERGIE ORDRE ZERO  ',enuc+eref+alam(k)
            print*,'  ENERGIE TOTALE      ',e2+enuc+eref+alam(k)
            print*,'*******************************************'
            do kk=1,ndet
               ab(kk)=ab(kk)+b(kk)
            enddo
            call ecr(ab,1,ndet,21)
            sum = 0.d0
c         write(6,*)'coucou'
c         call lire(ab,1,ndet,22)
            do  kk = 1,ndet
               sum = sum + ab(kk)*ab(kk)
            end do
            print *, ' david4 pertu norme =',sum
            sum = 1.d0/dsqrt(sum)
            do kk=1,ndet
c         print*,'kk,ndet,maxdav',kk,ndet,maxdav
               ab(kk) = ab(kk)*sum
            end do
            call dens(ab)
c         call wvec(ab,iesp,yesp)
            return
            if(nbschift.ne.0) then
               print*,'ATTENTION, level schift applique',nbschift,' fois
     &         '
               print*,'a cause de denominateur trop petit'
               print*,'Schift maximal : ',schifmax
            endif
         endif
c-------------------
c  fin modifs marie
c-------------------
c
c--------------------------------------------------
c     orthogonalisation de b(m+1) aux b(1)...b(m)
c--------------------------------------------------
c            do kkk=1,ndet
c            write(6,'('' david ab,m '',f12.8,2i8)')ab(kkk),kkk,m
c            enddo

         ! normalisation du nouveau vecteur ab
         SUM=0.d0
         DO I=1,ndet
            SUM=SUM+ab(I)*ab(I)
         enddo
         sum=dsqrt(sum)
         if(mprint(5)==1)print*,'norme ab',sum,'   vecteur numero',k
         DO I=1,ndet
            ab(I)=ab(I)/sum
         enddo

         ! Orthogonalisation de ab aux vecteurs precedents
         do iterorthog=1,10
            DO  L=1,M
               call lire(b,l,ndet,21)
               SUM=0.d0
               DO I=1,ndet
                  SUM=SUM+B(I)*ab(I)
               enddo
               DO I=1,ndet
                  ab(I)=ab(I)-SUM*B(I)
               enddo
            enddo
c               do kkk=1,ndet
c               write(6,'('' david ab, m '',f12.8,2i8)')ab(kkk),kkk,m
c               enddo
            SUM=0.d0
            DO I=1,ndet
               SUM=SUM+ab(I)*ab(I)
            enddo
            if(yw)print*,'m,sum',m,sum,thr
!            if(sum.lt.thr*thr*0.001) then
!               maxda2=min(m,maxda2)
!c            print*,'sum',sum
!               print*,' l''Espace est de dimension',m
!               goto 156
!            endif
            M=M+1
            SUM2=1.d0/DSQRT(SUM)
            DO I=1,ndet
               B(I)=SUM2*ab(I)
            enddo
            if(sum>1.d-6) exit
            ab=b
            print*,'le nouveau vecteur est lineairement dependant'//
     *      ' aux precedents : reorthogonalisation'
            M=M-1
         enddo
         call ecr(b,m,ndet,21)
 155     continue
      enddo
 156  continue
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         write(6,*)'Psi(m+1)      cpu',icpu2
      endif
c-------------------------
c     iteration suivante
c     produit H*Psi
c-------------------------
      if(mprint(1).eq.1) then
         do kk=m0+1,m
            call scrida('b avant mul1c$',b,ndet,21,kk)
         enddo
      endif
      m2=m
 210  continue
      if(ycv) goto 220
 200  continue
      iter=iter-1
      write(75,*) 'NON CONVERGE apres',iter,' iterations $'
      call scril
      stop='DEL'
 220  continue
      yecr=.true.
      icpu1=itemps(idum)
      call davregrou(alpha,alam,m,nvec,isuiv,bab1,b,b,ab,ab,yecr
     *,yesp,mv,iter)
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         write(6,*)'davregrou fin    cpu',icpu2
      endif
      return
      end
 
       subroutine davregrou(alpha,alam,m,nvec,isuiv,bab1,b1,b,ab,ab1,
     *yecr,yesp,mv,iter)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/dim/iadri ; integer(8) iadri
      dimension yesp(*)
      parameter (ngru3=2048,maxda3=300)
      include 'maxorb.prm'
      DIMENSION alpha(maxda3,maxda3)
      dimension bab1(maxda3,maxda3)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      character*3 calcul
      common/opt/ihab,calcul
      common/svfil/fil11
      character*40 fil11
      dimension b(ngru3,maxda3),ab(ngru3,maxda3),c(ngru3)
      dimension b1(iadri),ab1(iadri)
      dimension alam(maxda3)
      dimension ll0(maxda3)
      common /ijd/itab,jtab,dtab
      dimension itab(NGRU3),JTAB(NGRU3)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      real*4 DTAB(NGRU3)
      if(isuiv.ne.0.and.m.gt.nvec) call davsuiv2
     *(alpha,alam,m,nvec,isuiv,bab1,mv)
      do j=1,m
         ll0(j)=(j-1)*((ndet-1)/ngru3+1)
      enddo
      ilec=0
      do i=1,ndet,ngru3
         ilec=ilec+1
         long=min(ngru3,ndet-i+1)
         do j=1,m
            ll=ll0(j)+ilec
            call lirec(b(1,j),ll,long,21)
            call lirec(ab(1,j),ll,long,22)
         enddo
         do k=1,nvec
            do ii=1,long
               c(ii)=0.d0
               do l=1,m
                  c(ii)=c(ii)+alpha(l,k)*b(ii,l)
c                 print*,'ii,l',ii,l,c(ii),alpha(l,k),b(ii,l)
               enddo
            enddo
            ll=ll0(k)+ilec
            if(yecr)call ecric(c,ll,long,21)
            do ii=1,long
               c(ii)=0.d0
               do l=1,m
                  c(ii)=c(ii)+alpha(l,k)*ab(ii,l)
               enddo
            enddo
            if(yecr)call ecric(c,ll,long,22)
         enddo
      enddo
 
      open(99,file='LIDAVEC',form='unformatted',status='unknown')
      write(99) ndet,nvec
      write(99) (alam(kk),kk=1,nvec),enuc,eref
      write(99) m,iter,norb
      write(99) ((alpha(l,k),l=1,m),k=1,nvec)
      close(99)
 
 
 
      rewind 11
      write(11) ndet,nvec
      write(11) (alam(kk),kk=1,nvec),enuc,eref
      DO 1209 kk=1,NVEC
c      print*,'3kk',kk
      do i=1,ndet
         b1(i)=0.d0
      enddo
      call lire(ab,kk,ndet,21)
      if(calcul.eq.'MD') then
         if(itest(73).eq.0) call sgncip(b,yesp(8*iadri+1),ndet)
         call reocip(b,ab,itab,ndet,2)
         WRITE(11)(AB1(kkk),kkk=1,ndet)
      else
         WRITE(11)(B1(kkk),kkk=1,ndet)
      endif
c      print*,'2kk',kk
 1209 continue
      close(11)
      open(11,file=fil11,status='old',form='unformatted')
      if(yecr) then
c         iter=iter-1
      endif
      return
      end
       subroutine davsuiv2(alpha,alam,m,nvec,isuiv,bab1,mv)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      PARAMETER (maxda3=300,ngru3=2048,maxorbcas=16)
      include 'maxorb.prm'
      DIMENSION alpha(maxda3,maxda3),alam(maxda3)
      dimension bab1(maxda3,maxda3)
      common/pr/nprint,mprint(10)
      if(nprint.ge.2) then
         print*,'nouveaux vecteurs'
         call script(alpha,m,m,maxda3,maxda3)
      endif
      do ii=1,nvec
         rec=0.d0
         do kk=1,m
            sum=0.d0
            if(isuiv.eq.1) then
               do kkk=1,mv
                  sum=sum+bab1(kkk,ii)*alpha(kkk,kk)
               enddo
            else
               sum=alpha(1,kk)
            endif
            sum=dabs(sum)
            if(sum.gt.rec) irec=kk
            rec=max(rec,sum)
         enddo
         do kkk=1,m
            aaa=alpha(kkk,ii)
            alpha(kkk,ii)=alpha(kkk,irec)
            alpha(kkk,irec)=aaa
         enddo
         aaa=alam(ii)
         alam(ii)=alam(irec)
         alam(irec)=aaa
         if(nprint.ge.2) write(6,'('' rec max'',f10.6)') rec
      enddo
c     print*,'irec',irec
      if(irec.ne.nvec)
     *write(6,'('' alam'',10f8.4)')(alam(kkk),kkk=1,irec)
      return
      end
       subroutine dav4conv(b,ab,m,nvec,alam,alpha,sumq,ycv,thr,ncv)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter (ngru3=2048,maxda3=300)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      dimension alpha(maxda3,maxda3)
      dimension sumq(maxda3)
      dimension b(ngru3,maxda3),ab(ngru3,maxda3),c(ngru3)
      dimension alam(maxda3)
      dimension ll0(maxda3)
      dimension bsto(1000000),absto(1000000)
      do k=1,nvec
         sumq(k)=0.d0
      enddo
      do j=1,m
         ll0(j)=(j-1)*((ndet-1)/ngru3+1)
      enddo
      ilec=0
      do i=1,ndet,ngru3
         ilec=ilec+1
         long=min(ngru3,ndet-i+1)
         do j=1,m
            ll=ll0(j)+ilec
            call lirec(b(1,j),ll,long,21)
            call lirec(ab(1,j),ll,long,22)
c            do kkk=1,long,100
c               print'('' j,b(kkk,j),ab(kkk,j)'',i5,2f12.8)'
c     *          ,j,b(kkk,j),ab(kkk,j)
c            enddo
         enddo
         do k=1,nvec
            do ii=1,long
               c(ii)=0.d0
               do l=1,m
c                  if(ii.eq.1)print*,'ii',l,alam(k),b(ii,l),ab(ii,l),
c     *            ab(ii,l)-alam(k)*b(ii,l)
                  c(ii)=c(ii)+alpha(l,k)*(ab(ii,l)-alam(k)*b(ii,l))
c               print'('' c(ii)'',5f10.6,i10)',c(ii),
c     *         ab(ii,l),b(ii,l),alpha(l,k),alam(k),ii+i-1
               enddo
            enddo
!            print*,'Residus pour le vecteur',k
!            do kk=1,long
!               print'(f12.8)',c(kk)
!            enddo
            ll=ll0(k)+ilec
            call ecric(c,ll,long,23)
c            print*,'k,sumq(k)',k,sumq(k)
            do ii=1,long
               sumq(k)=sumq(k)+c(ii)*c(ii)
            enddo
c            print*,'k,sumq(k)',k,sumq(k)
         enddo
      enddo
      if(itest(59).eq.0) then
         if(itest(80).eq.0) then
            do k=1,nvec
               sumq(k)=DSQRT(sumq(k)/ndet)
            enddo
         else
            do k=1,nvec
               sumq(k)=DSQRT(sumq(k)/itest(80))
            enddo
         endif
c         print*,'k,sumq(k)',k,sumq(k)
      else
         do k=1,nvec
            sumq(k)=DSQRT(sumq(k)/nbdet_cas)
         enddo
      endif
      ycv=.true.
      ncv=0
      do k=1,nvec
         ycvl(k)=sumq(k).LT.THR
         if(ycvl(k)) ncv=ncv+1
         ycv=ycv.and.ycvl(k)
      enddo
c      if(m.eq.nvec) ycv=.true.
      return
      end
       subroutine syspin12(ab,ndet)
c
c     symetrisation en spin d'un vecteur
c
      PARAMETER (ngru3=2048,maxda3=300)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      dimension ab(ndet)
      common /ijd/itab,dtab
      dimension ITAB(NGRU3),DTAB(NGRU3)
      character*1 syspin
      common /sysp1/syspin
      yw=.false.
      if(syspin.eq.'0') return
      if(syspin.eq.'+') then
         isyspi=1
      else
         isyspi=-1
      endif
      rewind 3
      ifin=0
      do k=1,ndet,ngru3
         ideb=ifin+1
         ifin=min(ideb+ngru3-1,ndet)
c        on lit le codage de la symetrie de spin
         call liri(itab,ngru3,3)
c        on corrige les coef
         if(yw) then
            write(6,*)'codage syspin'
            do kk=ideb,ifin
               write(6,*)'codage kk,itab(kk)',kk,itab(kk)
            enddo
         endif
         i=0
         do l=ideb,ifin
            i=i+1
            if(itab(i).gt.l) goto 1
            ab(itab(i))=isyspi*ab(l)
 1          continue
c           if(yw)write(6,'('' syspin ab av/apr'',i6,2f12.8)')l,aa,
c     *      ab(l)
         enddo
      enddo
      return
      end
       subroutine sauvcd(v,nn,iord,jord)
      common/test/itest(100)
      common/dim/iadri ; integer(8) iadri
      real*8 v(nn)
      dimension iord(iadri),jord(iadri)
      rewind 87
      n=nn
      call lirbl(iord,n,87)
      do k=1,n
         jord(iord(k))=k
      enddo
      open(99,file='SAUVCD',status='unknown')
      if(itest(80).ne.0) n=itest(80)
      do k=1,n
         write(99,'(i8,F10.6)') k,v(jord(k))
      enddo
      close(99)
      open(99,file='SAUVCD2',status='unknown')
      do k=1,n
         write(99,'(i8,F10.6)') k,-v(jord(k))
      enddo
      stop
      return
      end
 
