!*************************
!
!     DIAGONALIZATION SUBROUTINE FOR LARGE SYMMETRIC MATRICES
!     E. R. DAVIDSON, J. COMP. PHYS 17, 87 (1975)
!
!*************************
!
!--------------------------------------------------------------------
!                               Small manual
!--------------------------------------------------------------------
! 1. Initialize:


! - Compute diago(1:ndet), diagonal of the matrix to be diagonilized
!   write diago on a file 'DIAGO' 
!   by blocks of length 2048. the number of the file
!   is file_diago, which is given to david0 through the call to init_david.
!   close(file_diago)
    

!          use mod_dav
!          call init_david(ndet,nvec,mem,maxit,
!    *     dim_heff,nessai,file_diago,prec,eref,mprint,davec1)
! where :
!
! ndet             = size of the matrix
! nvec             = number of roots
! mem              = in Mb
! maxit            = mx nb of iterations
! dim_heff         = dimension of effective hamiltonian
! nessai           = 0,1,2,3
! file_diago       = file where matrix diagonal is stored
! prec             = precision
! eref             = zero energy
! mprint(2)        = for debugging
! davec1           = name of output vector file (character*80)
! 
! 2. Operations before calling david

!    - declare and allocate 2 vectors v1(ndet) and v2(ndet):
!      allocatable v1(:),v2(:)
!      allocate(v1(ndet),v2(ndet))


!**********************************************************************
!    - compute guess vectors v1(ndet)
!    - write the guess vectors on files 21 (opened by init_david)
!      command to write the guess vectors:
!      do k=1,nvec
!         ...compute V1...
!         call ecr(V1(:),k,ndet,21)
!      enddo
!      (ecr is a subroutine of the david module)

!**********************************************************************
!    - write a subroutine mul that computes the V2 = H . V1 product
!      At the beginning of mul, V1 is on file 21 (like the guess vector)
!      read them as follows:

!      arguments of mul:
!      call mul(ind(1:n),n)
!      where:
!        n is the number of vectors in the product
!        ind() is the rank of these vectors
!      do k=1,nvec
!         ...compute V1...
!         call lire(V1(:),k,ndet,21)
!      enddo
!      
!      At the end, write V2 of vile 22
!      do k=1,nvec
!         ...compute V2...
!         call ecr(V2(:),k,ndet,22)
!      enddo
!      (files 21 and 22 were opened in init_dav)
!
!      beginning of mul:
!      subroutine mul(ind,n)
!       use mod_dav
!       integer ind(n)
!
!**********************************************************************
! 3.   call david(v1,v2)

!      An example of calling program is given at the end of this
!      file
!--------------------------------------------------------------------



      module mod_dav
      integer,parameter :: ngru3=2048
      double precision,dimension(ngru3) :: diag
      double precision,allocatable,dimension(:),private :: alam,sumq
      integer,allocatable,dimension(:),private :: act_vec
      logical,allocatable :: ycvl(:)
      character(40) :: form
      double precision,allocatable,dimension(:,:) :: h,alpha,v3,v4
      double precision,allocatable,dimension(:,:) :: cc1,cc2

      integer,private :: ndet,nvec,maxit,nvec1,dim_heff,nessai,mem
      integer,private :: file_diago,di_heff,iter,loc_heff=0,ncv,nfree
      integer,private :: n_act_vec
      real(8),allocatable,dimension(:,:),private :: Heff,Heff2
      integer,private :: mprint(5),nprint
      real(8),private :: prec
      real(8),private :: eref
      character(80),private :: davec1
      logical(1),private :: ytana,ytouregrou
      logical(1),private,allocatable :: yfree(:)
      integer,private,allocatable :: rep_vec(:,:),n_rep_vec(:)
     *,iadr_heff(:)

! nfree = nb d'enregistrements disponibles sur les fichiers a acces
!         direct 21 et 22
! yfree = yfree(k)=T --> l'enregistrement k est disponible
! n_rep_vec(k)=n --> la racine k est representee par n enregistrements
! rep_vec(:,k) --> numeros de ces enregistrements
! act_vec(:) --> dans l'appel a mul, numeros des enregistrements
!                  pour lesquels on doit faire le produit (il y
!                  en a nvec-ncv)
! iadr_heff(i)=j  --> l'indice i de Heff correspond a l'enregistrement j

      contains
!***********************************************************************
       subroutine init_david(ndet_lu,nvec_lu,mem_lu,maxit_lu,
     *dim_heff_lu,nessai_lu,file_diago_lu,prec_lu
     *,eref_lu,mprint_lu,davec1_lu)
      IMPLICIT none
      integer ndet_lu,nvec_lu,mem_lu,maxit_lu,dim_heff_lu
     *,nessai_lu,file_diago_lu,mprint_lu(5)
      character(*) davec1_lu
      real(8) dum(ngru3)
      real(8) prec_lu,eref_lu
      integer long
      logical :: yw=.false.

      ndet=ndet_lu
      nvec=nvec_lu
      mem=mem_lu
      maxit=maxit_lu
      dim_heff=dim_heff_lu*nvec
      nessai=nessai_lu
      file_diago=file_diago_lu
      prec=prec_lu
      eref=eref_lu
      mprint=mprint_lu
      davec1=davec1_lu


      allocate(Heff(dim_heff,dim_heff),Heff2(dim_heff,dim_heff))
      if(yw) then
         print*,'HEFF ET HEFF2 ALLOUES'
         print*,'ndet',ndet
         print*,'nvec',nvec
         print*,'mem',mem
         print*,'maxit',maxit
         print*,'dim_heff',dim_heff
         print*,'nessai',nessai
         print*,'file_diago',file_diago
         print*,'prec',prec
         print*,'========================'
      endif


      open(file_diago,file='DIAGO',status='old',form='unformatted')
      open(11,file='DAVEC',status='unknown',form='unformatted')
      !
      ! Ouvertures
      !
      inquire(iolength=long) dum
      open(21,status='UNKNOWN',file='LOC_DIRB',access='DIRECT',
     *recl=long,form='UNFORMATTED')
      open(22,status='UNKNOWN',file='LOC_DIRAB',access='DIRECT',
     *recl=long,form='UNFORMATTED')
      open(23,status='UNKNOWN',file='LOC_DIRP',access='DIRECT',
     *recl=long,form='UNFORMATTED')
      open(24,status='UNKNOWN',file='LOC_DIRR',access='DIRECT',
     *recl=long,form='UNFORMATTED')
      end subroutine
!**************************************************************************
       subroutine close_david
       logical :: yw=.false.
       deallocate(Heff,Heff2)
       if(yw)print*,'HEFF ET HEFF2 DESALLOUES'
       close(11)
       close(21,status='delete')
       close(22,status='delete')
       close(23,status='delete')
       close(24,status='delete')
      end subroutine
!**************************************************************************

      subroutine david(v1,v2)
!*************************
!
!     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)
      real(8),dimension(ndet) :: v1,v2
      character(132) temps
      character(40) temps2
      character(1) cs0
      character(3) cms2
      character(10000) namel
 
      character(31) el1vovoiil1
      character(3) syspin1
 

      
      ! test de validite
      if(nvec>ndet) then
         print*,'*************************************************'
         print*,'On demande plus de vecteurs que la dimension de H'
         print*,'nvec',nvec
         print*,'ndet',ndet
         print*,'*************************************************'
         stop
      endif
 
 
 
!
! Intialisation de variables, allocations
!
      yw=.false.
      yw1=.false.
      nprint=1
      ytana=.true.
      allocate(iadr_heff(dim_heff))
      allocate(v3(2048,dim_heff))
      allocate(v4(2048,dim_heff))
      allocate(cc1(2048,nvec))
      allocate(cc2(2048,nvec))
      allocate(alam(dim_heff))
      alam=0.d0
      allocate(sumq(dim_heff))
      allocate(alpha(dim_heff,dim_heff))
      allocate(h(dim_heff,dim_heff))
      allocate(ycvl(nvec))
      allocate(act_vec(nvec))
      allocate(yfree(dim_heff))
      allocate(rep_vec(dim_heff,nvec))
      allocate(n_rep_vec(nvec))
      yfree=.true.
      nfree=dim_heff-nvec
      do k=1,nvec
         rep_vec(1,k)=k
      enddo
      n_rep_vec=1
 
!
! Debut, ecritures
!
      yw=.false.
      yw1=.false.
      nprint=1
      WRITE(6,31)
 31   FORMAT(/,/,20X,'  NDET  NVEC MAXIT   PREC')
      WRITE(6,22) ndet,NVEC,MAXIT,PREC
 22   FORMAT(16X,i10,2I6,D8.1)
      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----------------------------------
      di_heff=nvec
      ncv=0
      do kk=1,nvec
         ycvl(kk)=.false.
      enddo
      ITER=0
      m0=0
      m2=nvec
c-----------------------------------------
c     boucle sur les iterations
c-----------------------------------------
      call cpu_time(t0)
 
      do 200 iter1=1,MAXIT
      iter=iter+1
      !print*,'incr iter',iter
       
c-----------------------------------------
c     appel H*Psi0
c-----------------------------------------
      if(mprint(1).eq.1) then
         do kk=m0+1,di_heff
            call scrida('v1 avant mulmc$',v1,ndet,21,kk)
         enddo
      endif
      call mul((/(k,k=m0+1,di_heff)/),di_heff-m0,v1,v2,ndet)
      maxl0=nvec
      if(mprint(1).eq.1) then
         do k=1,di_heff-m0
            call scrida('v2 ap mul    $',v2,ndet,22,m0+k)
         enddo
      endif
      if(mprint(3)==1) then
         print*,'recouvrement entre les vecteurs Psi'
         do kk=1,di_heff
            call lire(v1,kk,ndet,21)
            do ll=1,di_heff
               call lire(v2,ll,ndet,21)
               print*,'Rec Psi',kk,ll,dot_product(v1,v2)
            enddo
         enddo
         print*,'recouvrement entre les vecteurs HPsi'
         do kk=1,di_heff
            call lire(v1,kk,ndet,22)
            do ll=1,di_heff
               call lire(v2,ll,ndet,22)
               print*,'Rec HPsi',kk,ll,dot_product(v1,v2)
            enddo
         enddo
      endif
c-----------------------------------------
c     calcul de l'hamiltonien effectif
c-----------------------------------------
!      print*,'avant appel calc_heff_carre',di_heff,nvec,ncv
      if(di_heff==nvec-ncv) then
         !print*,'appel calc_heff_carre',di_heff,nvec,ncv
         call calc_heff_carre
      endif
      call calc_heff_rect(di_heff-(nvec-ncv))
      if(mprint(2).eq.1) then
         write(6,*)'Heff nouveau'
         call SCRIPT(Heff,di_heff,di_heff,dim_heff,dim_heff)
      endif
c
c-----------------------------------------------
c     diagonalisation de l'hamiltonien effectif
c-----------------------------------------------
c
      do k1=1,di_heff
         do k2=1,di_heff
            h(k2,k1)=Heff(k2,k1)
         enddo
      enddo
      call hdiag(h,alpha,di_heff,dim_heff)
      do kk=1,di_heff
         alam(kk)=h(di_heff+1-kk,di_heff+1-kk)
      enddo
      do kk=1,di_heff/2
         do i=1,di_heff
            vv=alpha(i,kk)
            alpha(i,kk)=alpha(i,di_heff+1-kk)
            alpha(i,di_heff+1-kk)=vv
         enddo
      enddo
!      ydepl=.false.
!      do k=1,di_heff
!         ydepl=ydepl.or.abs(alpha(di_heff,k))<1.d-7
!         if(abs(alpha(di_heff,k))<1.d-7) print*,'dernier coef',alpha(di_heff,k)
!      enddo
      if(mprint(2).eq.1) then
         write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,di_heff)
         write(6,*)'Veff'
         call SCRIPT(alpha,di_heff,di_heff,dim_heff,dim_heff)
      endif

c---------------------------------------------
c     test de convergence
c     test de convergence
c     Calcul de Hpsi-E.Psi
c     Stockage de Hpsi-E.Psi dans la file 23
c     sont calcules dans dav4conv :
c     sumq(1:nvec) = residus, ycvl(1:nvec) = vecteurs converges
c     ncv = nb de vecteurs converges, ycv = test general de convergence
c---------------------------------------------

      call dav4conv(ycv,mprint)

c---------------------------------------------
c     ecriture des energies a cette iteration
c---------------------------------------------

!      if(iter.eq.1.or.di_heff.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)+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)+eref,
     *      (alam(kk)-alam(1),kk=2,min0(5,nvec))
         endif
         write(6,12) di_heff,(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)
c-------------------------------------------------
c     on interromp le processus dans quelques cas
c-------------------------------------------------
c...  si convergence
      IF (ycv) GO TO 210
 230  continue
c...
c...  si on a fait toutes les iterations
      IF (iter.eq.MAXIT) goto 210
c----------------------------------------------------
c     si l'hamiltonien effectif devient trop grand
c     on calcule PSI et H*PSI (v1,v2) comme combinaisons
c     lineaires des vecteurs de chaque iteration
c     (on "regroupe" les vecteurs de chaque iteration)
c----------------------------------------------------
      if(di_heff.gt.nvec) then
         yecr=di_heff+nvec-ncv.gt.dim_heff
         icpu1=itemps(idum)
         call davregrou(isuiv,yecr,yesp,mv,v1,v2)
         if(ytana) then
            icpu2=itemps(idum)-icpu1
            if(yw1)write(6,*)'davregrou     cpu',icpu2
         endif
         if(yecr) di_heff=nvec
      endif
      icpu1=itemps(idum)
c----------------------------------------------------
c     calcul des vecteurs Psi(di_heff+1)
c----------------------------------------------------
      m0=di_heff
      icpu1=itemps(idum)
      if(mprint(5)==1)
     *print*,'calcul des vecteurs Psi(di_heff+1), ycvl',ycvl(1:nvec)
      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 file_diago
         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(file_diago) diag(1:ilong)
            !print*,'diag lu',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.d-13>0.d0) goto 97
               v2(Iq)=0.d0
               GO TO 100
 97            continue
c                  print*,'alam',alam(K),diag(I),alam(K)-diag(I),i
               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
                  v2(Iq)=v2(Iq)/(-1.d-5)
               else
                  v2(Iq)=v2(Iq)/(alam(K)-diag(I))
               endif
  100          CONTINUE
c               write(6,'('' david ab '',f12.8,i8)')v2(iq),iq
            enddo
         enddo
c        v2 contient le nouveau vecteur Psi
         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--------------------------------------------------
c     orthogonalisation de v1(di_heff+1) aux v1(1)...v1(di_heff)
c--------------------------------------------------
c
         ! normalisation v2
         SUM=0.d0
         DO I=1,ndet
            SUM=SUM+v2(I)*v2(I)
         enddo
         sum=dsqrt(sum)
         if(mprint(5)==1)print*,'norme v2',sum,'   vecteur numero',k
         DO I=1,ndet
            v2(I)=v2(I)/sum
         enddo
         
         ! Orthogonalisation V2
         do iterorthog=1,10
            DO  L=1,di_heff
               call lire(v1,l,ndet,21)
               SUM=0.d0
               DO I=1,ndet
                  SUM=SUM+v1(I)*v2(I)
               enddo
               if(mprint(5)==1)print*,'orthog sum',l,sum
               DO I=1,ndet
                  v2(I)=v2(I)-SUM*v1(I)
               enddo
            enddo
c           do kkk=1,ndet
c              write(6,'('' david ab, di_heff '',f12.8,2i8)')
c              ab(kkk),kkk,di_heff
c           enddo

            ! 2eme normalisation
            SUM=0.d0
            DO I=1,ndet
               SUM=SUM+v2(I)*v2(I)
            enddo
            if(yw1)print*,'di_heff,sum',di_heff,sum,prec
!            if(sum.lt.prec*prec*0.001) then
!               dim_heff=min(di_heff,dim_heff)
!c            print*,'sum',sum
!               print*,' l''Espace est de dimension',di_heff
!               goto 156
!            endif
            di_heff=di_heff+1
            SUM2=1.d0/DSQRT(SUM)
            if(mprint(5)==1)print*,'Norme avant 2eme normalisation',sum
            DO I=1,ndet
               v1(I)=SUM2*v2(I)
            enddo
            if(sum>1.d-6) exit
            print*,'le nouveau vecteur est lineairement dependant'//
     *      ' aux precedents :'
            print*, 'reorthonormalisation (norme=',sqrt(sum),')'
            v2=v1
            di_heff=di_heff-1
         enddo
         if(mprint(5)==1) print*,'ecriture du nouveau V1 sur',di_heff
         call ecr(v1,di_heff,ndet,21)
         if(di_heff==ndet) exit
 155     continue
      enddo
 156  continue
      if(yw1)print*,'di_heff',di_heff
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         if(yw1)write(6,*)'Psi(di_heff+1)      cpu',icpu2
      endif
c-------------------------
c     iteration suivante
c     produit H*Psi
c-------------------------
      if(mprint(1).eq.1) then
         print*,'di_heff',m0+1,di_heff
         do kk=m0+1,nvec
            call scrida('v1 avant mul1c$',v1,ndet,21,kk)
         enddo
      endif
      m2=di_heff
 210  continue
      if(ycv) goto 220
 200  continue
      write(75,*) 'NON CONVERGE apres',iter,' iterations $'
      iter=iter-1
      call scril
 220  continue
      yecr=.true.
      icpu1=itemps(idum)
      call davregrou(isuiv,yecr,yesp,mv,v1,v2)
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         if(yw1)write(6,*)'davregrou fin    cpu',icpu2
      endif
      call open_chose_number(ifil,'DAVID_ENER','unknown','unformatted')
      write(ifil) eref,alam(1:nvec)
!     deallocate(v3,v4,alam,sumq,alpha,h,ycvl)
      deallocate(iadr_heff)
      deallocate(v3)
      deallocate(v4)
      deallocate(cc1)
      deallocate(cc2)
      deallocate(alam)
      deallocate(sumq)
      deallocate(alpha)
      deallocate(h)
      deallocate(ycvl)
      deallocate(act_vec)
      deallocate(yfree)
      deallocate(rep_vec)
      deallocate(n_rep_vec)
      close(ifil)
      return
      end subroutine
 
       subroutine davregrou(isuiv,yecr,yesp,mv,v1,v2)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      real(8),allocatable :: cc(:)
      integer,allocatable :: ll0(:)
      integer iloc(1)
      real(8),dimension(ndet,nvec) :: v1,v2
!     if(isuiv.ne.0.and.di_heff.gt.nvec) call davsuiv2
      if(yecr) then
         allocate (cc(2048))
         allocate (ll0(dim_heff))
         do j=1,di_heff
            ll0(j)=(j-1)*((ndet-1)/ngru3+1)
         enddo
         ilec=0
         ifin=0
         do i=1,ndet,ngru3
            ilec=ilec+1
            long=min(ngru3,ndet-i+1)
            do j=1,di_heff
               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,di_heff
              ! print*,'v3 regrou',v3(:,j)
              ! print*,'v4 regrou',v4(:,j)
            enddo
            ideb=ifin+1
            ifin=ifin+long
            maxk=nvec
            do k=1,maxk
               do ii=1,long
                  cc(ii)=0.d0
                  do l=1,di_heff
                     cc(ii)=cc(ii)+alpha(l,k)*v3(ii,l)
                  enddo
               enddo
               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,di_heff
                        cc(ii)=cc(ii)+alpha(l,k)*v4(ii,l)
                     enddo
                  enddo
                  call ecric(cc,ll,long,22)
               endif
            enddo
         enddo
!        on recalcule Heff pour les nvec vecteurs regroupes
         !print*,'davregrou regrou Heff'
         heff2=heff
         do i=1,nvec
            do j=1,i
               heff(i,j)=0.d0
               do k=1,di_heff
                  do l=1,di_heff
                     heff(i,j)=heff(i,j)+alpha(k,i)*alpha(l,j)*
     *               heff2(k,l)
                  enddo
               enddo
               heff(j,i)=heff(i,j)
            enddo
         enddo
 
         deallocate(cc,ll0)
      endif
 
 
      return
      end subroutine
       subroutine dav4conv(ycv,mprint)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      real(8),allocatable :: cc(:)
      integer,allocatable :: ll0(:)
      integer mprint(5)
      allocate (cc(2048))
      allocate (ll0(dim_heff))
      !print*,'entree dav4conv'
      mprint(4)=0
      do k=1,nvec
         sumq(k)=0.d0
      enddo
      do j=1,di_heff
         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,di_heff
            ll=ll0(j)+ilec
            call lirec(v3(1,j),ll,long,21)
            call lirec(v4(1,j),ll,long,22)
            if(mprint(4)>=1) then
               print*,'Psi dans dav4conv, vecteur',j
               print'(8f10.6)',V3(1:long,j)
               print*,'HPsi dans dav4conv, vecteur',j
               print'(8f10.6)',V4(1:long,j)
            endif
         enddo
         if(mprint(4)>=1) then
            print*,'alpha'
            call script(alpha,di_heff,nvec,dim_heff,dim_heff)
         endif
         do k=1,nvec
            do ii=1,long
               cc(ii)=0.d0
               do l=1,di_heff
                  cc(ii)=cc(ii)+alpha(l,k)*(v4(ii,l)-alam(k)*v3(ii,l))
                  if(mprint(4)>=1)
     *            print'(a,i5,5f10.6)','ii,cc,alpha,v4,alam,v3'
     *            ,ii,cc(ii),alpha(l,k),v4(ii,l),alam(k)
     *            ,v3(ii,l)
               enddo
            enddo
            if(mprint(4)>=1) then
               print*,'Residu vecteur ',k
               print'(8f10.6)',cc(1:long)
            endif
            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
!
! Residus, convergence
!
      do k=1,nvec
         sumq(k)=DSQRT(sumq(k)/ndet)
      enddo
      ycv=.true.
      ncv=0
      do k=1,nvec
         ycvl(k)=sumq(k).LT.prec!.and.iter>10
         if(ycvl(k)) ncv=ncv+1
         ycv=ycv.and.ycvl(k)
      enddo
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c      if(di_heff.eq.nvec) ycv=.true.
      deallocate(cc,ll0)
      return
      end subroutine
C!***********************************************************************

       subroutine calc_heff_rect(m0)
!
! Calcul d'un rectangle inclus dans Heff
! i1,i2 : indices de ligne
! j1,j2 : indices de colonnes
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      nb_lec=(ndet-1)/2048+1
      if(m0==0) return
      heff(:,m0+1:di_heff)=0.d0
!
! nb_lec : nb de blocs de 2048 pour lire un vecteur
      do ilec=1,nb_lec
         long=min(2048,ndet-2048*(ilec-1))
!
! On lit tous les Psi
         do j=1,di_heff
            ll=(j-1)*((ndet-1)/2048+1)+ilec
            call lirec(v3(1,j),ll,long,21)
         enddo
!
! On lit les Hpsi qui viennent d'etre calcules
         do j=m0+1,di_heff
            ll=(j-1)*((ndet-1)/2048+1)+ilec
            call lirec(v4(1,j),ll,long,22)
               !print*,'v4 apres lec',v4(1:long,j)
         enddo
!
! On calcule Heff, sauf le bloc diagonal
         do i=1,m0
            do j=m0+1,di_heff
               heff(i,j)=heff(i,j)+
     *         dot_product(v3(1:long,i),v4(1:long,j))
               !print*,'v3',v3(1:long,i)
               !print*,'v4',v4(1:long,j)
!               print*,'heff3_nd',i,j,heff(i,j)
            enddo
         enddo
         do i=di_heff+1,di_heff
            do j=m0+1,di_heff
               heff(i,j)=heff(i,j)+
     *         dot_product(v3(1:long,i),v4(1:long,j))
!               print*,'heff3_nd',i,j,heff(i,j)
            enddo
         enddo
!
! On calcule le bloc diagonal de Heff
         do i=m0+1,di_heff
            do j=i,di_heff
               heff(i,j)=heff(i,j)+
     *         dot_product(v3(1:long,i),v4(1:long,j))
!               print*,'heff3_d',i,j,heff(i,j)
            enddo
         enddo
!
! Symetrisation
         do i=m0+1,di_heff
            do j=m0+1,i-1
               heff(i,j)=heff(j,i)
            enddo
            do j=1,m0
               heff(i,j)=heff(j,i)
            enddo
         enddo
      enddo
      end subroutine
C!***********************************************************************

       subroutine calc_heff_carre
!
! Calcul du carre Heff(1:di_heff,1:di_heff)
! i1,i2 : indices de ligne
! j1,j2 : indices de colonnes
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      nb_lec=(ndet-1)/2048+1
      heff(1:di_heff,1:di_heff)=0.d0
      !print*,'di_heff',di_heff
!
! nb_lec : nb de blocs de 2048 pour lire un vecteur
      do ilec=1,nb_lec
         long=min(2048,ndet-2048*(ilec-1))
!
! On lit les Psi
         do j=1,di_heff
            ll=(j-1)*((ndet-1)/2048+1)+ilec
            call lirec(v3(1,j),ll,long,21)
         enddo
!
! On lit les Hpsi
         do j=1,di_heff
            ll=(j-1)*((ndet-1)/2048+1)+ilec
            call lirec(v4(1,j),ll,long,22)
               !print*,'v4 apres lec',v4(1:long,j)
         enddo
!
! On calcule le bloc diagonal de Heff
         do i=1,di_heff
            do j=i,di_heff
               heff(i,j)=heff(i,j)+
     *         dot_product(v3(1:long,i),v4(1:long,j))
!               print*,'heff3_d',i,j,heff(i,j)
            enddo
         enddo
!
! Symetrisation
         do i=1,di_heff
            do j=1,i-1
               heff(i,j)=heff(j,i)
            enddo
         enddo
      enddo
      end subroutine
!**************************************************************************
      end module
!**************************************************************************
!**************************************************************************
       subroutine scrida(mess,b,n,ifil,ivec)
      IMPLICIT REAL*8(A-H,O-Z)
      dimension b(*)
      character*1 mess(80)
      call lire(b,ivec,n,ifil)
      call scrida1(mess,b,n,ifil,ivec)
      return
      end
       subroutine scrida1(mess,b,n,ifil,ivec)
      IMPLICIT REAL*8(A-H,O-Z)
      dimension b(*)
      character*1 mess(80)
      do k=1,80
         if(mess(k).eq.'$') then
            ifin=k
            goto 1
         endif
      enddo
      write(6,*)'mauvais message dans scrida'
      return
 1    continue
      write(6,*)'SCRIDA  ',(mess(k),k=1,ifin-1),' ifil,ivec',
     *ifil,ivec
      ifin=0
      do k=1,n,5
         ideb=ifin+1
         ifin=min0(n,ideb+4)
         write(6,1000)k,(b(kk),kk=ideb,ifin)
      enddo
 1000 format(i7,5(f10.6))
      return
      end
!**************************************************************************
      subroutine ecr(b,l,n,ifil)
      parameter (ngru3=2048)
      IMPLICIT REAL(8)(A-H,O-Z)
      dimension b(n)
!      print*,'n',n
!      write(6,*)'ecr l,n,ifil',l,n,ifil
      nn=(n-1)/ngru3
      ll=(l-1)*(nn+1)
      do k=1,n,ngru3
         ll=ll+1
c          write(ifil,rec=l) b
         long=min0(ngru3,n-k+1)
         call ecric(b(k),ll,long,ifil)
      enddo
      return
      end
       subroutine ecric(b,ll,long,ifil)
      IMPLICIT REAL(8)(A-H,O-Z)
      dimension b(long)
      irec=ll
      if(ifil==22.or.ifil==21) then
c         print*,'ecric ll',ll,ifil,long
         inquire(ifil,RECL=long2)
c         print*,'ecr.f',ifil,ll,long,long2
C         call filesplit('WRITE',ifil,long2,ichange,irec)
!         if(ichange==1)
!     *   print*,'****CLOSE/OPEN en ecriture  sur file',ifil
         call flush(6)
      endif
      !if(ifil==22) print*,'ECRITURE 22',ll
      write(ifil,rec=irec) b
      return
      end
!**************************************************************************
      subroutine lire(b,l,n,ifil)
      parameter (ngru3=2048)
      IMPLICIT REAL*8(A-H,O-Z)
      dimension b(n)
c      write(6,*)'lire l,n,ifil',l,n,ifil
      nn=(n-1)/ngru3
      ll=(l-1)*(nn+1)
      do k=1,n,ngru3
         ll=ll+1
c          read(ifil,rec=l) b
         long=min0(ngru3,n-k+1)
         call lirec(b(k),ll,long,ifil)
      enddo
      return
      end
       subroutine lirec(b,ll,long,ifil)
      IMPLICIT REAL*8(A-H,O-Z)
      dimension b(long)
      !print*,'lirec ll,ifil,long',ll,ifil,long
      irec=ll
      if(ifil==22.or.ifil==21) then
         inquire(ifil,RECL=long2)
         !print*,'lire.f',ifil,ll,long2,long
        !print*,'irec1',irec
C        call filesplit('READ',ifil,long2,ichange,irec)
        !print*,'irec2',irec
!         if(ichange==1)
!     *   print*,'****CLOSE/OPEN en lecture  sur file',ifil
         call flush(6)
      endif
!      if(ifil==22)print*,'LECTURE 22',ll
        !if(irec/=ll) print*,'ll,irec',ll,irec
        !if(irec/=ll) stop
      read(ifil,rec=irec) b
      return
      end
!**************************************************************************


C      module module
C      integer nvec,ndet,mem,maxit,dim_heff,nessai,file_diago,in_memory
C      real(8),allocatable :: v1(:),v2(:)
C      real(8) eref
C      end module
C
C
C      Program princ
C      use module
C      use mod_dav
C      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      real(8),allocatable :: diago(:)
C      real(8) prec
C      integer mprint(2)
C      character(80) davec1
C      print*,'PRINC   PRINC   PRINC   PRINC   PRINC   PRINC  ' 
C
C! Variables du probleme
C
C      nvec=3
C      ndet=85
C      mem=200   !(en Mo)
C      maxit=20
C      dim_heff=4
C      nessai=0
C      file_diago=1
C      prec=1.d-7
C      nessai=0
C      in_memory=1
C      file_diago=20
C      eref=0.d0
C      mprint=0
C      mprint(1)=1
C      mprint(2)=1
C      davec1='DAVEC'
C       
C!
C! Initialiser
C!
C      call init_david(ndet,nvec,mem,maxit,
C     *dim_heff,nessai,file_diago,prec,eref,mprint,davec1)
C!
C! Diagonaliser
C!
C      
C      print*,'avant davidson  mem',mem
C      allocate(v1(ndet))
C      allocate(v2(ndet))
C      call guess_vec(v1,v2,ndet,nvec)
C      call david(v1,v2)
C
C      end
C!******************************************************************
C      subroutine mul(act_vec,nmul)
C      use module
C      use mod_script
C      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      real(8),allocatable :: a(:,:),diago(:)
C      real(8),dimension(ndet,nvec) :: psi,hpsi
C      integer,dimension(2048) :: ii,jj
C      integer act_vec(nmul)
C      real(8) d(2048)
C!
C      ndet=85
C      allocate(a(ndet,ndet),diago(ndet))
C      a=0.d0
C
C
C! Creation de la matrice
C
C
C      open(1,file='MATB',status='old',form='unformatted')
C      do
C         read(1) ii,jj,d
C         ifin=2048
C         if(ii(2048)<0) ifin=jj(2048)
C         do k=1,ifin
C            a(ii(k),jj(k))=d(k)+a(ii(k),jj(k))
C            a(jj(k),ii(k))=a(ii(k),jj(k))
C            if(ii(k)==jj(k)) a(ii(k),jj(k))=d(k)+a(ii(k),jj(k))
C         enddo
C         if(ii(2048)<0) exit
C      enddo
C      close(1)
C         
C      
C      do k=1,nmul
C         print*,'mul act_vec',k,act_vec(k)
C         call lire(v1(:),act_vec(k),ndet,21)
C         !call mscript(v1(:))
C         v2(:)=matmul(a,v1(:))
C         call ecr(v2(:),act_vec(k),ndet,22)
C!         call mscript(v2(:))
C      enddo
C      deallocate(a)
C      
C      end
C!******************************************************************
C      subroutine guess_vec(psi,diago)
C      use module
C      use mod_script
C      IMPLICIT none
C      real(8) psi(ndet),dmax,locmin(1),diago(ndet)
C      integer k
C      if(nessai==0) then
C         if(in_memory==1) then
C            open(file_diago,file='DIAGO',form='unformatted',
C     *      status='old')
C            read(file_diago) diago(1:ndet)
C            dmax=maxval(diago(1:ndet))
C            do k=1,nvec
C               locmin=minloc(diago(1:ndet))
C               print*,'locmin',k,locmin(1)
C               psi(:)=0.d0
C               psi(locmin(1))=1.d0
C               diago(locmin(1))=dmax
C               if(k==2) psi(82)=0.d0
C               if(k==2) psi(83)=1.d0
C               if(k==3) psi(82)=1.d0
C               if(k==3) psi(83)=0.d0
C               call ecr(psi(:),k,ndet,21)
C            enddo
C            close(1)
C         else
C            stop'insufficient memory in guess'
C         endif
C      else
C         stop'valeur non prevue pour nessai'
C      endif
C
C      end subroutine
C!******************************************************************
