      subroutine david
      use module
      use mod_dav
      use mod_script
!*************************
!
!     DIAGONALIZATION SUBROUTINE FOR LARGE SYMMETRIC MATRICES
!     E. R. DAVIDSON, J. COMP. PHYS 17, 87 (1975)
!
!*************************
!
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      double precision,allocatable,dimension(:,:) :: h,alpha,v3,v4
     *,bab1
      common /habillage/ M,m2
      character(132) temps
      character(40) temps2
      character(1) cs0
      character(3) cms2
      character(10000) namel
 
      character(31) el1vovoiil1
      character(3) syspin1
 
 
      !
      yw=.false.
      yw1=.false.
      nprint=1
      write(cs0,'(i1)') is0
 
      write(cms2,'(i3)') ms2
      syspin1=syspin
      if(syspin==' ') syspin1='non'
      if(mhab==0) then
         namel=' davidson   diagonalisation #'//'symetrie de spin : '//
     *   syspin1//'#'//'symetrie '//cs0//'#'//'ms2 '//cms2//'#'
         if(uci) namel=trim(namel)//'Calcul PSRCI#'
         call titre(namel,40)
      else
         temps=' '
         if(mhab==1) write(temps,'(a)') 'MR-CEPA_0'
         if(mhab==2) write(temps,'(a)') 'MR-CEPA_0 raffine'
         namel=' davidson   diagonalisation #'//'symetrie de spin : '//
     *   syspin1//'#'//'symetrie '//cs0//'#'//'ms2 '//cms2//'#'
     *   //'Habillage  '//trim(temps)//'#'
         if(uci) namel=trim(namel)//'Calcul PSRCI#'
         call titre(namel,40)
      endif
      WRITE(6,31)
 31   FORMAT(/,/,20X,'  NDET  NVEC NITER   PREC')
      WRITE(6,22) ndet,NVEC,NITER,PREC
 22   FORMAT(16X,i10,2I6,D8.1)
      allocate(v3(2048,dim_heff))
      allocate(v4(2048,dim_heff))
      allocate(alam(dim_heff))
      alam=0.d0
      allocate(sumq(dim_heff))
      allocate(bab(dim_heff,dim_heff))
      allocate(bab1(dim_heff,dim_heff))
      allocate(alpha(dim_heff,dim_heff))
      allocate(h(dim_heff,dim_heff))
      allocate(ycvl(nvec))
      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
      print*,' '
      print*,' '
      write(6,'(a)')'ITER  M'
      call flush(6)
c----------------------------------
c     mises a zero
c----------------------------------
      m=nvec
      ncv=0
      do kk=1,nvec
         ycvl(kk)=.false.
      enddo
      ITER=0
      m0=0
      m2=nvec
c-----------------------------------------
c     initialisation UCI
c-----------------------------------------
      if(uci) call init_uci
c-----------------------------------------
c     boucle sur les iterations
c-----------------------------------------
      call cpu_time(t0)
 
      yiil1=.true.
      yiil1lent=.true.
 
      y_iterh_trop_grand=.true.
      do 200 iter1=1,niter
      iter=iter+1
      if(iter==iterh+1) then
         print*,'-------debut Habillage-------------'
         print*,' '
      endif
      !print*,'incr iter',iter
c-----------------------------------------
c     appel H*Psi0
c-----------------------------------------
      !if(itest(81)==m) call sauvl(v1,ndet)
      if(mprint(5).eq.1) then
         do kk=m0+1,m
            call scrida('v1 avant mulmc$',v1,ndet,21,kk)
         enddo
      endif
      if(nhab/=0) delta=0.d0
      call mul(m0,m2,m)
      maxl0=nvec
      if(mprint(5).eq.1) then
         do k=1,m-m0
            call scrida('v2 ap mul    $',v2,ndet,22,m0+k)
         enddo
      endif
      if(itest(82)==m) call sauvl(v2,ndet)
c-----------------------------------------
c     calcul de l'hamiltonien effectif
c-----------------------------------------
      DO 60 L=1,M
      call lire(v1,l,ndet,21)
      DO 61 LL=1,L
      BABL=0.d0
      call lire(v2,ll,ndet,22)
      DO 50 J=1,ndet
      BABL=BABL+V1(J,1)*v2(J,1)
   50 continue
      BAB(LL,L)=BABL
      BAB(L,LL)=BABL
   61 continue
   60 continue
      if(mprint(4).eq.1) then
         write(6,*)'Heff'
         call SCRIPT(bab,m,m,dim_heff,dim_heff)
      endif
c-----------------------------------------------
c     diagonalisation de l'hamiltonien effectif
c-----------------------------------------------
c     diagonalisation
      if(nhab>0) alam_hab=alam(nhab)
      do k1=1,m
         do k2=1,m
            h(k2,k1)=bab(k2,k1)
         enddo
      enddo
      call hdiag(h,alpha,m,dim_heff)
      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
!      ydepl=.false.
!      do k=1,m
!         ydepl=ydepl.or.abs(alpha(m,k))<1.d-7
!         if(abs(alpha(m,k))<1.d-7) print*,'dernier coef',alpha(m,k)
!      enddo
      if(mprint(4).eq.1) then
         write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,m)
         write(6,*)'Veff'
         call SCRIPT(alpha,m,m,dim_heff,dim_heff)
      endif
c---------------------------------------------
c     test de convergence
c---------------------------------------------
      call dav4conv(v3,v4,m,alpha,ycv,y_iterh_trop_grand,alam_hab)
      !maxl0=nvec-count(ycvl)
      !print*,'MAXL0,nvec',MAXL0,nvec
!      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
         call cpu_time(t1)
         icpu=t1-t0
         icpu1=icpu
         if(icpu1.eq.0) icpu1=1
         longt2=int(log10(float(icpu1)))+2
         write(form,15)'(a5,i',longt2,',a4)'
         write(temps2,form) '  cpu',icpu,' sec'
         call cpu_time(t0)
         if(nvec.le.5) then
            write(temps,14)iter,alam(1)+enuc+eref,
     *      (alam(kk)-alam(1),kk=2,min0(5,nvec))
            !print*,'alam(1)',alam(1)
            longt=min0(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,min0(5,nvec))
         endif
         write(6,12) m,(sumq(kk),kk=1,min0(5,nvec))
         ifin=5
         do k=6,nvec-5,5
            ideb=ifin+1
            ifin=min0(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=min0(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)
12    format(i6,3x,5D14.2)
121   format(9x,5D14.2)
 15   format(a5,i1,a4)
      call flush(6)
      !if(iter==2)call sauvl(v2,ndet)
c-------------------------------------------------
c     on interromp le processus dans quelques cas
c-------------------------------------------------
c...  si convergence
      if(y_iterh_trop_grand.and.ycv.and.mhab/=0.and.iterh>=iter) then
         y_iterh_trop_grand=.false.
         print*,' '
         print*,'***ATTENTION***'
         print*,
     *   'Le calcul a converge avant que l''habillage ne commence'
         print*,'-------debut Habillage-------------'
         print*,' '
         iterh=iter-1
         print*,'ITER,ITERH',ITER,ITERH
         ycv=.false.
      endif
      IF (ycv) GO TO 210
 230  continue
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 (v1,v2) comme combinaisons
c     lineaires des vecteurs de chaque iteration
c----------------------------------------------------
      if(m.gt.nvec.or.nhab.ne.0) then
         yecr=m+nvec-ncv.gt.dim_heff
         icpu1=itemps(idum)
         call davregrou(alpha,m,isuiv,bab1,v3,v4,yecr
     *   ,yesp,mv)
         if(ytana) then
            icpu2=itemps(idum)-icpu1
            if(yw1)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(v2,k,ndet,23)
         rewind 20
         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
            read(20) diag(1:ilong)
c           boucle sur les det du bloc
            DO I=1,ilong
               iq=iq+1
c               write(6,'('' david diag '',f12.8,i8)')
c     *         diag(i),iq
               !IF (DABS(ab(Iq))-1.d-25) 95,95,97
               if(DABS(v2(Iq,1))-1.d-25>0.d0) goto 97
               v2(Iq,1)=0.d0
               GO TO 100
 97            continue
               if(alam(K)-diag(I).gt.-1.d-5) then
                       !print*,'alam',alam(K),diag(I),alam(K)-diag(I),i
                  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
                  v2(Iq,1)=v2(Iq,1)/(-1.d-5)
               else
                  v2(Iq,1)=v2(Iq,1)/(alam(K)-diag(I))
               endif
  100          CONTINUE
c               write(6,'('' david ab '',f12.8,i8)')v2(iq,1),iq
            enddo
         enddo
c        v2 contient le nouveau vecteur Psi
!         call syspin2(v2(:,1))
         !if(ydepl)v2(:,1)=v2(:,1)+1.d-5
         !if(ydepl)print*,'bruit sur le futur vecteur'
         call symdet3(v2(:,1))
         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
         if(uci) then
            call proj_uci(alpha(1:m,1:m))
         endif
c
c--------------------------------------------------
c     orthogonalisation de v1(m+1) aux v1(1)...v1(m)
c--------------------------------------------------
c
         DO  L=1,M
            call lire(v1,l,ndet,21)
            SUM=0.d0
            DO I=1,ndet
               SUM=SUM+v1(I,1)*v2(I,1)
            enddo
            DO I=1,ndet
               v2(I,1)=v2(I,1)-SUM*v1(I,1)
            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+v2(I,1)*v2(I,1)
         enddo
         if(yw1)print*,'m,sum',m,sum,prec
         if(sum.lt.prec*prec*0.001) then
            dim_heff=min(m,dim_heff)
c         print*,'sum',sum
            print*,' l''Espace est de dimension',m
            goto 156
         endif
         M=M+1
         SUM=1.d0/DSQRT(SUM)
         DO I=1,ndet
            v1(I,1)=SUM*v2(I,1)
         enddo
         call ecr(v1,m,ndet,21)
 155     continue
      enddo
 156  continue
      if(yw1)print*,'m',m
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         if(yw1)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('v1 avant mul1c$',v1,ndet,21,kk)
         enddo
      endif
      if(nhab.ne.0.and.iter.ge.iterh) call diaghab
      m2=m
!      if(nhab.ne.0.and.iter.ge.iterh) print*,'appel diaghab iter',iter
 210  continue
      if(ycv) goto 220
 200  continue
      write(75,*) 'NON CONVERGE apres',iter,' iterations $'
      iter=iter-1
      call scril
      stop='DEL'
 220  continue
      yecr=.true.
      icpu1=itemps(idum)
      call davregrou(alpha,m,isuiv,bab1,v3,v4,yecr
     *,yesp,mv)
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         if(yw1)write(6,*)'davregrou fin    cpu',icpu2
      endif
      deallocate(v3,v4,alam,sumq,bab,bab1,alpha,h,ycvl)
      return
      end
 
       subroutine davregrou(alpha,m,isuiv,bab1,b1,ab1,
     *yecr,yesp,mv)
      use module
      use mod_dav
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension bab1(dim_heff,dim_heff),b1(*),ab1(*)
      dimension v3(2048,dim_heff)
      dimension v4(2048,dim_heff)
      DIMENSION alpha(dim_heff,dim_heff)
      real(8),allocatable :: cc(:),rec_hab(:)
      integer,allocatable :: ll0(:)
      integer iloc(1)
!     if(isuiv.ne.0.and.m.gt.nvec) call davsuiv2
!    *(alpha,alam,m,nvec,isuiv,bab1,mv)
      if(yecr.or.nhab.ne.0) then
         allocate (cc(2048))
         allocate (ll0(dim_heff))
         allocate (rec_hab(dim_heff))
         do j=1,m
            ll0(j)=(j-1)*((ndet-1)/ngru3+1)
         enddo
         ilec=0
         ifin=0
         rec_hab(:)=0.d0
         if(mhab>0) v2(:,1)=vhab
         do i=1,ndet,ngru3
            ilec=ilec+1
            long=min(ngru3,ndet-i+1)
            do j=1,m
               ll=ll0(j)+ilec
               call lirec(v3(1,j),ll,long,21)
               call lirec(v4(1,j),ll,long,22)
              ! print*,'v3 regrou',i,j,ll,m
              ! print*,'v3 regrou',v3(:,j)
              ! print*,'v4 regrou',v4(:,j)
            enddo
            ideb=ifin+1
            ifin=ifin+long
            maxk=nvec
            if(nhab/=0) maxk=m
            do k=1,maxk
               do ii=1,long
                  cc(ii)=0.d0
                  do l=1,m
                     cc(ii)=cc(ii)+alpha(l,k)*v3(ii,l)
                  enddo
               enddo
               if(nhab/=0) then
                  rec_hab(k)=rec_hab(k)+
     *            dot_product(cc(1:long),v2(ideb:ifin,1))
                  do k1=1,long
!                     if(dabs(cc(k1))>1.d-1.or.dabs(v2(ideb+k1-1,1))
!     *               >1.d-1)print*,'cc,vhab',
!     *               k,ideb-1+k1,cc(k1),v2(ideb+k1-1,1)
                  enddo
                  if(k==nhab) vhab(ideb:ifin)=cc(1:long)
!                 print*,'vhab ds david',vhab(ideb:ifin)
               endif
               if(k>nvec) cycle
               ll=ll0(k)+ilec
               if(yecr) then
                  call ecric(cc,ll,long,21)
                  do ii=1,long
                     cc(ii)=0.d0
                     do l=1,m
                        cc(ii)=cc(ii)+alpha(l,k)*v4(ii,l)
                     enddo
                  enddo
                  call ecric(cc,ll,long,22)
               endif
            enddo
         enddo
         if(nhab>0.and..not.vhab_original.and.iter>iterh-1) then
            rec_hab=dabs(rec_hab)
            if(rec_hab(nhab)<1.d0/dsqrt(2.d0)) then
               print*,'********************************************'
               print'(a)','recouvrement(s) avec le vecteur habilleur '//
     *         'de l''iteration precedente'
               print'(10d10.2)',rec_hab(1:m)
               print*,'Le recouvrement est < sqrt(2)/2.'
               print*,' On cherche si le vecteur habilleur n''a'//
     *         ' pas change de numero'
               iloc=maxloc(rec_hab(1:m))
               print'(a,f10.6,a,i3)'
     *         ,'valeur max du recouvrement :',maxval(rec_hab(1:m)),
     *         '     en position ',iloc(1)
               print*,'nhab prend desormais la valeur',iloc(1)
               nhab=iloc(1)
               if(nhab>nvec) then
                  print*,'nvec=',nvec
                  print*,'nvec doit etre au moins egal a nhab'
                  print*,'relancer le calcul avec nhab>=',iloc(1)
                  stop
               endif
               print*,'********************************************'
               ilec=0
               ifin=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(v3(1,j),ll,long,21)
                  enddo
                  ideb=ifin+1
                  ifin=ifin+long
                  do ii=1,long
                     vhab(ideb-1+ii)=0.d0
                     do l=1,m
                        vhab(ideb-1+ii)=vhab(ideb-1+ii)
     *                  +alpha(l,iloc(1))*v3(ii,l)
                     enddo
                  enddo
               enddo
                do k1=1,long
                     if(dabs(vhab(ideb-1+k1))>1.d-1)
     *               print*,'vhab',
     *               ideb-1+k1,vhab(ideb+k1-1)
                 enddo
            endif
         endif
         vhab_original=.false.
 
         deallocate(cc,ll0,rec_hab)
      endif
 
      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
      v1(:,1)=0.d0
      call lire(v1,kk,ndet,21)
      WRITE(11) v1(:,1)
 1209 continue
      close(11)
      open(11,file=davec1,status='old',form='unformatted')
      return
      end
       subroutine davsuiv2
      use module
      use mod_dav
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      return
      end
       subroutine dav4conv(v3,v4,m,alpha,ycv,y_iterh_trop_grand
     *,alam_hab)
      use module
      use mod_dav
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension alpha(dim_heff,dim_heff)
      dimension v3(2048,dim_heff),v4(2048,dim_heff)
      real(8),allocatable :: cc(:)
      integer,allocatable :: ll0(:)
      allocate (cc(2048))
      allocate (ll0(dim_heff))
      do k=1,nvec
         sumq(k)=0.d0
      enddo
      do j=1,m
         ll0(j)=(j-1)*((ndet-1)/2048+1)
      enddo
      ilec=0
      do i=1,ndet,2048
         ilec=ilec+1
         long=min(2048,ndet-i+1)
         do j=1,m
            ll=ll0(j)+ilec
            call lirec(v3(1,j),ll,long,21)
            call lirec(v4(1,j),ll,long,22)
         enddo
         do k=1,nvec
            do ii=1,long
               cc(ii)=0.d0
               do l=1,m
                  cc(ii)=cc(ii)+alpha(l,k)*(v4(ii,l)-alam(k)*v3(ii,l))
!                  print*,'ii',ii,cc(ii),alpha(l,k),v4(ii,l),alam(k)
!     *            ,v3(ii,l)
               enddo
            enddo
            ll=ll0(k)+ilec
            call ecric(cc,ll,long,23)
            do ii=1,long
               sumq(k)=sumq(k)+cc(ii)*cc(ii)
            enddo
         enddo
      enddo
      if(itest(59).eq.0) then
         do k=1,nvec
            sumq(k)=DSQRT(sumq(k)/ndet)
         enddo
      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.prec
         !if(nhab>0)ycv=ycv.and.dabs(alam_hab-alam(nhab))<prec*10
! si habillage, et si k est le vecteur habilleur, on ajoute une
! condition supplementaire a la convergence de ce vecteur
         if(nhab>0.and.nhab==k)
     *   ycvl(k)=ycvl(k).and.dabs(alam_hab-alam(nhab))<prec*10
         if(ycvl(k)) ncv=ncv+1
         ycv=ycv.and.ycvl(k)
      enddo
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     si .not.y_iterh_trop_grand, on a converge le calcul sans habillage
!     si en plus iterh==iter-2, on en est 
!     a la 1ere iteration de l'habillage
!     alors, l'habillage n'avait pas ete prepare (les delta sont nuls)
!     donc, lh'habillage vaut 0, le calcul va converger tout de suite
!     on va imposer donc 1 iteration supplementaire, pour reprendre le
!     cycle d'habillage
      if(.not.y_iterh_trop_grand.and.iterh==iter-2) ycv=.false.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c      if(m.eq.nvec) ycv=.true.
      deallocate(cc,ll0)
      return
      end
       subroutine sauvl(v,n)
      use module
      real(8) v(n)
      open(99,file='SAUVL',status='unknown')
      call titre('creation SAUVL, puis stop#',40)
      print*,'v(1)',v(1)
      do k=1,n
         write(99,'(i8,F10.6)') k,v(k)
         !write(6,'(i8,F10.6)') k,v(k)
      enddo
      stop
      return
      end
       subroutine init_david(dim_heff_1)
      use mod_dav
      integer dim_heff_1
      dim_heff=dim_heff_1
      end subroutine
