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

!          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
! prec             = convergence precision
! eref             = zero energy
! mprint(2)        = for debugging
! davec1           = name of output vector file (character*80)
! 
! 2. Operations before calling david

!    - allocate 2 vectors v1(ndet) and v2(ndet)

!    - Compute diago(1:ndet), diagonal of the matrix to be digonilized
!      write diago on a file by blocks of length 2048

!    - 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:
!      do k=1,nvec
!         ...compute V1...
!         call ecr(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)
!
! 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(:) :: 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(2),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(2)
      character(*) davec1_lu
      real(8) dum(ngru3)
      real(8) prec_lu,eref_lu
      integer long

      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

      ytouregrou=.true.

      allocate(Heff(dim_heff,dim_heff),Heff2(dim_heff,dim_heff))
      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*,'************************'


      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')
!      print*,'COUCOU2'
      open(22,status='UNKNOWN',file='LOC_DIRAB',access='DIRECT',
     *recl=long,form='UNFORMATTED')
!      print*,'COUCOU4'
      open(23,status='UNKNOWN',file='LOC_DIRP',access='DIRECT',
     *recl=long,form='UNFORMATTED')
!      print*,'COUCOU6'
      open(24,status='UNKNOWN',file='LOC_DIRR',access='DIRECT',
     *recl=long,form='UNFORMATTED')
      print*,'fin init_david'
      end subroutine
!**************************************************************************
       subroutine close_david
       deallocate(Heff,Heff2)
       close(11)
       close(21,status='delete')
       close(22,status='delete')
       close(23,status='delete')
       close(24,status='delete')
      end subroutine
!**************************************************************************
      subroutine david(v1,v2)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      real(8),dimension(ndet,nvec) :: v1,v2
      character(132) temps
      character(40) temps2
      character(10000) namel
      logical ycv
 
 
!
! 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
!
      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  D_Heff'
      call flush(6)
c
c----------------------------------
c     mises a zero
c----------------------------------
c
      ycv=.false.
      do k=1,nvec
         act_vec(k)=k
         iadr_heff(k)=k
      enddo
      di_heff=nvec
!     di_heff est la dimension de l'hamiltonien effectif en cours
!     (nvec au debut, puis augmente jusqu'a nvec*dim_heff, puis
!     reste constant,s auf apres convergence de certains
!     vecteurs propres
!     act_vec(1:nvec) vecteurs modifies a l'iteration iter
      ncv=0
      do kk=1,nvec
         ycvl(kk)=.false.
         yfree(kk)=.false.
      enddo
            print*,'yfree debut',yfree
      ITER=0
c-----------------------------------------
c     boucle sur les iterations
c-----------------------------------------
      call cpu_time(t0)
 
      do 200 iter=1,maxit
c-----------------------------------------
c     appel H*Psi0
c-----------------------------------------
      print*,'iter',iter,'     ACT_VEC',act_vec
      if(mprint(1).eq.1) then
         do kk=1,nvec-ncv
            k=act_vec(kk)
            call scrida('v1 avant mulmc$',v1,ndet,21,k)
         enddo
      endif
      call mul(act_vec,nvec-ncv)
      if(mprint(1).eq.1) then
         do kk=1,nvec-ncv
            k=act_vec(kk)
            call scrida('v2 ap mul    $',v2,ndet,22,k)
         enddo
      endif
c
c-----------------------------------------
c     calcul de l'hamiltonien effectif
c-----------------------------------------
c
      if(mprint(2).eq.1) then
         write(6,*)'Heff avant'
         call SCRIPT(Heff,di_heff,di_heff,dim_heff,dim_heff)
      endif
! subroutine calc_heff :
! calcul de colonnes de Heff
! nb de colonnes : nvec-ncv
! position des colonnes rajoutees : 
C      call calc_heff2(rep_vec,act_vec,n_rep_vec,nvec-ncv)
      call calc_heff3(di_heff-(nvec-ncv),di_heff)
      !if(mprint(2).eq.1) then
         write(6,*)'Heff'
         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)
      print*,'di_heff',di_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
      if(mprint(2).eq.1) then
         write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,di_heff)
         print*,'alam',alam(1:2)
         write(6,*)'Veff'
         call SCRIPT(alpha,di_heff,di_heff,dim_heff,dim_heff)
      endif
c
c---------------------------------------------
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---------------------------------------------
c
      call dav4conv(v3,v4,alpha)
      ycl=all(ycvl(1:nvec))
c
c---------------------------------------------
c     ecriture des energies a cette iteration
c---------------------------------------------
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)+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-------------------------------------------------
c     on interromp le processus dans quelques cas
c-------------------------------------------------
c
c...  si convergence
      IF (ycv) GO TO 220
 230  continue
c...
c...  si on a fait toutes les iterations
      IF (iter.eq.maxit) goto 200
c
c----------------------------------------------------
c     Si Heff devient trop grand a la prochaine iteration,
c     on va eliminer 2*nvec vecteurs PSI et H*PSI
c     dans la moitie de la place liberee, on va mettre 
c     une combinaison lineaire des 2 vecteurs elimines
c     l'autre moitie servira a l'iteration suivante.
c     Puis on stocke Psi et Hpsi (1:nvec) dans 21 et 22
c     On calcule Heff correspondant aux vecteurs (1:nvec)
c----------------------------------------------------
c
      if(ytouregrou) then
         call davregrout
      else
         call davregrou
      endif
      print*,'davregrou Heff'
      call SCRIPT(Heff,di_heff,di_heff,dim_heff,dim_heff)
      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
      if(mprint(2).eq.1) then
         write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,di_heff)
         print*,'alam',alam(1:2)
         write(6,*)'Veff'
         call SCRIPT(alpha,di_heff,di_heff,dim_heff,dim_heff)
      endif
C      if(iter>1) then
C         if(di_heff+nvec-ncv.gt.dim_heff)then 
C!           alors di_heff va devenir plus grand que dim_heff a la 
C!           prochaine iteration
C            icpu1=itemps(idum)
C            call davregrou(alpha,m0,m,v1,v2)
C            m=nvec
C            if(ytana) then
C               icpu2=itemps(idum)-icpu1
C               if(yw1)write(6,*)'davregrou     cpu',icpu2
C            endif
C            call calc_heff(0,nvec)
C         endif
C      endif
      icpu1=itemps(idum)
c
c----------------------------------------------------
c     calcul des vecteurs Psi(m+1)
c     les vecteurs sont stockes sur la file 22, a la suite de ceux
c     des iterations precedentes.
c     en sortie, m a ete incremente de nvec, et m0 a l'ancienne
c     valeur de m
c     les vecteurs Psi(m+1) sont stockes de m0+1 a m
c----------------------------------------------------
c
      call calc_vect_suivant(v1,v2)
c
c-------------------------
c     iteration suivante (retour au debut de la boucle)
c     produit H*Psi
c-------------------------
c
 200  continue
c
c-----------------------------------------
c     fin de la boucle sur les iterations
c-----------------------------------------
c
      write(75,*) 'NON CONVERGE apres',iter,' iterations $'
      iter=iter-1
      call scril
      stop='DEL'
 220  continue
      icpu1=itemps(idum)
      call davregrou
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         if(yw1)write(6,*)'davregrou fin    cpu',icpu2
      endif
      deallocate(v3,v4,alam,sumq,Heff,alpha,h,ycvl)
      return
      end subroutine
!***************************************************************************
 
       subroutine davregrouv(alpha,m0,m,v1,v2)
c
c----------------------------------------------------
c     Si Heff devient trop grand a la prochaine iteration,
c     on doit eliminer nvec vecteurs pour faire de la place
c     aux nouveaux
c     En fait, on en elimine 2.nvec (les 2.nvec plus anciens). 
c     on calcule nvec PSI et nvec H*PSI (v1,v2) comme combinaisons
c     lineaires des vecteurs eliminés
c     Puis on stocke les nvec nouveaux vecteurs Psi et Hpsi
c     dans 21 et 22
c     On calcule Heff correspondant aux vecteurs (1:nvec)
c----------------------------------------------------
c
      !IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      implicit none
      real(8) v3(2048,dim_heff)
      real(8) v4(2048,dim_heff)
      real(8) alpha(dim_heff,dim_heff)
      real(8) :: cc(2048)
      integer iloc(1)
      real(8),dimension(ndet,nvec) :: v1,v2
      integer m0,m
      integer i,j,k,l,kk,ideb,ifin,ll,ii,ilec,long
      ilec=0
      ifin=0
      do i=1,ndet,ngru3
         ilec=ilec+1
         long=min(ngru3,ndet-i+1)
!        lecture de tous les Psi et HPsi (1:di_heff)
         do j=1,di_heff
            ll=(j-1)*((ndet-1)/ngru3+1)+ilec
            call lirec(v3(1,j),ll,long,21)
            call lirec(v4(1,j),ll,long,22)
         enddo
         ideb=ifin+1
         ifin=ifin+long
         k=0
         do kk=1,nvec
            if(ycvl(kk)) cycle
            k=k+1
!           vecteur k : meilleur Psi, stocke dans cc
            do ii=1,long
               cc(ii)=0.d0
               do l=1,m
                  cc(ii)=cc(ii)+alpha(l,k)*v3(ii,l)
               enddo
            enddo
!           
            ll=(k-1)*((ndet-1)/ngru3+1)+ilec
            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)
         enddo
      enddo
 
 
      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
C!***************************************************************************
C 
C       subroutine davregrou
Cc
Cc----------------------------------------------------
Cc On regroupe les enregistrements dans quelques cas
Cc 1. Quand un vecteur a converge
Cc 2. quand on n'a plus assez d'enregistrements disponibles
Cc    pour stocker la prochaine iteration
Cc----------------------------------------------------
Cc
C      !IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      implicit none
C      real(8) :: cc(2048),alpha1,alpha2,anorm
C      integer iloc(1)
C      integer i,j,k,l,kvec,ll,ii,ilec,long,krep,jj,jvec,jn
C      integer return
C
C      return=0
C      if(nfree<nvec-ncv) return=1
C      if(return==0) then
C         do kvec=1,nvec
C            if(ycvl(kvec).and.n_rep_vec(kvec)>1) return=2
C         enddo
C      endif
C! Si return==1, on sort des limites. On regroupe les 2 plus vieux
C!  vecteurs et on ecrit le regroupement sur 21 et 22
C! Si return==2, un vecteur a converge. On regroupe tous les vecteurs
C! et on ecrit le regroupement sur 21 et 22
C      if(return==0) return
C
C      if(return==1) then
C!        on sort des limites
C!        On regroupe les 2 plus vieux
C!        vecteurs et on ecrit le regroupement sur 21 et 22
C
C!        boucle sur les vecteurs
C         do kvec=1,nvec
C!           si CV avant cette iteration, sauter
C            if(n_rep_vec(kvec)==1) cycle
C
C!           on va regrouper les 2 plus vieux Psi et Hpsi de kvec
C!           on utilise alpha(1:2,kvec), mais il faut renormaliser
C            alpha1=alpha(rep_vec(1,kvec),kvec)
C            alpha2=alpha(rep_vec(2,kvec),kvec)
C            anorm=sqrt(alpha1*alpha1+alpha2*alpha2)
C            alpha1=alpha1/anorm
C            alpha2=alpha2/anorm
C
C!           on lit les 2 plus vieux Psi et Hpsi de kvec
C            ilec=0
C            do i=1,ndet,ngru3
C               ilec=ilec+1
C               long=min(ngru3,ndet-i+1)
C               jn=0
C               do jj=1,2
C                  do jvec=1,nvec
C                     jn=jn+1
C                     j=rep_vec(jj,kvec)
C                     ll=(j-1)*((ndet-1)/ngru3+1)+ilec
C                     call lirec(v3(1,jn),ll,long,21)
C                     call lirec(v4(1,jn),ll,long,22)
C                     print'(a,i3,10f10.6)','V3',jn,v3(1:10,jn)
C                     print'(a,i3,10f10.6)','V4',jn,v4(1:10,jn)
C                  enddo
C               enddo
C
C!              V3 et V4 contiennent les 2 vecteurs a regrouper
C!              on ecrit le regroupement dans v3(1,kvec) et v4(1,kvec)
C!              puis sur 21 et 22 en position kvec
C               v3(:,1)=alpha1*v3(:,1)+alpha2*v3(:,2)
C               v4(:,1)=alpha1*v4(:,1)+alpha2*v3(:,2)
C               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
C               call ecric(v3(:,1),ll,long,21)
C               call ecric(v4(:,1),ll,long,22)
C            enddo
C!
C!           On a libere de la place sur 21 et 22
C            nfree=nfree+1
C            j=rep_vec(2,kvec)
C            yfree(j)=.true.
C            print*,'yfree 1 libere',j,yfree
C            n_rep_vec(kvec)=n_rep_vec(kvec)-1
C            rep_vec(2:n_rep_vec(kvec),kvec)=
C     *      rep_vec(3:n_rep_vec(kvec)+1,kvec)
C            di_heff=di_heff-1
C         enddo
C      else if(return==2) then
C!        Un vecteur a converge
C!        On regroupe tous les
C!        vecteurs et on ecrit le regroupement sur 21 et 22
C
C!        boucle sur les vecteurs
C         do kvec=1,nvec
C!           si CV avant cette iteration, sauter
C            if(n_rep_vec(kvec)==1) cycle
C
C!           on lit les vieux Psi et Hpsi de kvec
C            ilec=0
C            do i=1,ndet,ngru3
C               ilec=ilec+1
C               long=min(ngru3,ndet-i+1)
C               do jj=1,n_rep_vec(kvec)
C                  j=rep_vec(jj,kvec)
C                  ll=(j-1)*((ndet-1)/ngru3+1)+ilec
C                  call lirec(v3(1,jj),ll,long,21)
C                  call lirec(v4(1,jj),ll,long,22)
C               enddo
C            enddo
C
C!           V3 et V4 contiennent les 2 vecteurs a regrouper
C!           on ecrit le regroupement dans v3(1,kvec) et v4(1,kvec)
C!           puis sur 21 et 22 en position kvec
C            v3(:,1)=alpha(rep_vec(j,kvec),kvec)*v3(:,1)
C            v4(:,1)=alpha(rep_vec(j,kvec),kvec)*v4(:,1)
C            do jj=2,n_rep_vec(kvec)
C               j=rep_vec(jj,kvec)
C               v3(:,1)=alpha(rep_vec(j,kvec),kvec)*v3(:,jj)+v3(:,1)
C               v4(:,1)=alpha(rep_vec(j,kvec),kvec)*v4(:,jj)+v3(:,1)
C               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
C               call ecric(v3(:,1),ll,long,21)
C               call ecric(v4(:,1),ll,long,22)
C            enddo
C!
C!           On a libere de la place sur 21 et 22
C            nfree=nfree+n_rep_vec(kvec)-1
C            do jj=2,n_rep_vec(kvec)
C               j=rep_vec(jj,kvec)
C               yfree(j)=.true.
C            print*,'yfree libere davregrou',yfree
C            enddo
C         enddo
C      endif
C
C      return
C      end subroutine
!***************************************************************************
 
       subroutine davregrou
       use mod_script
c
c----------------------------------------------------
c On regroupe les enregistrements dans quelques cas
c 1. Quand un vecteur a converge
c 2. quand on n'a plus assez d'enregistrements disponibles
c    pour stocker la prochaine iteration
c----------------------------------------------------
c
      !IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      implicit none
      real(8) :: cc(2048),cc2(2048),alpha1,alpha2,anorm
      integer iloc(1)
      integer i,j,k,l,kvec,ll,ii,ilec,long,krep,jj,jvec,jn
      integer kfin,lfin
      integer return

      return=0
      if(nfree<nvec-ncv) return=1
      if(return==0) then
         do kvec=1,nvec
            if(ycvl(kvec).and.n_rep_vec(kvec)>1) return=2
         enddo
      endif
! Si return==1, on sort des limites. On regroupe les 2 plus vieux
!  vecteurs et on ecrit le regroupement sur 21 et 22
! Si return==2, un vecteur a converge. On regroupe tous les vecteurs
! et on ecrit le regroupement sur 21 et 22
      if(return==0) return

      if(return==1) then
!        on sort des limites
!        On regroupe les 2 plus vieux
!        vecteurs et on ecrit le regroupement sur 21 et 22
         v3=10000.d0
         v4=10000.d0
         print*,'davregrou return=1'
         Heff2=Heff

         ilec=0
         do i=1,ndet,2048
            ilec=ilec+1
            long=min(2048,ndet-i+1)
!           boucle sur les vecteurs
!
! On lit les nvec vecteurs (bloc de gauche)
            do kvec=1,nvec
               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
               call lirec(v3(1,kvec),ll,long,21)
               call lirec(v4(1,kvec),ll,long,22)
            enddo
!
! on lit le 2eme bloc en partant de gauche (les plus vieux vecteurs)
            do k=nvec+1,nvec+nvec-ncv
               j=iadr_heff(k)
               ll=(j-1)*((ndet-1)/ngru3+1)+ilec
               call lirec(v3(1,k),ll,long,21)
               call lirec(v4(1,k),ll,long,22)
            enddo
! On regroupe dans le bloc de gauche
            do kvec=1,nvec
               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
!              si CV avant cette iteration, sauter
               if(n_rep_vec(kvec)==1) cycle
! Norme des vecteurs regroupes
               anorm=0.d0
               do k=1,nvec+nvec-ncv
                  anorm=anorm+alpha(k,kvec)**2
               enddo
               anorm=sqrt(anorm)
               print*,'anorm',anorm
! Vecteurs regroupes :
               cc=0.d0
               cc2=0.d0
               do k=1,nvec+nvec-ncv
                  alpha1=alpha(k,kvec)/anorm
                  print*,'calc cc',alpha1,k
                  cc=cc+v3(:,k)*alpha1
                  cc2=cc2+v4(:,k)*alpha1
               enddo
                print*,'ecriture cc sur',kvec,ll
               call ecric(cc,ll,long,21)
               call ecric(cc2,ll,long,22)
            enddo
         enddo
!
! Fin de la boucle sur les blocs
!
!        On a libere de la place sur 21 et 22

!        enregistrements libres :
         do k=nvec+1,nvec+nvec-ncv
            j=iadr_heff(k)
            yfree(j)=.true.
            nfree=nfree+1
            print*,'yfree 1 libere',j,yfree
!
!        on decale rep_vec de 1
         enddo
         do kvec=1,nvec
            if(ycvl(kvec)) cycle
            n_rep_vec(kvec)=n_rep_vec(kvec)-(nvec-ncv)
            rep_vec(2:n_rep_vec(kvec),kvec)=
     *      rep_vec(3:n_rep_vec(kvec)+1,kvec)
            di_heff=di_heff-1
         enddo
!
!        on decale iadr_vec de nvec-ncv
         iadr_heff(nvec+1:di_heff)=
     *   iadr_heff(nvec+nvec-ncv+1:di_heff+nvec-ncv)
!
!        on recalcule Heff pour les nvec vecteurs regroupes
         do i=1,nvec
            do j=1,i
               heff(i,j)=0.d0
               kfin=nvec+nvec-ncv
               if(ycvl(i)) kfin=1
               do k=1,kfin
                  lfin=nvec+nvec-ncv
                  if(ycvl(j)) lfin=1
                  do l=1,lfin
                     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
C         do i=nvec+1,di_heff
C            do j=1,nvec
C               kfin=nvec+nvec-ncv
C               if(ycvl(j)) kfin=1
C               do k=1,kfin
C                  heff(i,j)=heff(i,j)+alpha(k,j)*
C     *            heff2(k,l)
                  
               
         heff(:,nvec+1:di_heff)=
     *   heff(:,nvec+nvec-ncv+1:di_heff+nvec-ncv)
         heff(nvec+1:di_heff,:)=
     *   heff(nvec+nvec-ncv+1:di_heff+nvec-ncv,:)
         call calc_heff3(0,nvec)

         print*,'normes'
         do k=1,di_heff
            call lire(v3(:,1),iadr_heff(k),ndet,21)
            print*,k,dot_product(v3(1:ndet,1),v3(1:ndet,1))
         enddo
         do k=1,di_heff
            call lire(v3(:,1),iadr_heff(k),ndet,21)
            do l=1,di_heff
               call lire(v4(:,1),iadr_heff(l),ndet,22)
               Heff2(k,l)=dot_product(v3(1:ndet,1),v4(1:ndet,1))
            enddo
         enddo
         call SCRIPT(Heff,di_heff,di_heff,dim_heff,dim_heff)
         call SCRIPT(Heff2,di_heff,di_heff,dim_heff,dim_heff)
         heff=heff2
         heff(:,di_heff+1:dim_heff)=0.d0
         heff(di_heff+1:dim_heff,:)=0.d0
           





C!        boucle sur les vecteurs
C         do kvec=1,nvec
C!           si CV avant cette iteration, sauter
C            if(n_rep_vec(kvec)==1) cycle
C
C!           on va regrouper les 2 plus vieux Psi et Hpsi de kvec
C!           on utilise alpha(1:2,kvec), mais il faut renormaliser
C            alpha1=alpha(rep_vec(1,kvec),kvec)
C            alpha2=alpha(rep_vec(2,kvec),kvec)
C            anorm=sqrt(alpha1*alpha1+alpha2*alpha2)
C            alpha1=alpha1/anorm
C            alpha2=alpha2/anorm
C
C!           on lit les 2 plus vieux Psi et Hpsi de kvec
C            ilec=0
C            do i=1,ndet,ngru3
C               ilec=ilec+1
C               long=min(ngru3,ndet-i+1)
C               jn=0
C               do jj=1,2
C                  do jvec=1,nvec
C                     jn=jn+1
C                     j=rep_vec(jj,kvec)
C                     ll=(j-1)*((ndet-1)/ngru3+1)+ilec
C                     call lirec(v3(1,jn),ll,long,21)
C                     call lirec(v4(1,jn),ll,long,22)
C                     print'(a,i3,10f10.6)','V3',jn,v3(1:10,jn)
C                     print'(a,i3,10f10.6)','V4',jn,v4(1:10,jn)
C                  enddo
C               enddo
C
C!              V3 et V4 contiennent les 2 vecteurs a regrouper
C!              on ecrit le regroupement dans v3(1,kvec) et v4(1,kvec)
C!              puis sur 21 et 22 en position kvec
C               v3(:,1)=alpha1*v3(:,1)+alpha2*v3(:,2)
C               v4(:,1)=alpha1*v4(:,1)+alpha2*v3(:,2)
C               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
C               call ecric(v3(:,1),ll,long,21)
C               call ecric(v4(:,1),ll,long,22)
C            enddo
C!
C!           On a libere de la place sur 21 et 22
C            nfree=nfree+1
C            j=rep_vec(2,kvec)
C            yfree(j)=.true.
C            print*,'yfree 1 libere',j,yfree
C            n_rep_vec(kvec)=n_rep_vec(kvec)-1
C            rep_vec(2:n_rep_vec(kvec),kvec)=
C     *      rep_vec(3:n_rep_vec(kvec)+1,kvec)
C            di_heff=di_heff-1
C         enddo
      else if(return==2) then
!        Un vecteur a converge
!        On regroupe tous les
!        vecteurs et on ecrit le regroupement sur 21 et 22

!        boucle sur les vecteurs
         do kvec=1,nvec
!           si CV avant cette iteration, sauter
            if(n_rep_vec(kvec)==1) cycle

!           on lit les vieux Psi et Hpsi de kvec
            ilec=0
            do i=1,ndet,ngru3
               ilec=ilec+1
               long=min(ngru3,ndet-i+1)
               do jj=1,n_rep_vec(kvec)
                  j=rep_vec(jj,kvec)
                  ll=(j-1)*((ndet-1)/ngru3+1)+ilec
                  call lirec(v3(1,jj),ll,long,21)
                  call lirec(v4(1,jj),ll,long,22)
               enddo
            enddo

!           V3 et V4 contiennent les 2 vecteurs a regrouper
!           on ecrit le regroupement dans v3(1,kvec) et v4(1,kvec)
!           puis sur 21 et 22 en position kvec
            v3(:,1)=alpha(rep_vec(j,kvec),kvec)*v3(:,1)
            v4(:,1)=alpha(rep_vec(j,kvec),kvec)*v4(:,1)
            do jj=2,n_rep_vec(kvec)
               j=rep_vec(jj,kvec)
               v3(:,1)=alpha(rep_vec(j,kvec),kvec)*v3(:,jj)+v3(:,1)
               v4(:,1)=alpha(rep_vec(j,kvec),kvec)*v4(:,jj)+v3(:,1)
               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
               call ecric(v3(:,1),ll,long,21)
               call ecric(v4(:,1),ll,long,22)
            enddo
!
!           On a libere de la place sur 21 et 22
            nfree=nfree+n_rep_vec(kvec)-1
            do jj=2,n_rep_vec(kvec)
               j=rep_vec(jj,kvec)
               yfree(j)=.true.
            print*,'yfree libere davregrou',yfree
            enddo
         enddo
      endif

      return
      end subroutine
C!***************************************************************************
       subroutine davregrout
       use mod_script
c
c----------------------------------------------------
c On regroupe les enregistrements dans quelques cas
c 1. Quand un vecteur a converge
c 2. quand on n'a plus assez d'enregistrements disponibles
c    pour stocker la prochaine iteration
c----------------------------------------------------
c
      !IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      implicit none
      real(8) :: cc(2048),cc2(2048),alpha1,alpha2,anorm
      integer iloc(1)
      integer i,j,k,l,kvec,ll,ii,ilec,long,krep,jj,jvec,jn
      integer kfin,lfin
      integer return

      return=0
      if(nfree<nvec-ncv) return=1
      print*,'dans davregrout return',return
! Si return==1, on sort des limites. On regroupe tous les vecteurs
      if(return==0) return

      if(return==1) then
!        on sort des limites
         v3=10000.d0
         v4=10000.d0
         print*,'davregrou return=1'
         Heff2=Heff

         ilec=0
         do i=1,ndet,2048
            ilec=ilec+1
            long=min(2048,ndet-i+1)
!           boucle sur les vecteurs
!
! On lit tous les vecteurs
            do kvec=1,di_heff
               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
               call lirec(v3(1,kvec),ll,long,21)
               call lirec(v4(1,kvec),ll,long,22)
            enddo
!
! On regroupe dans le bloc de gauche
            do kvec=1,nvec
               ll=(kvec-1)*((ndet-1)/ngru3+1)+ilec
! Vecteurs regroupes :
               cc=0.d0
               cc2=0.d0
               do k=1,di_heff
                  alpha1=alpha(k,kvec)
                  print*,'calc cc',alpha1,k
                  cc=cc+v3(:,k)*alpha1
                  cc2=cc2+v4(:,k)*alpha1
               enddo
                print*,'ecriture cc sur',kvec,ll,cc(2)
               call ecric(cc,ll,long,21)
               call ecric(cc2,ll,long,22)
            enddo
         enddo
!
! Fin de la boucle sur les blocs
!
!        On a libere de la place sur 21 et 22

!        enregistrements libres :
         do k=nvec+1,di_heff
            j=iadr_heff(k)
            yfree(j)=.true.
            nfree=nfree+1
            print*,'yfree 1 libere',j,yfree
!
!        on decale rep_vec de 1
         enddo
         di_heff=nvec
!
!        on decale iadr_vec de nvec-ncv
         iadr_heff(nvec+1:di_heff)=0
!
!        on recalcule Heff pour les nvec vecteurs regroupes
         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
C         do i=nvec+1,di_heff
C            do j=1,nvec
C               kfin=nvec+nvec-ncv
C               if(ycvl(j)) kfin=1
C               do k=1,kfin
C                  heff(i,j)=heff(i,j)+alpha(k,j)*
C     *            heff2(k,l)
                  
               
         heff(:,nvec+1:di_heff)=0.d0
         heff(nvec+1:di_heff,:)=0.d0

         print*,'normes'
         do k=1,di_heff
            call lire(v3(:,1),iadr_heff(k),ndet,21)
            print*,k,dot_product(v3(1:ndet,1),v3(1:ndet,1))
         enddo
         do k=1,di_heff
            call lire(v3(:,1),iadr_heff(k),ndet,21)
            do l=1,di_heff
               call lire(v4(:,1),iadr_heff(l),ndet,22)
               Heff2(k,l)=dot_product(v3(1:ndet,1),v4(1:ndet,1))
            enddo
         enddo
         call SCRIPT(Heff,di_heff,di_heff,dim_heff,dim_heff)
         call SCRIPT(Heff2,di_heff,di_heff,dim_heff,dim_heff)
         heff=heff2
         heff(:,di_heff+1:dim_heff)=0.d0
         heff(di_heff+1:dim_heff,:)=0.d0
           
      endif

      return
      end subroutine
C!***************************************************************************
C 
C       subroutine davregroun
Cc
Cc----------------------------------------------------
Cc
C      !IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      implicit none
C      integer iloc(1)
C      integer i,j,k,l,kk,ideb,ifin,ll,ii,ilec,long,jn,jj,jvec,kvec
C      ilec=0
C      ifin=0
C!
C! Boucle sur les blocs
C      do i=1,ndet,ngru3
C         ilec=ilec+1
C         long=min(ngru3,ndet-i+1)
C!        lecture des 2*nvec Psi et HPsi (les plus anciens)
C         jn=0
C         cc1=0.d0
C         cc2=0.d0
C         do jj=1,2
C            do jvec=1,nvec
C               jn=jn+1
C               j=rep_vec(jj,kvec)
C               ll=(j-1)*((ndet-1)/ngru3+1)+ilec
C               call lirec(v3(1,jn),ll,long,21)
C               call lirec(v4(1,jn),ll,long,22)
C               print'(a,i3,10f10.6)','V3',jn,v3(1:10,jn)
C               print'(a,i3,10f10.6)','V4',jn,v4(1:10,jn)
C               do kvec=1,nvec
C                  cc1(:,kvec)=cc1(:,kvec)+alpha(l,kvec)*v3(:,l)
C            enddo
C         enddo
C
C
C
C
C
C         do j=1,di_heff
C            ll=(j-1)*((ndet-1)/ngru3+1)+ilec
C            call lirec(v3(1,j),ll,long,21)
C            call lirec(v4(1,j),ll,long,22)
C         enddo
C         ideb=ifin+1
C         ifin=ifin+long
C         k=0
C         do kk=1,nvec
C            if(ycvl(kk)) cycle
C            k=k+1
C!           vecteur k : meilleur Psi, stocke dans cc
C            do ii=1,long
C               cc(ii)=0.d0
C               do l=1,m
C                  cc(ii)=cc(ii)+alpha(l,k)*v3(ii,l)
C               enddo
C            enddo
C!           
C            ll=(k-1)*((ndet-1)/ngru3+1)+ilec
C            call ecric(cc,ll,long,21)
C            do ii=1,long
C               cc(ii)=0.d0
C               do l=1,m
C                  cc(ii)=cc(ii)+alpha(l,k)*v4(ii,l)
C               enddo
C            enddo
C            call ecric(cc,ll,long,22)
C         enddo
C      enddo
C 
C 
C      rewind 11
C      write(11) ndet,nvec
C      write(11) (alam(kk),kk=1,nvec),enuc,eref
C      DO 1209 kk=1,NVEC
C      v1(:,1)=0.d0
C      call lire(v1,kk,ndet,21)
C      WRITE(11) v1(:,1)
C 1209 continue
C      close(11)
C      open(11,file=davec1,status='old',form='unformatted')
C      return
C      end subroutine
!***********************************************************************
       subroutine dav4conv(v3,v4,alpha)
      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) :: cc(2048)
      do k=1,nvec
         sumq(k)=0.d0
      enddo
!
! Stockage sur 23 de H.Psi-E.PSI
!
      ilec=0
      do i=1,ndet,2048
         ilec=ilec+1
         long=min(2048,ndet-i+1)
         do j=1,di_heff
            ll=(j-1)*((ndet-1)/2048+1)+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,di_heff
                  cc(ii)=cc(ii)+alpha(l,k)*(v4(ii,l)-alam(k)*v3(ii,l))
!                  print'(a,i4,5f10.6)',
!     *            'ii',ii,cc(ii),alpha(l,k),v4(ii,l),alam(k)
!     *            ,v3(ii,l)
               enddo
            enddo
            ll=(k-1)*((ndet-1)/2048+1)+ilec
            call ecric(cc,ll,long,23)
            do ii=1,long
               sumq(k)=sumq(k)+cc(ii)*cc(ii)
            enddo
         enddo
      enddo
!            call scrida('HPSI-EPSI$',v4,ndet,23,1)
!            call scrida('HPSI-EPSI$',v4,ndet,23,2)
!
! 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
         if(ycvl(k)) ncv=ncv+1
!         ycv=ycv.and.ycvl(k)
      enddo
      return
      end subroutine
C!***********************************************************************
C
C       subroutine calc_heff1(m0,m)
C      use mod_script
C      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      Heff(1:m,m0+1:m)=0.d0
C      Heff(m0+1:m,1:m)=0.d0
C      nb_lec=(ndet-1)/2048+1
C      do ilec=1,nb_lec
C         long=min(2048,ndet-2048*(ilec-1))
C         do j=1,m
C            ll=(j-1)*((ndet-1)/2048+1)+ilec
C            call lirec(v3(1,j),ll,long,21)
C         enddo
C         do j=m0+1,m
C            ll=(j-1)*((ndet-1)/2048+1)+ilec
C            call lirec(v4(1,j),ll,long,22)
C         enddo
C         do i=1,m0
C            do j=m0+1,m
C               heff(i,j)=heff(i,j)+dot_product(v3(:,i),v4(:,j))
C               heff(j,i)=heff(i,j)
C            enddo
C         enddo
C         do i=m0+1,m
C            do j=m0+1,i
C               heff(i,j)=heff(i,j)+dot_product(v3(:,i),v4(:,j))
C               heff(j,i)=heff(i,j)
C            enddo
C         enddo
C      enddo
C      end subroutine
C!***********************************************************************
C
C       subroutine calc_heff(m0,m)
C      use mod_script
C      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      Heff=0.d0
C      nb_lec=(ndet-1)/2048+1
C      do ilec=1,nb_lec
C         long=min(2048,ndet-2048*(ilec-1))
C         do j=1,m
C            ll=(j-1)*((ndet-1)/2048+1)+ilec
C            call lirec(v3(1,j),ll,long,21)
C         enddo
C         do j=1,m
C            ll=(j-1)*((ndet-1)/2048+1)+ilec
C            call lirec(v4(1,j),ll,long,22)
C         enddo
C         do i=1,m
C            do j=1,i
C               heff(i,j)=heff(i,j)+dot_product(v3(:,i),v4(:,j))
C               heff(j,i)=heff(i,j)
C            enddo
C         enddo
C      enddo
C      end subroutine
C!***********************************************************************
C
C       subroutine calc_heff2(ind_ligne,ind_col,n_ligne,n_col)
C!
C! Calcul d'un rectangle inclus dans Heff
C! i1,i2 : indices de ligne
C! j1,j2 : indices de colonnes
C      use mod_script
C      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      integer ind_ligne(n_ligne),ind_col(n_col)
C      nb_lec=(ndet-1)/2048+1
C      heff(ind_ligne,ind_col)=0.d0
C      do ilec=1,nb_lec
C         long=min(2048,ndet-2048*(ilec-1))
C         do jj=1,n_ligne
C            j=ind_ligne(jj)
C            ll=(j-1)*((ndet-1)/2048+1)+ilec
C            call lirec(v3(1,j),ll,long,21)
C         enddo
C         do jj=1,n_col
C            j=ind_col(jj)
C            ll=(j-1)*((ndet-1)/2048+1)+ilec
C            call lirec(v4(1,j),ll,long,22)
C         enddo
C         do ii=1,n_ligne
C            i=ind_ligne(ii)
C            do jj=1,n_col
C               j=ind_col(jj)
C               !if(j>=i) then
C                  heff(i,j)=dot_product(v3(:,i),v4(:,j))
C                  heff(j,i)=heff(i,j)
C                  print*,'heff2',i,j,heff(i,j)
C               !endif
C            enddo
C         enddo
C      enddo
C      end subroutine
C!***********************************************************************

       subroutine calc_heff3(m0,m)
!
! Calcul d'un rectangle inclus dans Heff
! i1,i2 : indices de ligne
! j1,j2 : indices de colonnes
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      nb_lec=(ndet-1)/2048+1
      heff(:,m0+1:m)=0.d0
      print*,'m0,m',m0,m,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 tous les Psi
         do jj=1,di_heff
            j=iadr_heff(jj)
            print*,'j,jj',j,jj
            ll=(j-1)*((ndet-1)/2048+1)+ilec
            call lirec(v3(1,jj),ll,long,21)
         enddo
!
! On lit les Hpsi qui viennent d'etre calcules
         do jj=m0+1,m
            j=iadr_heff(jj)
            ll=(j-1)*((ndet-1)/2048+1)+ilec
            call lirec(v4(1,jj),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,m
               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=m+1,di_heff
            do j=m0+1,m
               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,m
            do j=i,m
               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,m
            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
!**************************************************************************

       subroutine calc_vect_suivant(v1,v2)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      real(8),dimension(ndet,nvec) :: v1,v2
      yw1=.false.
      icpu1=itemps(idum)
      do k=1,nvec
         if(ycvl(k)) cycle
         iq=0

c        on lit le vecteur (H-E)*PSI
         call lire(v2(:,1),k,ndet,23)
         rewind 20
         nsh=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

!           lecture des elements diagonaux
            read(20) diag(1:ilong)

c           boucle sur les det du bloc
            DO I=1,ilong
               iq=iq+1
               if(DABS(v2(Iq,1))<=1.d-25) then
                  v2(Iq,1)=0.d0
               else
!                 corriger le denominateur s'il est trop petit ou
!                 negatif
                  if(alam(K)-diag(I).gt.-1.d-5) then
                     nsh=nsh+1
                     v2(Iq,1)=v2(Iq,1)/(-1.d-5)
                  else
                     v2(Iq,1)=v2(Iq,1)/(alam(K)-diag(I))
                  endif
               endif
            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
         endif
c
c--------------------------------------------------
c     orthogonalisation aux vecteurs precedents
c--------------------------------------------------
c
         
          do ivieux=1,di_heff
             l=iadr_heff(ivieux)
             call lire(v1(:,1),l,ndet,21)
C         do kvec2=1,nvec
C            DO  LL=1,n_rep_vec(kvec2)
C               !print*,k,' : orthogonalisation au vecteur',kvec2,ll
C               l=rep_vec(ll,kvec2)
               call lire(v1(:,1),l,ndet,21)
               SUM=0.d0
               DO I=1,ndet
                  SUM=SUM+v1(I,1)*v2(I,1)
                  !print'(a,i4,3f18.8)','scal',i,v1(i,1),v2(i,1),sum
               enddo
               DO I=1,ndet
                  v2(I,1)=v2(I,1)-SUM*v1(I,1)
               enddo
            enddo
C         enddo
!
!        Normalisation
         SUM=0.d0
         DO I=1,ndet
            SUM=SUM+v2(I,1)*v2(I,1)
         enddo
         if(yw1)print*,'sum',sum,prec
         if(sum.lt.prec*prec*0.001) then
            print*,' le nouveau vecteur est de dimension nulle'
            exit
         endif
         SUM=1.d0/DSQRT(SUM)
         print*,'SUM',sum
         DO I=1,ndet
            v1(I,1)=SUM*v2(I,1)
         enddo
!
!        Ecriture sur 21
         do i=1,Dim_Heff
            if(yfree(i)) then
               print*,'suivant ecr sur',i
               print*,'V1',v1(1:10,1)
               call ecr(v1(:,1),i,ndet,21)
               nfree=nfree-1
               yfree(i)=.false.
               n_rep_vec(k)=n_rep_vec(k)+1
               rep_vec(n_rep_vec(k),k)=i
               act_vec(k)=i
               di_heff=di_heff+1
               iadr_heff(di_heff)=i
               print*,'di_heff',di_heff
               exit
            endif
         enddo
         print*,'yfree suivant',yfree
         print*,'act_vec suivant',act_vec
      enddo
      if(ytana) then
         icpu2=itemps(idum)-icpu1
         if(yw1)write(6,*)'Psi(m+1)      cpu',icpu2
      endif
      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)
      return
      end
       subroutine scrida1(mess,b,n)
      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)
      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

