      subroutine david3(B,iesp,AB,ALAM,THR,maxdav,maxda2,
     *NVEC,NITER,yesp)
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 (maxda3=300,ngru3=2048,maxorbcas=16)
      include 'maxorb.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c    |      yesp                     |
c
      dimension yesp(*)
      common/dim/iadri ; integer(8) iadri
      common/svfil/fil11
      character*40 fil11
      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 /ijd/itab,jtab,dtab
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      dimension ITAB(NGRU3),JTAB(NGRU3)
      dimension sumq(maxda3)
      DIMENSION DTAB(NGRU3)
      real*4 dtab
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/opt/ihab,calcul
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      character*3 calcul
      common/sui/isuiv
      common/pert/schift,damp,ypertu,ycaspert
      common/pr/nprint,mprint(10)
      dimension bc(ngru3)
      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
      DATA ZERO,ONE/0.D0,1.D0/
      DATA EPS/1.D-25/
c      print*,'entree david3'
      lonstc=0
      jnb1=0
      icpu(1)=itemps(idum)
      if(itest(29).eq.1) then
         open(72,status='unknown',file='b_st',access='DIRECT',
     *   recl=ngru3*8,form='UNFORMATTED')
         open(73,status='UNKNOWN',file='ab_st',access='DIRECT',
     *   recl=ngru3*8,form='UNFORMATTED')
      endif
    5 FORMAT (//10X,'EIGENVALUE NUMBER',I3)
   10 FORMAT (3X,'ITER=',I3,', M=',I2,', EIGENVALUE=',F17.12,
     *', CONVERGENCE =',D10.2)
   20 FORMAT (///5X,'THE DAVIDSON PROCEDURE DOES NOT CONVERGE AFTER',
     *I4,' ITERATIONS'///)
      yw=.false.
c       ngru2=200
      icalc1=0
      if(yw)write(6,*)'1b',(b(kk),kk=1,ndet)
      if(yw)write(6,*)'2b',(b(kk),kk=1,ndet)
c      K=1
c      WRITE (6,*) 'VALEURS PROPRES'
      write(6,*)'ITER  M'
      call flush(6)
      M=NVEC
      ncv=0
      do kk=1,nvec
         ycvl(kk)=.false.
      enddo
      ITER=1
C
C     CONSTRUCTION OF THE BAB MATRIX IN THE SUBSPACE
C     OF THE TRIAL VECTORS  B(1) ... B(M)
C
      if(yw)write(6,*)'3b',(b(kk),kk=1,ndet)
      if(itest(29).eq.1) call ecr(b,1,ndet,72)
      if(mprint(5).eq.1) then
         do kk=1,m
            call scrida('b avant mulmc$',b,ndet,21,kk)
         enddo
      endif
      m0=0
      m2=nvec
      call mulmc2(b,iesp,iter,nvec)
      if(itest(29).eq.1) then
         call lire(ab,1,ndet,22)
         call ecr(ab,1,ndet,73)
      endif
      if(mprint(5).eq.1) then
         do kk=1,m
            call scrida('ab apres mulmc$',ab,ndet,22,kk)
         enddo
      endif
      if(yw)write(6,*)'4b',(b(kk),kk=1,ndet)
      if(yw)write(6,*)'ab',(ab(kk),kk=1,ndet)
      DO 60 L=1,M
      call lire(b,l,ndet,21)
      DO 60 LL=1,L
      BABL=ZERO
      call lire(ab,ll,ndet,22)
      DO 50 J=1,ndet
   50 BABL=BABL+B(J)*AB(J)
   60 BAB(L,LL)=BABL
C
C     DIAGONALIZATION OF BAB ... EIGENVALUES ALAM, EIGENVECTORS ALPHA
C
   70 DO 72 L=1,M
      DO 72 LL=1,L
      H(L,LL)=BAB(L,LL)
   72 H(LL,L)=BAB(L,LL)
      if(mprint(4).eq.1) then
         write(6,*)'Heff'
         call SCRIPT(h,m,m,maxda3,maxda3)
c        write(6,'('' alam avant riera'',4f8.4)')(alam(kk),kk=1,m)
      endif
      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
      CALL RIERA(M,H,ALPHA,ALAM,P,maxda3,ierr)
      if(ierr.eq.1) then
         print*,'..diagonalisation JACOBI'
         call hdiag(h,alpha,m,maxda3)
         do k=1,m
            alam(k)=h(m+1-k,m+1-k)
         enddo
         do k=1,m/2
            do i=1,m
               vv=alpha(i,k)
               alpha(i,k)=alpha(i,m+1-k)
               alpha(i,m+1-k)=vv
            enddo
         enddo
      endif
      if(isuiv.ne.0.and.m.gt.nvec) then
         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)
      endif
      mv=m
      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)
         write(6,*)'k',k
         if(k.gt.1)write(6,*)'k,alpha(k,k),alpha(kk,k-1)',
     *   k,alpha(k,k),(alpha(kk,k-1),kk=1,k-2)
      endif
C
C     SETS UP THE CORRECTION VECTOR Q
C     AND PERFORMS THE CONVERGENCE TEST
C
   75 continue
      ncv0=ncv
      do 92 k=1,nvec
c      if(ycvl(k)) goto 92
      SUMQ(k)=ZERO
      do kk=1,ndet
         b(kk)=zero
      enddo
      DO 90 L=1,M
      call lire(ab,l,ndet,22)
      ll=(l-1)*((ndet-1)/ngru3+1)
      iii=-ngru3
      do i=1,ndet,ngru3
         ll=ll+1
         long=min(ngru3,ndet-i+1)
         call lirec(bc,ll,long,21)
         iii=iii+ngru3
         do ii=1,long
c            if(ii.eq.1)print*,'ii',l,alam(k),bc(ii),ab(ii+iii),
c     *           AB(ii+iii)-ALAM(K)*bc(ii)
            ab(ii+iii)=AB(ii+iii)-ALAM(K)*bc(ii)
         enddo
      enddo
      DO 90 I=1,ndet
c     print*,'qav',q(i)
c      Q(I)=Q(I)+ALPHA(L,K)*(AB(I)-ALAM(K)*B(I))
      b(I)=b(I)+ALPHA(L,K)*AB(I)
c        print*,'q',i,q(i),ab(i),b(i)
   90 continue
      do i=1,ndet
c        print*,'Q',i,q(i)
         SUMQ(k)=SUMQ(k)+b(I)*b(I)
c               print*,'sumq',i,sumq(k)
      enddo
      if(itest(59).eq.0) then
         SUMQ(k)=DSQRT(SUMQ(k)/ndet)
      else
         SUMQ(k)=DSQRT(SUMQ(k)/nbdet_cas)
      endif
c      WRITE (6,10) ITER,M,ALAM(K),SUMQ(k)
c       write(6,*)alam(k)
c     on sauve Q sur DIRP
c       write(6,*)'avant ecriture q  m,k',m,k
      call ecr(b,k,ndet,23)
 92   continue
      if(yw)print*,'apres 92'
      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,m,(alam(kk),kk=1,min(5,nvec))
            longt=min(5,nvec)*14+9
            write(6,'(a)') temps(1:longt)//temps2(1:longt2+10)
         else
            write(6,14) iter,m,(alam(kk),kk=1,min(5,nvec))
         endif
         write(6,12)(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),kk=ideb,ifin)
            write(6,12)(sumq(kk),kk=ideb,ifin)
         enddo
         if(nvec.gt.5) then
            ideb=ifin+1
            ifin=min(ideb+4,nvec)
            write(temps,11)(alam(kk),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,12)(sumq(kk),kk=ideb,ifin)
         endif
         write(6,*)' '
      endif
11    format(9x,5F14.9)
14    format('##',i4,i3,5F14.9)
 13   format(a4,i8,a4)
12    format(9x,5D14.2)
 15   format(a5,i1,a4)
      call flush(6)
      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
      if(yw)print*,'ycvl',(ycvl(k),k=1,nvec)
      IF (ycv) GO TO 200
      IF (ITER.GE.NITER) GO TO 200
      ITER=ITER+1
      if(yw)print*,'iter',iter
C
C     IF M OVERFLOWS, THE B SUBSPACE IS THOROUGHLY REDEFINED
C
      IF (M+nvec-ncv.Gt.MAXDA2) GO TO 200
C
C     COMPUTES THE VECTOR B(M+1)  TO ENLARGE THE B SUBSPACE
C
      m0=m
      do 155 k=1,nvec
      if(yw)print*,'k,ycvl',k,(ycvl(kk),kk=1,nvec)
      if(ycvl(k)) goto 155
      iq=0
c       write(6,*)'avant lecture q  m,k',m,k
      call lire(ab,k,ndet,23)
      rewind 25
      nsh=0
      nlimit=0
      do 99 ii=1,ndet,ngru3
      if(iq+ngru3.gt.ndet) then
         ilong=ndet-iq
      else
         ilong=ngru3
      endif
      call lir8(diag,ilong,25)
      if(yw) then
         do kkk=1,ndet
            write(6,'('' david diag '',f12.8,i8)')diag(kkk),kkk
         enddo
      endif
      DO 100 I=1,ilong
      iq=iq+1
      IF (DABS(ab(Iq))-EPS) 95,95,97
   95 ab(Iq)=ZERO
      GO TO 100
 97   continue
c      if(dabs(ALAM(K)-DIAG(I)).lt.1.d-15) then
      if(ALAM(K)-DIAG(I).gt.-1.d-5) then
c         write(6,*)'QUASI DEGENERESCENCE',alam(k),diag(i),k,i
         nsh=nsh+1
         ab(Iq)=ab(Iq)/(-1.d-5)
         if(dabs(ab(iq)).gt.1.d0) then
            ab(iq)=1.d0
            nlimit=nlimit+1
c            print*,'ab remis a 1.',iq
         endif
      else
         ab(Iq)=ab(Iq)/(ALAM(K)-DIAG(I))
      endif
  100 CONTINUE
  99  continue
      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 = zero
c         write(6,*)'coucou'
c         call lire(ab,1,ndet,22)
         do  kk = 1,ndet
            sum = sum + ab(kk)*ab(kk)
         end do
         print *, ' david3 pertu norme =',sum
         sum = ONE/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--   symetrie de spin : cas du singulet
c     b(m+1) est projete sur l'espace singulet
c      call syspi1(ab,ndet)
c--   orthogonalisation de b(m+1) aux b(1)...b(m)
      DO 130 L=1,M
      call lire(b,l,ndet,21)
      SUM=ZERO
      DO 110 I=1,ndet
  110 SUM=SUM+B(I)*ab(I)
      DO 120 I=1,ndet
  120 ab(I)=ab(I)-SUM*B(I)
  130 CONTINUE
      SUM=ZERO
      DO 140 I=1,ndet
  140 SUM=SUM+ab(I)*ab(I)
      if(yw)print*,'m,sum',m,sum
      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
      SUM=ONE/DSQRT(SUM)
      DO 150 I=1,ndet
  150 B(I)=SUM*ab(I)
      call ecr(b,m,ndet,21)
 155  continue
 156  continue
C
C     ADDS ONE ROW AND ONE COLUMN TO THE BAB MATRIX
C
      if(itest(29).eq.1) call ecr(b,m,ndet,72)
c     if(itest(29).eq.1) print*,'ecr 72  ',m
      if(mprint(5).eq.1) then
         do kk=m0+1,m
            call scrida('b avant mulmc2$',b,ndet,21,kk)
         enddo
      endif
      m2=m
      call mulmc2(b,iesp,iter,nvec)
c      do kk=1,m
c          call scrida('ab apres mulmc2$',ab,ndet,22,kk)
c       enddo
      if(itest(29).eq.1) then
         call lire(ab,m,ndet,22)
         call ecr(ab,m,ndet,73)
      endif
c     if(itest(29).eq.1) print*,'ecr 73  ',m
      if(mprint(5).eq.1) then
         do kk=m0+1,m
            call scrida('ab apres mulmc2$',ab,ndet,22,kk)
         enddo
      endif
      do 195 k=1,nvec-ncv
      if(m0+k.gt.maxda2) goto 195
      call lire(ab,m0+k,ndet,22)
      if(yw)write(6,*)'2ab',(ab(kk),kk=1,ndet)
      DO 190 L=1,M
      SUM=ZERO
      call lire(b,l,ndet,21)
      DO 180 J=1,ndet
  180 SUM=SUM+B(J)*AB(J)
  190 BAB(M0+k,L)=SUM
 195  continue
c--   fabrication du vecteur d'essai et ecriture
c     print*,'fabrication vecteur d''essai'
      rewIND 11
      WRITE(11) ndet,NVEC
      WRITE(11) (ALAM(kk),kk=1,NVEC),enuc,eref
      DO 1209 KK=1,NVEC
      do i=1,ndet
         b(i)=ZERO
      enddo
      DO LL=1,M
         alp=alpha(ll,kk)
         call lire(ab,ll,ndet,21)
         do i=1,ndet
            b(i)=b(i)+AB(I)*ALP
         enddo
      enddo
      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)(AB(kkk),kkk=1,ndet)
c         print*,'ecriture 11 david3 iter',iter
c        call scrida('ecriture 11  $',ab,ndet,21,1)
      else
         WRITE(11)(B(kkk),kkk=1,ndet)
      endif
 1209 continue
      close(11)
      open(11,file=fil11,status='old',form='unformatted')
C
C     BACK TO THE DIAGONALIZATION OF BAB
C
      GO TO 70
C
C     THE EIGENVECTORS OF BAB ARE BACK-TRANSFORMED
C     IN THE ORIGINAL BASIS
C
  200 CONTINUE
      if(yw)print*,'apres 200'
      DO 272 L=1,M
      DO 272 LL=1,L
      H(L,LL)=BAB(L,LL)
  272 H(LL,L)=BAB(L,LL)
      CALL RIERA(M,H,ALPHA,ALAM,P,maxda3,ierr)
      if(ierr.eq.1) then
         print*,'.diagonalisation JACOBI'
         call hdiag(h,alpha,m,maxda3)
         do k=1,m
            alam(k)=h(m+1-k,m+1-k)
         enddo
         do k=1,m/2
            do i=1,m
               vv=alpha(i,k)
               alpha(i,k)=alpha(i,m+1-k)
               alpha(i,m+1-k)=vv
            enddo
         enddo
      endif
      if(isuiv.ne.0.and.m.gt.nvec) then
c        print*,'alpha fin'
c        call script(alpha,m,m,maxda3,maxda3)
         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
c           print*,'irec',irec
c           write(6,'('' alam'',10f8.4)')(alam(kkk),kkk=1,irec)
         enddo
      endif
      DO 209 KK=1,NVEC
      do i=1,ndet
         ab(i)=ZERO
      enddo
      DO LL=1,M
         alp=alpha(ll,kk)
         call lire(b,ll,ndet,21)
         do i=1,ndet
            ab(i)=ab(i)+B(I)*ALP
         enddo
      enddo
      call ecr(ab,kk,ndet,23)
      do i=1,ndet
         b(i)=ZERO
      enddo
      DO LL=1,M
         alp=alpha(ll,kk)
         call lire(ab,ll,ndet,22)
         do i=1,ndet
            b(i)=b(i)+AB(I)*ALP
         enddo
      enddo
      call ecr(b,kk,ndet,24)
 209  continue
      if(yw)print*,'apres 209'
      DO 220 KK=1,NVEC
      call lire(b,kk,ndet,23)
      call ecr(b,kk,ndet,21)
      call lire(b,kk,ndet,24)
      call ecr(b,kk,ndet,22)
  220 continue
      if(yw)print*,'apres 220'
      IF (ycv) RETURN
      IF (ITER.GE.NITER) GO TO 250
      M=NVEC
      DO 240 L=1,NVEC
      DO 230 LL=1,NVEC
      BAB(L,LL)=ZERO
  230 ALPHA(L,LL)=ZERO
      BAB(L,L)=ALAM(L)
  240 ALPHA(L,L)=ONE
      iter=iter-1
      if(yw)print*,'iter75',iter
      GO TO 75
 250  CONTINUE
      if(yw)print*,'apres 250'
      WRITE (6,20) ITER
      stop='DEL'
c      STOP
      return
      END
       subroutine mulmc2(b,iesp,iter,nvec)
c
c-------------------------------------------------------------------
c     subroutine de multiplication directe de la matrice par m vecteurs
c     la dimension est ndet
c     les vecteurs en donnee sont dans le fichier partitionne 21
c     l'enregistrement i correspond a vecteur i
c     les vecteurs resultats sont ecrits de la meme facon
c     dans le fichier 22
c-------------------------------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048,maxda3=300)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b                        |
c    |      iesp
c
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      common /ijd/itab,jtab,dtab
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      dimension ITAB(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      DIMENSION B(ndet),iesp(ndet*2)
      common/test/itest(100)
      yw=.false.
      yw1=.false.
      m1=m0+1
      ideb=0
c     print*,'maxl0',maxl0
c
c--   calcul de icalc
c--
      mm=m2-m0
c      write(6,*)'m0,m2,mm',m0,m2,mm
c      write(6,*)'ndet,iadri',ndet,iadri
      iadrib=iadri
      if(itest(13).ne.0)iadrib=itest(13)
      do k=1,mm
         ifin=ideb+maxl0
         if(ifin.gt.iadrib) then
            ideb=0
            ifin=maxl0
         endif
         if(ideb.eq.0) then
            icalc(k)=min(iadrib/maxl0,mm-k+1)
         else
            icalc(k)=0
         endif
         ideb=ifin
      enddo
      if(yw.or.(iter.eq.1.and.yw1.and.nvec.ge.1))
     *write(6,'(a8,40i3)')'icalc',(icalc(k),k=1,mm)
      m3=0
      do i=m1,m2
         icalc1=icalc(i-m0)
         m3=m3+1
         if(icalc1.ne.0) m3=0
         if(yw)write(6,*)'dans mulmc2 i,m0,icalc1,m3',i,m0,icalc1,m3
         call mul1c(b,i)
      enddo
      return
      end
