!=======================================================================
!
! Routines:
!
! 1. haydock      Originally By MLT       Last Modified 6/24/08 (JRD)
!
!     Calculates the real and imaginary parts of the macroscopic dielectric
!     function starting from interaction matrix elements calculated by
!     the Kernel code. It uses interpolation in the matrix elements and
!     the Haydock recursion method. Spin-polarized case implemented.
!
!     For more details, see:
!     Rohlfing & Louie, PRB 62:(8), 4927 (2000)
!     Benedict & Shirley, PRB 59:(8), 5441 (1999)
!     R. Haydock, Comput. Phys. Commun. 20, 11 (1980)
!     G. Strinati, Rivista del Nuovo Cimento 11:(12), 1 (1988)
!
!     Please report bugs to: jdeslip@civet.berkeley.edu
!
!========================================================================

#include "f_defs.h"

subroutine haydock(eqp,xct,flag,nmax)

  use global_m
  use fullbz_m
  use genwf_m
  use intkernel_m
  use intwfn_m
  use misc_m
  use mtxel_optical_m
  use random_m
  implicit none

  type (eqpinfo), intent(inout) :: eqp
  type (xctinfo), intent(inout) :: xct
  type (flags), intent(in) :: flag
  integer, intent(in) :: nmax

  type (crystal) :: crys
  type (mmtsinfo) :: mmts
  type (symmetry) :: syms
  type (gspace) :: gvec
  type (grid) :: kg_fi, kgq_fi
  type (kpoints) :: kp_fi, kpq_fi
  type (wavefunction) :: wfnc_fi
  type (wavefunction) :: wfnvq_fi
  type (work_genwf) :: work, workq
  type (int_wavefunction) :: intwfnc
  type (int_wavefunction) :: intwfnv

  character :: tmpstr*128,filename*20
  integer :: ii,jj,ncount,nmat,nblock
  integer :: ikb, icb, ivb
  integer :: ik,ikq,ikt,ikrq,ikcvs,ikcvst,ic,iv,is
  integer :: seed, iunit_c,iunit_v
  integer :: ih,ith,n0
  real(DP) :: vol,vol1,sum,sum1
  real(DP) :: tsec(2),tmin(2),tmax(2),omega_plasma
  
  character*16, allocatable :: routnam(:)
  integer, allocatable :: routsrt(:)
  integer, allocatable :: fi2co_wfn(:,:),indexq_fi(:)
  real(DP), allocatable :: kco(:,:)
  SCALAR, allocatable :: &
    dcc(:,:,:,:,:),dvv(:,:,:,:,:),s1(:),s1_l(:),s1k(:,:,:),dummy(:), &
    hmtrx(:,:),s0(:),s0_l(:),hqpcc(:,:,:),hqpvv(:,:,:)
  real(DP), allocatable :: intp_coefs(:,:)

  PUSH_SUB(haydock)

  mmts%nmax = nmax

  if (xct%read_kpoints .and. peinf%inode.eq.0) then
    write(0,*) 'WARNING: you are using partial sampling with the Haydock iterative scheme!'
    write(0,*) 'The optical spectrum may not be meaningful...'
  endif
  if(mmts%nmax.eq.0.and.flag%spec.ne.1) then
    call die('missing number of iterations')
  endif

! If flag%spec.eq.1, just calculate the spectrum from input coefficients

  ith=21
  if (flag%spec.eq.1) then
    if (peinf%inode.eq.0) then
      call open_file(ith,file='eps2_moments',form='unformatted',status='old')
      read(ith) mmts%nmax,mmts%norm,mmts%vol,ii,xct%nspin
      SAFE_ALLOCATE(mmts%an, (mmts%nmax))
      SAFE_ALLOCATE(mmts%bn, (mmts%nmax))
      read(ith) (mmts%an(ii),ii=1,mmts%nmax)
      read(ith) (mmts%bn(ii),ii=1,mmts%nmax)
      write(6,*)
      write(6,*) 'Reading coefficients from file; nmax = ',mmts%nmax, ' norm= ',mmts%norm
      write(6,*) '     n    a(n)        b(n)  '
      do ii=1,mmts%nmax
        write(6,120) ii, mmts%an(ii),mmts%bn(ii)
      enddo
      call close_file(ith)
    endif
120 format(3x,i4,3x,2e12.5)

  else

!-----------------------
! Read wavefunctions on the fine grid

  call logit('Calling input')
  call timacc(2,1)
  call input(crys,gvec,kg_fi,kp_fi,syms,eqp,xct,flag, &
    omega_plasma,.false.,intwfnc)
  
  nmat = xct%nkpt_fi*xct%ncb_fi*xct%nvb_fi*xct%nspin
  vol = xct%nktotal*crys%celvol
  if (peinf%inode.eq.0) then
    write(6,'(a,f32.14,a)') 'Crystal volume = ',vol,' a.u.'
    write(6,*) ' number of valence bands = ',xct%nvb_fi
    write(6,*) ' number of cond. bands   = ',xct%ncb_fi
    write(6,*) ' number of spins   = ',xct%nspin
    write(6,'(a,f7.4,a)') ' Broadening: ',xct%eta,' eV'
  endif
  call timacc(2,2)

  SAFE_ALLOCATE(indexq_fi, (xct%nkpt_fi))
  if (flag%vm.eq.0 .or. .not. flag%read_dtmat) then
    call timacc(3,1)
    call logit('Calling input_q')
    call input_q(kp_fi,crys,gvec,kg_fi,kgq_fi,kpq_fi, &
      syms,xct,indexq_fi,eqp,flag,intwfnv)
    call timacc(3,2)
  endif

!----------------------------
! Calculate the transformation matrices from coarse-grid wavefunctions
! FHJ: These are the final transformation coefs that will be used to interpolate
! the kernel. However, we might use an unrestricted version of dvv/dcc to
! interpolate eqp if xct%unrestricted_transf==.true..
  SAFE_ALLOCATE(dvv, (xct%nvb_fi,xct%n1b_co,xct%nspin,xct%nkpt_fi,xct%npts_intp_kernel))
  SAFE_ALLOCATE(dcc, (xct%ncb_fi,xct%n2b_co,xct%nspin,xct%nkpt_fi,xct%npts_intp_kernel))
  SAFE_ALLOCATE(kco, (3,xct%nkpt_co))
  SAFE_ALLOCATE(fi2co_wfn, (xct%npts_intp_kernel,xct%nkpt_fi))
  SAFE_ALLOCATE(intp_coefs, (xct%npts_intp_kernel, xct%nkpt_fi))

  call logit('Calling intwfn')
  call timacc(4,1)
  call intwfn(kp_fi,crys,syms,xct,flag,gvec,kg_fi,kgq_fi, &
    dcc,dvv,kco,fi2co_wfn,indexq_fi,eqp,intwfnv,intwfnc,intp_coefs)
  call timacc(4,2)

  SAFE_DEALLOCATE_P(xct%ifmax)
  if (flag%vm.eq.0 .or. .not. flag%read_dtmat) then
    ! otherwise, we did not call input_q to allocate it
    SAFE_DEALLOCATE_P(xct%ifmaxq)
  endif

!----------------------------
! Initialize recursion states and coefficients.
! If there is a previous run, read previous states from unit ith and
! skip the calculation of velocity/momentum matrix elements.
!
!       nblock : size of cvs block in hmtrx

  nblock = xct%ncb_fi*xct%nvb_fi*xct%nspin
  if (xct%ipar .eq. 1) then
    peinf%nblockd=nblock
  else if (xct%ipar .eq. 2) then
    peinf%nblockd = xct%nvb_fi*xct%nspin
  else    
    peinf%nblockd = xct%nspin
  endif
  nmat= xct%nkpt_fi*nblock
  SAFE_ALLOCATE(s1, (nmat))
  SAFE_ALLOCATE(s1k, (xct%ncb_fi,xct%nvb_fi,xct%nspin))
  s1= 0.d0
  s1k= 0.d0

! Since this code always compute an odd number of an's and bn's,
! it will calculate nmax+1 coefficients if nmax is even
! solution: overshoot the array size

  mmts%nmaxp=mmts%nmax+1
  SAFE_ALLOCATE(mmts%an, (mmts%nmaxp))
  SAFE_ALLOCATE(mmts%bn, (mmts%nmaxp))
  mmts%an(:) = 0.d0
  mmts%bn(:) = 0.d0
  mmts%vol = vol
  SAFE_ALLOCATE(s0, (nmat))
  s0 = 0.d0

  if (flag%vm.eq.2) then
    if (peinf%inode.eq.0) then
      call open_file(ith,file='eps2_moments',form='unformatted',status='old')
      read(ith) n0,mmts%norm,vol1,ii,is
      if ((abs(vol1-mmts%vol).gt.1.d-10).or.ii.ne.nmat.or.is.ne.xct%nspin) then
        call die(' Parameter mismatch in old file eps2_moments')
      endif
      
      read(ith) (mmts%an(ii),ii=1,n0)
      read(ith) (mmts%bn(ii),ii=1,n0)
      
      read(ith) (s1(ii),ii=1,nmat)
      read(ith) (s0(ii),ii=1,nmat)
      call close_file(ith)
      write(6,*) 'Reading old data from file eps2_moments'
      sum = (4.d0*PI_D*ryd)**2*mmts%norm*mmts%an(1)/(mmts%vol*xct%nspin)
      write(6,*) 'Sum rule (excitons) : ',sum,' eV^2'
      write(6,*) '      n         a(n)        b(n)'
      do ih=1,n0
        write(6,120) ih,mmts%an(ih),mmts%bn(ih)
      enddo
    endif
#ifdef MPI
    call MPI_BCAST(n0, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, mpierr)
    call MPI_BCAST(mmts%norm, 1, MPI_REAL_DP, 0, MPI_COMM_WORLD, mpierr)
    call MPI_BCAST(mmts%an, mmts%nmaxp, MPI_REAL_DP, 0, MPI_COMM_WORLD, mpierr)
    call MPI_BCAST(mmts%bn, mmts%nmaxp, MPI_REAL_DP, 0, MPI_COMM_WORLD, mpierr)
    call MPI_BCAST(s1, nmat, MPI_SCALAR, 0, MPI_COMM_WORLD, mpierr)
    call MPI_BCAST(s0, nmat, MPI_SCALAR, 0, MPI_COMM_WORLD, mpierr)
#endif

  else
    n0=1
  endif

!-------------------------
! Calculate the velocity (or momentum) matrix elements.
! Each PE calculates a small number of them. At the end, share data.
!
! If flag%vm.eq.1, skip this part and just read the matrix elements
! from "vmtxel".

  call logit('Calling v/p matrix elements')
  if (flag%vm.eq.0) then
    if (flag%opr .eq. 2) then
      seed =5000
      call genrand_init(put=seed)
      ! Just set the s1 vector to be random numbers on all processors 
      ! The seed has to be the same on all processors otherwise we need
      ! to set this on one and broadcast..
      call mtxel_jdos(s1,nmat)
    else

      do ikt=1, peinf%ikt(peinf%inode+1)
        ik = peinf%ik(peinf%inode+1,ikt)
        ikq = indexq_fi(ik)
        ikrq = kg_fi%indr(ik)
      
        call genwf(crys,gvec,kg_fi,syms,wfnc_fi,xct,ik,ik,work,intwfnc, is_cond = .true.)
      
        call genwf(crys,gvec,kgq_fi,syms,wfnvq_fi,xct,ik,ikq,workq,intwfnv, is_cond = .false.)
        if (flag%opr.eq.0) then
          call mtxel_v(wfnc_fi,wfnvq_fi,gvec,xct%qshift,wfnc_fi%nband,wfnvq_fi%nband,s1k)
        elseif (flag%opr.eq.1) then
          call mtxel_m(crys,wfnc_fi,wfnvq_fi,gvec,eqp,xct,wfnc_fi%nband,wfnvq_fi%nband,s1k,ik,.true.)
        endif
        do is=1,xct%nspin
          do ic=1,xct%ncb_fi
            do iv=1,xct%nvb_fi
              s1(bse_index(ik, ic, iv, is, xct)) = s1k(ic,iv,is)
            enddo
          enddo
        enddo
        SAFE_DEALLOCATE_P(wfnc_fi%cg)
        SAFE_DEALLOCATE_P(wfnc_fi%isort)
        SAFE_DEALLOCATE_P(wfnvq_fi%cg)
        SAFE_DEALLOCATE_P(wfnvq_fi%isort)
      enddo

      ! typedefs initializes all of these ikolds to 0
      if(work%ikold /= 0) then
        SAFE_DEALLOCATE_P(work%cg)
        SAFE_DEALLOCATE_P(work%isort)
        SAFE_DEALLOCATE_P(work%ph)
        SAFE_DEALLOCATE_P(work%ind)
      endif
      if(workq%ikold /= 0) then
        SAFE_DEALLOCATE_P(workq%cg)
        SAFE_DEALLOCATE_P(workq%isort)
        SAFE_DEALLOCATE_P(workq%ph)
        SAFE_DEALLOCATE_P(workq%ind)
      endif

! Share matrix elements

#ifdef MPI
      SAFE_ALLOCATE(dummy, (nmat))
      dummy = s1
      call MPI_ALLREDUCE(dummy,s1,nmat,MPI_SCALAR,MPI_SUM, MPI_COMM_WORLD,mpierr)
      SAFE_DEALLOCATE(dummy)
#endif

    endif ! Whether jdos or (velocity/momentum)

    if (peinf%inode.eq.0) then
      write(6,'(1x,a)') 'Writing matrix elements into vmtxel'
      call open_file(16,file='vmtxel',form='unformatted',status='replace')
      write(16) xct%nkpt_fi,xct%ncb_fi,xct%nvb_fi,xct%nspin,flag%opr
      write(16) (s1(ikcvs),ikcvs=1,nmat)
      call close_file(16)
    endif

  else if(flag%vm == 1) then  ! ...if the matrix elements were calculated already

    if (peinf%inode.eq.0) then
      write(6,'(1x,a)') 'Reading matrix elements from vmtxel'
      call open_file(16,file='vmtxel',form='unformatted',status='old')
      read(16) ik,ic,iv,is,ii
      if (ik.ne.xct%nkpt_fi.or.ic.ne.xct%ncb_fi.or.iv.ne.xct%nvb_fi &
        .or.is.ne.xct%nspin.or.ii.ne.flag%opr) then
        write(tmpstr,*) 'parameter mismatch in vmtxel ', &
          ik,ic,iv,is,ii,xct%nkpt_fi,xct%ncb_fi,xct%nvb_fi,xct%nspin,flag%opr
        call die(tmpstr)
      endif
      
      read(16) (s1(ikcvs),ikcvs=1,nmat)
      call close_file(16)
    endif
#ifdef MPI
    call MPI_BCAST(s1,nmat,MPI_SCALAR,0,MPI_COMM_WORLD,mpierr)
#endif

  endif

  if (flag%vm.eq.0 .or. .not. flag%read_dtmat) then
    call dealloc_grid(kgq_fi)
  endif

  SAFE_DEALLOCATE(s1k)
  SAFE_DEALLOCATE(indexq_fi)

! JRD: Now close the no longer needed wavefunction files

  if (xct%iwriteint.eq.1) then
    SAFE_DEALLOCATE_P(intwfnc%cgk)
    SAFE_DEALLOCATE_P(intwfnv%cgk)
    SAFE_DEALLOCATE_P(intwfnc%isort)
    SAFE_DEALLOCATE_P(intwfnv%isort)
  endif
  
  if (xct%iwriteint.eq.0 .and. (flag%vm.ne.1 .or. .not. flag%read_dtmat)) then
    write(filename,'(a,i4.4)') 'INT_VWFNQ_', peinf%inode
    iunit_v = 128+(2*peinf%inode)+2
    call open_file(iunit_v, filename, status = 'old')
    call close_file(iunit_v, delete = .true.) ! files INT_VWFNQ_*

    write(filename,'(a,i4.4)') 'INT_CWFN_', peinf%inode
    iunit_c = 128+(2*peinf%inode)+1
    call open_file(iunit_c, filename, status = 'old')
    call close_file(iunit_c, delete = .true.) ! files INT_CWFN_*
  endif

!-------------------------
! Calculate the non-interacting spectrum. Only one PE works

  call logit('Calling absp0')

  if (peinf%inode.eq.0) call absp0(eqp,xct,s1,vol,omega_plasma,flag)

!---------------------------
! Build Hamiltonian matrix. Diagonal part comes from the "non-interacting"
! quasiparticle Hamiltonians.  If the QP Greens func is diagonal,
! then these are just the quasiparticle energy differences on the
! diagonal.  The more general case is:
!
!       <cvk|H0|c'v'k'> = delta(k,k') *
!            [ <c|hqp|c'>*delta(v',v) - delta(c,c')*<v'|hqp|v> ]
!
! The rest of the Hamiltonian, which is the electron-hole interaction,
! comes from interpolation further below.

  call logit('Building non-interacting Hamiltonian')
  SAFE_ALLOCATE(hmtrx, (xct%nkpt_fi*nblock,peinf%nblocks*peinf%nblockd))
  hmtrx(:,:) = 0.d0

! Loop over kpoints

  do ikt=1,peinf%ibt(peinf%inode + 1)
    ik=peinf%ikb(peinf%inode+1,ikt)

! Build <c|hqp|c'> and <v|hqp|v'> for this kpoint

    SAFE_ALLOCATE(hqpcc, (xct%ncb_fi,xct%ncb_fi,xct%nspin))
    SAFE_ALLOCATE(hqpvv, (xct%nvb_fi,xct%nvb_fi,xct%nspin))
    hqpcc = 0.0d0
    hqpvv = 0.0d0

! Put QP energies on diagonals of hqpcc and hqpvv to start

    do is=1,xct%nspin
      do ic=1,xct%ncb_fi
        hqpcc(ic,ic,is) = eqp%ecqp(ic,ik,is)
      enddo
      do iv=1,xct%nvb_fi
        hqpvv(iv,iv,is) = eqp%evqp(iv,ik,is)
      enddo
    enddo

! Read possible offdiagonal QP elements from "hqp.<ik>" file
! if it exists JRD: This is broken for now.  Someone should fix
! it in the future if they want to use it

        !if (ik.lt.10) then
        !  write(tmpstr,'(a,i1)') 'hqp.',ik
        !else if (ik.lt.100) then
        !  write(tmpstr,'(a,i2)') 'hqp.',ik
        !else if (ik.lt.1000) then
        !  write(tmpstr,'(a,i3)') 'hqp.',ik
        !else if (ik.lt.10000) then
        !  write(tmpstr,'(a,i4)') 'hqp.',ik
        !else
        !  write(0,*) 'too many kpoints for reading hqp'
        !endif
        !call open_file(9,file=tmpstr,form='formatted',status='old',iostat=is)
        !if (is.eq.0) then
        !  if (peinf%inode.eq.0) then
        !    write(6,*) 'Reading offdiagonal hqp from file ',tmpstr
        !    write(6,*) 'All values in eV'
        !  endif
        !  do
        !    read(9,*,end=999) nocc,ii,jj,x,y
!
!! if ii and jj both refer to valence, states, put
!! matrix element into hqpvv
!
!            if ((ii<=nocc).and.(ii>nocc-xct%nvb_fi).and. &
!            (jj<=nocc).and.(jj>nocc-xct%nvb_fi)) then
!              if (peinf%inode.eq.0) write(6,'(a,2i5,2f20.10)') ' hqp(v,vp) = ',ii,jj,x,y
!              ii=nocc-ii+1
!              jj=nocc-jj+1
!              is = 1
!#ifdef CPLX
!              hqpvv(ii,jj,is) = CMPLX(x,y)/ryd
!#else
!              hqpvv(ii,jj,is) = x/ryd
!#endif
!            else if ((ii>nocc).and.(ii<=nocc+xct%ncb_fi).and. &
!            (jj>nocc).and.(jj<=nocc+xct%ncb_fi)) then
!              if (peinf%inode.eq.0) write(6,'(a,2i5,2f20.10)') ' hqp(c,cp) = ',ii,jj,x,y
!              ii=ii-nocc
!              jj=jj-nocc
!              is = 1
!#ifdef CPLX
!              hqpcc(ii,jj,is) = CMPLX(x,y)/ryd
!#else
!              hqpcc(ii,jj,is) = x/ryd
!#endif
!            endif
!          enddo
! 999      call close_file(9)
!          write(6,*)
!        endif ! if hqp.<ik> was found

! Now build hamiltonian from hqpcc and hqpvv

    do is=1,xct%nspin
      do iv=1,xct%nvb_fi
        do ic=1,xct%ncb_fi
          !do icp=1,xct%ncb_fi
          ikb=peinf%ikb(peinf%inode+1,ikt)
          if (xct%ipar .eq. 1) then
            ikcvs = bse_index(ikt, ic, iv, is, xct)
            ivb=iv
            icb=ic
          else if (xct%ipar .eq. 2 .and. ic .eq. 1) then
            ikcvs = bse_index(ikt, ic, iv, is, xct, ncband = 1)
            icb=peinf%icb(peinf%inode+1,ikt)
            ivb=iv
          else if (xct%ipar .eq. 3 .and. iv .eq. 1 .and. ic .eq. 1) then
            ikcvs = bse_index(ikt, ic, iv, is, xct, ncband = 1, nvband = 1)
            ivb=peinf%ivb(peinf%inode+1,ikt)
            icb=peinf%icb(peinf%inode+1,ikt)
          else
            cycle
          endif
          ikcvst = bse_index(ikb, icb, ivb, is, xct)
          hmtrx(ikcvst,ikcvs) = hqpcc(icb,icb,is) - hqpvv(ivb,ivb,is)

          !enddo
        enddo
      enddo

    enddo
    SAFE_DEALLOCATE(hqpcc)
    SAFE_DEALLOCATE(hqpvv)
  enddo ! loop on k-points on this processor

!#ifdef VERBOSE
!      call logit('Non-int Hamiltonian, node 0, kpt (0,0):', &
!      peinf)
!      if (peinf%inode.eq.0) then
!        ikt=peinf%ik(peinf%inode+1,1)
!        ik=1
!        do ic=1,min(5,xct%ncb_fi)
!          do iv=1,xct%nvb_fi
!            do icp=1,min(5,xct%ncb_fi)
!              do ivp=1,xct%nvb_fi
!                is = 1
!                ikcvs = bse_index(ik, ic, iv, is, xct)
!                ikcvst = bse_index(ikt, icp, ivp, is, xct)
!                write(6,'(4i5,2f15.8)') ic,iv,icp,ivp,hmtrx(ikcvs,ikcvst)
!              enddo
!            enddo
!          enddo
!        enddo
!      endif
!#endif

!-----------------------------------------------------------------------
! Define the mapping of eigenvectors: the ii-th column of the matrix
! egs(:,:) stored in PE #ipe will contain the eigenvector of order
! peinf%peig(ipe,ii). The total number of eigenvectors stored in
! each processor is given by peinf%neig(1:peinf%npes).
!  pblock >= maxval(peinf%neig(1:peinf%npes))
! NOTE: this is taken from diag code, but it also holds for the
! mapping of hmtrx, that has the same layout as egs (Murilo)

  SAFE_ALLOCATE(peinf%neig, (peinf%npes))
  SAFE_ALLOCATE(peinf%peig, (peinf%npes,peinf%nblocks*peinf%nblockd))
  peinf%neig=0
  peinf%peig=0
  ii=1
  do jj=1,nmat
    if (ii.eq.peinf%npes+1) ii=1
    peinf%neig(ii)=peinf%neig(ii)+1
    peinf%peig(ii,peinf%neig(ii))=jj
    if (mod(jj,peinf%nblockd).eq.0) ii=ii+1
  enddo

!---------------------------------
! Initialize local states : s1_l  --> local part of s1
!                           s0_l  --> local part of s0
! Whenever s1 and s0 change, their local parts must be updated

  SAFE_ALLOCATE(s1_l, (peinf%nblocks*peinf%nblockd))
  !MJ : CHANGE THIS

  call local_s(nmat,s1,s1_l)
  SAFE_ALLOCATE(s0_l, (peinf%nblocks*peinf%nblockd))
  call local_s(nmat,s0,s0_l)

!--------------------------------
! Interpolation scheme in the Kernel

  call logit('Calling intkernel')
  call timacc(5,1)
  call intkernel(crys,kg_fi,kp_fi,syms,xct,hmtrx,dcc,dvv,kco,fi2co_wfn,flag,gvec,intp_coefs)
  call timacc(5,2)
  call dealloc_grid(kg_fi)

  SAFE_DEALLOCATE(fi2co_wfn)
  SAFE_DEALLOCATE(dcc)
  SAFE_DEALLOCATE(dvv)
  SAFE_DEALLOCATE(kco)

#ifdef VERBOSE
  call logit('Interacting Hamiltonian, node 0, kpt (0,0):')
!      if (peinf%inode.eq.0) then
!        ikt=peinf%ik(peinf%inode+1,1)
!        ik=1
!        do ic=1,min(5,xct%ncb_fi)
!          do iv=1,xct%nvb_fi
!            do icp=1,min(5,xct%ncb_fi)
!              do ivp=1,xct%nvb_fi
!                is = 1
!                ikcvs = bse_index(ik, ic, iv, is, xct)
!                ikcvst = bse_index(ikt, icp, ivp, is, xct)
!                write(6,'(4i5,2f15.8)') ic,iv,icp,ivp,hmtrx(ikcvs,ikcvst)
!              enddo
!            enddo
!          enddo
!        enddo
!      endif
#endif

!------------------------------
! Normalize s1 to get the first-order Haydock state: |1>= (e.v) |Ground>
! Calculate the first a coefficient

  if (flag%vm .ne. 2) then

    mmts%norm =  dble( DOT_PRODUCT(s1,s1) )
    sum = sqrt(mmts%norm)
    s1(:) = s1(:)/sum
    call local_s(nmat,s1,s1_l)
  
    sum1 = dble( DOT_PRODUCT(s1,MATMUL(hmtrx,s1_l)) )
#ifdef MPI
    call MPI_Allreduce(sum1,sum,1,MPI_REAL_DP,MPI_SUM,MPI_COMM_WORLD,mpierr)
    sum1 = sum
#endif
    mmts%an(1) = sum1

#ifdef MPI
    call MPI_BARRIER(MPI_COMM_WORLD,mpierr)
#endif

!--------------------------
! Calculate the second order state, s0, and the first b coefficient

    s0 = MATMUL(hmtrx,s1_l)

#ifdef MPI
    SAFE_ALLOCATE(dummy, (nmat))
    dummy = s0
    call MPI_Allreduce(dummy,s0,nmat,MPI_SCALAR,MPI_SUM,MPI_COMM_WORLD,mpierr)
    SAFE_DEALLOCATE(dummy)
#endif

    s0(:) = s0(:) - s1(:)*mmts%an(1)
    sum = dble( DOT_PRODUCT(s0,s0) )
    mmts%bn(1) = sum
    s0(:) = s0(:)/sqrt(sum)
    call local_s(nmat,s0,s0_l)

  endif

  if (peinf%inode.eq.0) then
    write(6,750) mmts%nmax
750 format(/,'Performing Haydock recursion with ',i5,' steps. ')
    write(6,*) 'Norm of first state : ',mmts%norm
    
! Check plasmon sum rule
!
! Exact value of sum rule:
! sum = (pi/2.d0)*( plasma frequency )^2

    sum = (4.d0*PI_D*ryd)**2*mmts%norm*mmts%an(1)/ &
      (mmts%vol*xct%nspin)
    write(6,*) 'Sum rule (excitons) : ',sum,' eV^2'
    write(6,*) '      n         a(n)        b(n)'
    write(6,120) n0,mmts%an(n0),mmts%bn(n0)
  endif

#ifdef MPI
  call MPI_BARRIER(MPI_COMM_WORLD,mpierr)
#endif

!-----------------------------------------------------------------------
! Start Haydock recursion method. At this point, n0 is always an odd number
! After each pair of iterations, we have the states:
!              | ih+1 >  ---  s1
!              | ih+2 >  ---  s0
! Lower states are lost.

  call timacc(6,1)
  do ih=n0+1,mmts%nmax,2
    call iterate(mmts,xct,nmat,ih,hmtrx,s1,s0)
  enddo
  call timacc(6,2)
  SAFE_DEALLOCATE(hmtrx)
  SAFE_DEALLOCATE(s1)
  SAFE_DEALLOCATE(s0)
  SAFE_DEALLOCATE_P(peinf%neig)
  SAFE_DEALLOCATE_P(peinf%peig)

!---------------------------
! Calculate absorption spectrum using Haydock recursion

  endif

  if (peinf%inode.eq.0) call absh(mmts,xct%nspin,xct%eta)
  SAFE_DEALLOCATE_P(mmts%an)
  SAFE_DEALLOCATE_P(mmts%bn)
  SAFE_DEALLOCATE_P(eqp%eclda)
  SAFE_DEALLOCATE_P(eqp%evlda)
  SAFE_DEALLOCATE(intp_coefs)

  if (xct%iwritecoul .eq. 1 .and. peinf%inode .eq. 0) then
    call close_file(19) ! file vcoul
  endif

#ifdef MPI
  call MPI_BARRIER(MPI_COMM_WORLD,mpierr)
#endif
  if (eqp%spl_tck%n>0) then
    SAFE_DEALLOCATE_P(eqp%spl_tck%t)
    SAFE_DEALLOCATE_P(eqp%spl_tck%c)
  endif

!----------------------------
! Time accounting

  SAFE_ALLOCATE(routnam, (60))
  routnam(1)='TOTAL:'
  routnam(2)='INPUT:'
  routnam(3)='INPUT_Q:'
  routnam(4)='INTWFN:'
  routnam(5)='INTKERNEL:'
  routnam(6)='ITERATE:'
  routnam(41)='IW Input_co:'
  routnam(42)='IW Interp:'
  routnam(43)='IW Genwf:'
  routnam(44)='IW Gwnwf_Co:'
  routnam(45)='IW Mtxel_t:'
  routnam(46)='IW Write:'
  routnam(47)='IW Reduce:'
  routnam(51)='IK Setup:'
  routnam(52)='IK C-Check:'
  routnam(53)='IK Input:'
  routnam(54)='IK Inteps:'
  routnam(55)='IK Vcoul:'
  routnam(56)='IK Cache:'
  routnam(57)='IK Interp:'
  routnam(58)='IK Sum:'
  SAFE_ALLOCATE(routsrt, (21))
  routsrt=(/ (ii,ii=2,6), (ii,ii=41,47), (ii,ii=51,58), 1 /)

  call timacc(1,2)
  if(peinf%inode.eq.0) then
    write(6,*)
    write(6,9000) 'CPU [s]','WALL [s]','#'
    write(6,*)
  endif
  
  do ii=1,ubound(routsrt, 1)
    call timacc(routsrt(ii),3,tsec,ncount)
#ifdef MPI
    call MPI_ALLREDUCE(tsec,tmin,2,MPI_REAL_DP,MPI_MIN,MPI_COMM_WORLD,mpierr)
    call MPI_ALLREDUCE(tsec,tmax,2,MPI_REAL_DP,MPI_MAX,MPI_COMM_WORLD,mpierr)
#else
    tmin = tsec
    tmax = tsec
#endif
    if(peinf%inode==0) then
      if (ii>1) then
        if (routsrt(ii)-routsrt(ii-1)/=1) write(6,*)
      endif
      write(6,9001) routnam(routsrt(ii)),tmin(1),tmin(2),ncount
      write(6,9002) tsec(1),tsec(2)
      write(6,9003) tmax(1),tmax(2)
    endif
  enddo

9000 format(17x,a13,  3x,a13,  3x,a8)
9001 format(1x,a11,'(min.)',f13.3,3x,f13.3,3x,i8)
9002 format(  12x,'(PE 0)',f13.3,3x,f13.3)
9003 format(  12x,'(max.)',f13.3,3x,f13.3)

  POP_SUB(haydock)
  return

end subroutine haydock
