#include "f_defs.h"

!-----------------------------------------------------------------------
subroutine input(crys,gvec,kg,kp,syms,eqp,xct,flag, &
  omega_plasma,is_diag,intwfnc)
!-----------------------------------------------------------------------
!
!     Read data from file WFN_fi and initialize variables
!
!     output: crys, gvec, kg, syms, eqp types
!             INT_CWFN_* files (if flag%vm.ne.1.or. .not. flag%read_dtmat)
!
  use global_m
  use checkbz_m
  use eqpcor_m
  use fullbz_m
  use input_utils_m
  use misc_m
  use scissors_m
  use sort_m
  use wfn_rho_vxc_io_m
  use intpts_m
  use io_utils_m
  implicit none

  type (crystal), intent(out) :: crys
  type (gspace), intent(out) :: gvec
  type (grid), intent(out) :: kg
  type (kpoints), intent(out) :: kp
  type (symmetry), intent(out) :: syms
  type (eqpinfo), intent(inout) :: eqp
  type (xctinfo), intent(inout) :: xct
  type (flags), intent(in) :: flag
  real(DP), intent(out) :: omega_plasma
  logical, intent(in) :: is_diag
  type (int_wavefunction), intent(out) :: intwfnc

  type (wavefunction) :: wfnc
  character :: filenamec*20
  character :: tmpfn*16
  character :: fncor*32
  integer :: iunit_c,iwrite

  integer :: ii,jj,kk,nn,nmat,is,isp,ik,irk,irk_kp,ib,ib_kp
  integer :: dest,tag,ic,iv,iwritetotal,ijk
  integer :: irks
  real(DP) :: diffvol,vcell,kt(3),div
  real(DP) :: test,tol,qtot
  real(DP), allocatable :: eltr(:),kltr(:,:),ek_tmp(:)
  integer, allocatable :: kcvltr(:,:),indxk(:),k_tmp(:,:)
  integer, allocatable :: index(:),isend(:),iwriteik(:)
  SCALAR, allocatable :: cg(:,:), cgarray(:)

  character(len=3) :: sheader
  integer :: iflavor
  type(gspace) :: gvec_kpt
  integer :: last_ng, last_ng_match, last_ikt
  logical :: skip_checkbz, broken_degeneracy
  !> Number of bands that were corrected (via scissors or eqp). We can`t find 
  !! the FE using more bands than this number.
  integer :: bands_cor, minband
  type(progress_info) :: prog_info

!-----------------------------------------------------------------------
! Read info for crystal from WFN_fi

  PUSH_SUB(input)

  if(peinf%inode == 0) call open_file(25,file='WFN_fi',form='unformatted',status='old')

  sheader = 'WFN'
  iflavor = 0
  call read_binary_header_type(25, sheader, iflavor, kp, gvec, syms, crys, &
    dont_warn_kgrid=xct%patched_sampling.or..not.xct%is_absorption)
  call check_trunc_kpts(xct%icutv, kp)

!-----------------------------------------------------------------------
!     Read info for g-vectors from WFN_fi
!

  call logit('input:  reading gvec info')

  SAFE_ALLOCATE(gvec%components, (3, gvec%ng))
  call read_binary_gvectors(25, gvec%ng, gvec%ng, gvec%components)

  call get_volume(vcell,crys%bdot)
  diffvol=abs(crys%celvol-vcell)
  if (diffvol.gt.TOL_Small) then
    call die('volume mismatch', only_root_writes = .true.)
  endif

  xct%nspin=kp%nspin
  if(xct%nspin == 2 .and. flag%krnl == 0) &
    call die("spin_triplet concept applies only to a spin-unpolarized calculation.", only_root_writes = .true.)

  if(any(kp%ifmax(:,:) == 0)) &
    call die("BSE codes cannot handle a system where some k-points have no occupied bands.", only_root_writes = .true.)

  kp%nvband=minval(kp%ifmax(:,:)-kp%ifmin(:,:))+1
  kp%ncband=kp%mnband-maxval(kp%ifmax(:,:))

!-----------------------------------------------------------
! Manual override of band numbers

  if (xct%vmax.ne.0) then
    kp%nvband = xct%vmax-xct%vmin+1
    kp%ncband = kp%mnband-xct%vmax
    if (peinf%inode.eq.0) then
      write(6,*)
      write(6,*) '*** Overwrite min/max occupied state for fine-grid wavefunctions'
      write(6,*) '*** kp%nvband =',kp%nvband,' kp%ncband =',kp%ncband
      write(6,*)
    endif
  endif

!-----------------------------------------------------------
! Manual override of regular grid
! it matters only if you want to perform minicell averages

  if (xct%rgrid(1).ne.0) kp%kgrid = xct%rgrid

!----------------------------------------------------------------
! (gsm) check whether the requested number of bands
!       is available in the wavefunction file

! we only use the conduction bands from WFN_fi
! if flag%vm.eq.1.and.flag%read_dtmat we don`t need them at all

  if(flag%vm .ne. 1 .or. .not. flag%read_dtmat) then

    if(xct%ncb_fi.gt.kp%ncband) then
      call die("The requested number of conduction bands is not available in WFN_fi.")
    endif

  endif

!----------------------------------------------------------------------
!     Read the k-point sampling from kpoints (if it exists) or from
!     WFN_fi. In either case, this sampling will define the irreducible
!     Brillouin zone.

  if (xct%read_kpoints) then
    if (peinf%inode.eq.0) then
      call open_file(9,file='kpoints',form='formatted',status='old')
      read(9,*) kg%nr
      SAFE_ALLOCATE(kg%r, (3,kg%nr))
      do ii=1,kg%nr
        read(9,*) (kg%r(jj,ii),jj=1,3),div
        kg%r(:,ii) = kg%r(:,ii)/div
      enddo
      call close_file(9)
    endif
#ifdef MPI
    call MPI_BCAST(kg%nr,   1,     MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
    if(peinf%inode.ne.0) then
      SAFE_ALLOCATE(kg%r, (3,kg%nr))
    endif
    call MPI_BCAST(kg%r,    3*kg%nr,MPI_REAL_DP,0,MPI_COMM_WORLD,mpierr)
#endif

!     indxk : stores the correspondence between k-points kg%r and kp%rk
!     (it is used to select the set of wavefunctions to be stored)
!     tol : tolerance in the coordinates of k-points

    tol = TOL_Small
    SAFE_ALLOCATE(indxk, (kg%nr))
    indxk=0
    do jj=1,kg%nr
      do ii=1,kp%nrk
        kt(:) = kg%r(:,jj) - kp%rk(:,ii)
        if (all(abs(kt(1:3)).lt.tol)) then
          if (indxk(jj).ne.0) write(0,*) 'WARNING: multiple definition of k-point',jj,indxk(jj),kg%r(:,jj)
          indxk(jj)=ii
        endif
      enddo
      
!     If some k-point listed in kg%r is not found in WFN_fi, indxk
!     will store zero. Later, the job will stop in genwf.

      if (indxk(jj).eq.0) write(0,*) 'WARNING: could not find vector ',kg%r(:,jj),' in WFN_fi'
    enddo
  else
    kg%nr=kp%nrk
    SAFE_ALLOCATE(kg%r, (3,kg%nr))
    kg%r(1:3,1:kg%nr)=kp%rk(1:3,1:kp%nrk)
    SAFE_ALLOCATE(indxk, (kg%nr))
    do ii=1,kg%nr
      indxk(ii) = ii
    enddo
  endif

!-----------------------------------------------------------------------
!     Generate full brillouin zone from irreducible wedge, rk -> fk
!
!     If flag%bz0.eq.1, only Identity will be used as
!     symmetry operation. In this case, kg%r (irreducible BZ) and kg%f
!     (full BZ) will be identical.
!
  if (flag%bz0.eq.1 .and. .not. xct%is_absorption) then
    ! in the inteqp code, we want to leave the k-points alone, if symmetries are not being used.
    call fullbz(crys,syms,kg,1,skip_checkbz,wigner_seitz=.false.,paranoid=.false.,do_nothing=.true.)
  else if (flag%bz0.eq.1) then
    call fullbz(crys,syms,kg,1,skip_checkbz,wigner_seitz=.true.,paranoid=.true.)
  else
    call fullbz(crys,syms,kg,syms%ntran,skip_checkbz,wigner_seitz=.true.,paranoid=.true.)
  endif
  tmpfn='WFN_fi'
  if (.not. skip_checkbz .and. .not.xct%patched_sampling) then
    call checkbz(kg%nf,kg%f,kp%kgrid,kp%shift,crys%bdot, &
      tmpfn,'k',.true.,xct%freplacebz,xct%fwritebz)
  endif
!
  if (flag%bz0.eq.0.and.peinf%inode.eq.0) write(6,801)
  if (flag%bz0.eq.1.and.peinf%inode.eq.0) write(6,802)
801 format(1x,'Using symmetries to expand the fine-grid sampling',/)
802 format(1x,'No symmetries used in the fine grid-sampling',/)
!
  xct%nkpt_fi = kg%nf
  xct%nktotal = kg%nf
  if (xct%patched_sampling) then
    ! FHJ: the main assumption of the patched sampling is that the volume of
    ! each mini-BZ is given by the number of k-points before decimating the WFN.
    ! Still, shouldn`t this line be used always, even for regular sampling?
    xct%nktotal = product(kp%kgrid)
  endif
  
  if (peinf%inode .eq. 0) then
    write(6,"(1x,'kgrid:',3i4)") kp%kgrid
  endif
  
!-----------------------------------------------------------------------

  SAFE_ALLOCATE(kp%elda, (kp%mnband, kp%nrk, kp%nspin))
  kp%elda(:,:,:) = kp%el(:,:,:)
  call scissors_shift(kp, eqp%scis, eqp%spl_tck)

!-----------------------------------------------------------------------
! If quasi-particle correction requested, read the corrected
! qp energies from file (in eV)

  bands_cor = kp%mnband
  minband = 1
  if(xct%eqp_corrections) then
    fncor='eqp.dat'
    bands_cor = maxval(kp%ifmax(:,:)) + xct%ncb_fi
    minband = minval(kp%ifmax(:,:)-xct%nvb_fi+1)
    ! FIXME: for metals this is asking for a few more bands than actually needed on some k-points
    call eqpcor(fncor,peinf%inode,peinf%npes,kp,&
      minval(kp%ifmax(:,:)-xct%nvb_fi+1),bands_cor,0,0,kp%el,kp%el,kp%el,1,0)
  endif

  call find_efermi(xct%rfermi, xct%efermi, xct%efermi_input, kp, bands_cor, minband, &
    "fine grid", should_search = .true., should_update = .true., write7 = .false.)

  call assess_degeneracies(kp, kp%el(kp%mnband, :, :), kp%mnband - 1, xct%efermi, TOL_Degeneracy)

  call calc_qtot(kp, crys%celvol, xct%efermi, qtot, omega_plasma, write7 = .false.)

! DAS: degenerate subspace check

  ! degeneracy does not matter for WFN_fi in inteqp
  if((flag%vm .ne. 1 .or. .not. flag%read_dtmat) .and. peinf%inode == 0 .and. xct%is_absorption) then
    if(xct%ncb_fi.eq.kp%ncband) then
      call die("You must provide one more conduction band in WFN_fi in order to assess degeneracy.")
    endif
    broken_degeneracy = .false.
    do jj = 1, kp%nspin
      do ii = 1, kp%nrk
        if(abs(kp%elda(kp%ifmax(ii, jj) + xct%ncb_fi, ii, jj) &
          - kp%elda(kp%ifmax(ii, jj) + xct%ncb_fi + 1, ii, jj)) .lt. TOL_Degeneracy) then
          broken_degeneracy = .true.
        endif
      enddo
    enddo

    if(broken_degeneracy) then
      if(xct%degeneracy_check_override) then
        write(0,'(a)') &
          "WARNING: Selected number of conduction bands breaks degenerate subspace in WFN_fi. " // &
          "Run degeneracy_check.x for allowable numbers."
        write(0,*)
      else
        write(0,'(a)') &
          "Run degeneracy_check.x for allowable numbers, or use keyword " // &
          "degeneracy_check_override to run anyway (at your peril!)."
        call die("Selected number of conduction bands breaks degenerate subspace in WFN_fi.")
      endif
    endif
  endif

!-----------------------------------------------------------------------
!     Work with energy arrays: ec,ev,eclda,evlda (all in Ryd!)
!     xct%evqp          QP valence energies
!     xct%ecqp          QP conduction energies
!     xct%evlda         LDA valence energies (used only
!        with momentum operator)
!     xct%eclda         LDA conduction energies (idem)
!      The label of bands in xct%evqp and xct%evlda is again reversed:
!      from higher to lower energies.

  SAFE_ALLOCATE(eqp%evqp, (xct%nvb_fi,xct%nkpt_fi,xct%nspin))
  SAFE_ALLOCATE(eqp%ecqp, (xct%ncb_fi,xct%nkpt_fi,xct%nspin))
  SAFE_ALLOCATE(eqp%evlda, (xct%nvb_fi,xct%nkpt_fi,xct%nspin))
  SAFE_ALLOCATE(eqp%eclda, (xct%ncb_fi,xct%nkpt_fi,xct%nspin))

! FHJ: loop thru indices on `eqp` grid, and then find the
!      corresponding labels on the `kp` grid
  do is=1,xct%nspin
    do irk=1,xct%nkpt_fi
      !irkq = index of q-pt on `kp` grid
      irk_kp = indxk(kg%indr(irk))

      !loop thru bands of `kp` grid
      do ib_kp=1, kp%mnband

        !ib = band index on `eqp` grid
        ib = kp%ifmax(irk_kp,is) - ib_kp + 1

        if (ib > 0) then
          !if ib is one of the selected valence bands
          if (ib <= xct%nvb_fi) then
            eqp%evqp    (ib, irk, is) = kp%el  (ib_kp, irk_kp, is)
            eqp%evlda   (ib, irk, is) = kp%elda(ib_kp, irk_kp, is)
          endif
        else
          ib = 1 - ib !transform negative val. index into positive cond. index
          !if ib is one of the selected conduction bands
          if (ib <= xct%ncb_fi) then
            eqp%ecqp (ib, irk, is) = kp%el  (ib_kp, irk_kp, is)
            eqp%eclda(ib, irk, is) = kp%elda(ib_kp, irk_kp, is)
          endif
        endif

      enddo
    enddo
  enddo
      
  if (peinf%inode.eq.0) then
    call scissors_write(6, eqp%scis)
  endif

!-----------------------------------------------------------------------
!       Distribute kpoints among the PEs
!
  call logit('input:  calling distrib')
  call distrib(xct,gvec%FFTgrid,kp%kgrid,is_diag)

!-----------------------------------------------------------------------
! gsm: store xct%ifmax for generating eqp/eqp_q.dat in intwfn

  SAFE_ALLOCATE(xct%ifmax, (xct%nkpt_fi,xct%nspin))
  xct%ifmax(:,:) = kp%ifmax(kg%indr(:),:)

!-----------------------------------------------------------------------
!     Order g-vectors with respect to their kinetic energy

  call logit('input:  reordering gvecs')
  SAFE_ALLOCATE(index, (gvec%ng))
  SAFE_ALLOCATE(gvec%ekin, (gvec%ng))
  call kinetic_energies(gvec, crys%bdot, gvec%ekin)
  call sortrx(gvec%ng, gvec%ekin, index, gvec = gvec%components)

  SAFE_ALLOCATE(ek_tmp, (gvec%ng))
  ek_tmp = gvec%ekin
  SAFE_ALLOCATE(k_tmp, (3,gvec%ng))
  k_tmp = gvec%components
  do ii=1,gvec%ng
    gvec%ekin(ii) = ek_tmp(index(ii))
    gvec%components(:,ii) = k_tmp(:,index(ii))
  enddo
  SAFE_DEALLOCATE(ek_tmp)
  SAFE_DEALLOCATE(k_tmp)
  SAFE_DEALLOCATE(index)

  call gvec_index(gvec)
  
!-----------------------------------------------------------------------
!     Read the wavefunctions and create INT_CWFN_*
!
  if (flag%read_dtmat .and. flag%vm /= 0) then
    if (peinf%inode.eq.0) write(6,*) ' Bypassing INT_CWFN_*'
    call write_transitions()
    POP_SUB(input)
    return
  endif
    
  call logit('input:  reading WFN_fi')
  wfnc%nband=xct%ncb_fi
  wfnc%nspin=kp%nspin
  wfnc%nspinor=kp%nspinor

  if (xct%iwriteint .eq. 0) then
    if(peinf%inode.lt.10000) then
      write(filenamec,'(a,i4.4)') 'INT_CWFN_', peinf%inode
    else
      call die("input: cannot use more than 10000 nodes")
    endif
    iunit_c=128+(2*peinf%inode)+1
    call open_file(iunit_c,file=filenamec,form='unformatted',status='replace')
  else
    SAFE_ALLOCATE(intwfnc%ng, (peinf%ikt(peinf%inode+1)))
    SAFE_ALLOCATE(intwfnc%isort, (gvec%ng,peinf%ikt(peinf%inode+1)))
    SAFE_ALLOCATE(intwfnc%cgk, (kp%ngkmax,wfnc%nband,kp%nspin*kp%nspinor,peinf%ikt(peinf%inode+1)))
  endif

  SAFE_ALLOCATE(wfnc%isort, (gvec%ng))
  SAFE_ALLOCATE(isend, (peinf%npes))
  wfnc%isort=0
  last_ikt=-1
  last_ng=-1
  last_ng_match=-1
  call progress_init(prog_info, 'reading wavefunctions (WFN_fi)', 'k-point', kp%nrk)
  do irk=1,kp%nrk
    call progress_step(prog_info, irk)
    irks = 0
    do ii=1,kg%nr
      if (irk.eq.indxk(ii)) then
        irks=ii
        exit
      endif
    enddo

    wfnc%ng = kp%ngk(irk)

! FHJ: Realloc arrays. Note that we can`t do something like
!      "if (wfnc%ng>last_ng)"  b/c fortran complains at read_binary_gvectors 
!      if the vectors are not exactly wfnc%ng big.
    if(wfnc%ng/=last_ng) then
      if(last_ng/=-1) then
        SAFE_DEALLOCATE_P(gvec_kpt%components)
        SAFE_DEALLOCATE(cg)
      endif
      SAFE_ALLOCATE(gvec_kpt%components, (3, wfnc%ng))
      SAFE_ALLOCATE(cg, (wfnc%ng, kp%nspin*kp%nspinor))
      last_ng = wfnc%ng
    endif

    call read_binary_gvectors(25, wfnc%ng, wfnc%ng, gvec_kpt%components)

    if(irks > 0) then
      do ii = 1, kp%ngk(irk)
        call findvector(wfnc%isort(ii), gvec_kpt%components(:, ii), gvec)
        if(wfnc%isort(ii) == 0) call die('input: could not find gvec')
      enddo

! FHJ: Realloc arrays.
      if(wfnc%ng/=last_ng_match) then
        if(last_ng_match/=-1) then
          SAFE_DEALLOCATE_P(wfnc%cg)
          SAFE_DEALLOCATE(cgarray)
        endif
        SAFE_ALLOCATE(wfnc%cg, (wfnc%ng, wfnc%nband, wfnc%nspin*wfnc%nspinor))
        SAFE_ALLOCATE(cgarray, (wfnc%ng))
        last_ng_match = wfnc%ng
      endif
      if(peinf%ikt(peinf%inode+1)/=last_ikt) then
        if(last_ikt/=-1) then
          SAFE_DEALLOCATE(iwriteik)
        endif
        SAFE_ALLOCATE(iwriteik,(peinf%ikt(peinf%inode+1)))
        last_ikt = peinf%ikt(peinf%inode+1)
      endif

!       Determine which PEs will write the wavefunctions for this k-point
      iwrite=0
      iwritetotal=0
      iwriteik=0
      do ii=1, peinf%ikt(peinf%inode+1)
        if(kg%indr(peinf%ik(peinf%inode+1,ii)).eq.irks) then
          iwritetotal=iwritetotal+1
          iwriteik(iwritetotal)=ii
          iwrite=1
        endif
      enddo

!       Determine to which PEs the wavefunctions for this k-point
!       need to be sent...
      isend=0
      if(peinf%inode.eq.0) then
        do jj=2,peinf%npes
          do ii=1, peinf%ikt(jj)
            if(kg%indr(peinf%ik(jj,ii)).eq.irks) then
              isend(jj)=1
              exit
            endif
          enddo
        enddo
      endif
    endif
!
!       Loop over the bands
!
    do ii=1,kp%mnband

      call read_binary_data(25, kp%ngk(irk), kp%ngk(irk), kp%nspin*kp%nspinor, cg, bcast=.false.)

      if(irks == 0) cycle

      do is=1, kp%nspin
!         If ii is one of the selected conduction bands...
        if((ii.gt.kp%ifmax(irks,is).and. &
          ii.le.kp%ifmax(irks,is)+xct%ncb_fi)) then

          do isp=1, kp%nspinor
            if (peinf%inode.eq.0) then
              cgarray(1:kp%ngk(irk))=cg(1:kp%ngk(irk), is*isp)
#ifdef VERBOSE
              write(6,'(a, 3i7, 2(f18.13))') 'input', irks, ii, is*isp, cgarray(1)
#endif
            end if
#ifdef MPI
            if(peinf%inode.eq.0) then
              do jj=2,peinf%npes
                if(isend(jj).eq.1) then
                  dest=jj-1
                  tag=1000+dest*2-(is-1)
                  call MPI_SEND(cgarray,kp%ngk(irk),MPI_SCALAR, &
                    dest,tag,MPI_COMM_WORLD,mpierr)
                endif
              enddo
            else
              if(iwrite.eq.1) then
                tag=1000+peinf%inode*2-(is-1)
                call MPI_RECV(cgarray,kp%ngk(irk),MPI_SCALAR,0,tag, &
                  MPI_COMM_WORLD,mpistatus,mpierr)
              endif
            endif
#endif
            if(iwrite.eq.1) then
              wfnc%cg(1:wfnc%ng,ii-kp%ifmax(irks,is),is*isp) = cgarray
            endif
          enddo
          if(iwrite.eq.1) then
            !FHJ: We only Send/Recv and check one spin at a time
            call checknorm('WFN_fi',ii,irks,kp%ngk(irk),is,kp%nspinor,&
                         wfnc%cg(:,ii-kp%ifmax(irks,is),:))
          endif
        endif
      enddo
      
    enddo
    if(irks == 0) cycle
    
    if(iwrite.eq.1) then
      
      if (xct%iwriteint .eq. 0) then 
        write(iunit_c) irks,wfnc%ng,wfnc%nband,wfnc%nspin,wfnc%nspinor
        write(iunit_c) (wfnc%isort(ii),ii=1,gvec%ng), &
          (((wfnc%cg(ii,jj,kk),ii=1,wfnc%ng),jj=1,wfnc%nband),kk=1,wfnc%nspin*wfnc%nspinor)
      else
        do ijk = 1, iwritetotal
          intwfnc%ng(iwriteik(ijk))=wfnc%ng
          intwfnc%isort(:,iwriteik(ijk))=wfnc%isort(:)
          intwfnc%cgk(1:wfnc%ng,:,:,iwriteik(ijk))=wfnc%cg(1:wfnc%ng,:,:)
        enddo
      endif
    endif
  enddo !end loop over k-points
  call progress_free(prog_info)

  SAFE_DEALLOCATE(isend)
  SAFE_DEALLOCATE_P(wfnc%isort)

  if(last_ikt/=-1) then
    SAFE_DEALLOCATE(iwriteik)
  endif
  if(last_ng_match/=-1) then
    SAFE_DEALLOCATE_P(wfnc%cg)
    SAFE_DEALLOCATE(cgarray)
  endif
  if(last_ng/=-1) then
    SAFE_DEALLOCATE_P(gvec_kpt%components)
    SAFE_DEALLOCATE(cg)
  endif
  
  SAFE_DEALLOCATE(indxk)

  if (xct%iwriteint .eq. 0) call close_file(iunit_c)

  call write_transitions()

#ifdef MPI
  if(xct%iwriteint == 0) call MPI_Barrier(MPI_COMM_WORLD, mpierr)
#endif

  POP_SUB(input)  
  return

contains

  subroutine write_transitions()

    PUSH_SUB(input.write_transitions)
    
    if(peinf%inode.eq.0) then
      write(6,'(/,1x,a)') 'Conduction wavefunctions read from file WFN_fi'
      write(6,'(1x,a,i8)') ' - Number k-points in irreducible BZ: ', kg%nr
      write(6,'(1x,a,i8)') ' - Number k-points in full BZ: ', kg%nf
      write(6,'(1x,a,f12.6,a)') ' - Effective k-point radius: ', kg%sz,' Bohr^-1'
#ifdef VERBOSE
      write(6,'(/,1x,a)') 'Listing all k-points:'
      write(6,'(3x,3f15.9)') ((kg%r(ii,jj),ii=1,3),jj=1,kg%nr)
      write(6,'(1x,a,/)') 'Done listing k-points'
#endif
      call close_file(25)
    endif ! node 0

    ! hang on to k-points to check in input_co that grids are the same
    if(.not. xct%skipinterp) then
      SAFE_DEALLOCATE_P(kp%rk)
    endif
    SAFE_DEALLOCATE_P(kp%ifmin)
    SAFE_DEALLOCATE_P(kp%ifmax)
    SAFE_DEALLOCATE_P(kp%el)

!-----------------------------------------------------------------------
!     Print out information about the nn lowest energy transitions for
!     spin up states. The array eltr has the lowest nmat energy
!     transitions, with corresponding bands/k-points in kltr, kcvltr.
!     This can also be used to locate the location in BZ
!     of all transitions within a predefined energy range.
!
    if(peinf%inode.eq.0) then
      nmat=100
      SAFE_ALLOCATE(eltr, (nmat))
      SAFE_ALLOCATE(kltr, (3,nmat))
      SAFE_ALLOCATE(kcvltr, (3,nmat))
      kltr=0.d0
      kcvltr=0
      eltr(:)=1.d8
      eltr(1)=eqp%ecqp(1,1,1) - eqp%evqp(1,1,1)
      kltr(:,1)=kg%f(:,1)
      kcvltr(:,1)=1
      
      do ik=1,xct%nkpt_fi
        do iv=1,xct%nvb_fi
          ic_loop: do ic=1,xct%ncb_fi
            if (ik.eq.1 .and. ic.eq.1 .and. iv.eq.1) cycle ic_loop
            test=eqp%ecqp(ic,ik,1) - eqp%evqp(iv,ik,1)
            do jj=1,nmat
              if (test.lt.eltr(jj)) then
                do kk=nmat-1,jj,-1
                  eltr(kk+1) = eltr(kk)
                  kltr(:,kk+1)=kltr(:,kk)
                  kcvltr(:,kk+1)=kcvltr(:,kk)
                enddo
                eltr(jj)=test
                kltr(:,jj)=kg%f(:,ik)
                kcvltr(1,jj)=ik
                kcvltr(2,jj)=ic
                kcvltr(3,jj)=iv
                cycle ic_loop
              endif
            enddo
          enddo ic_loop
        enddo
      enddo
        
      eltr(:)=eltr(:)*ryd
      write(6,*)
      write(6,*) ' Lowest energy transitions : [eV]'
      nn=5
      do jj=1,nn
        if (kcvltr(1,jj)>0) then
          write(6,210) (kltr(ii,jj),ii=1,3), &
            (kcvltr(ii,jj),ii=1,3),eltr(jj)
        endif
      enddo
210   format(2x,' ( ',f6.3,' , ',f6.3,' , ',f8.3,' ) ',3i4,f11.6)
      SAFE_DEALLOCATE(eltr)
      SAFE_DEALLOCATE(kltr)
      SAFE_DEALLOCATE(kcvltr)
    endif

    POP_SUB(input.write_transitions)
    return
      
  end subroutine write_transitions

end subroutine input
