module kubo_greenwood
  use datatypes

  implicit none

  real(double), parameter :: kb = 8.617333262145d-5 / 27.21138602d0
  complex(double_cplx), target, allocatable, save :: ngradm_summed(:,:), sigma(:,:)
  integer :: mat_dS2(3)

  contains

    subroutine dealloc_matdS2()
      use mult_module, only: free_temp_matrix
      implicit none

      integer :: i

      do i = 3, 1, -1
        call free_temp_matrix(mat_dS2(i))
      end do

    end subroutine dealloc_matdS2

    subroutine get_conductivity(w, expH, Ef, wtk, kp, kps, spin)

      use numbers
      use datatypes
      use GenComms, only: cq_abort, inode, ionode, myid,io_lun, gsum
      use PAO_grid_transform_module, only: single_PAO_to_grid, single_PAO_to_grad
      use matrix_data, only: Hrange
      use global_module, only: sf, atomf
      use mult_module, only: SF_to_AtomF_transform, matrix_scale,allocate_temp_matrix, &
       free_temp_matrix, matrix_product_trace, matS
      use calc_matrix_elements_module, only: act_on_vectors_new
      use functions_on_grid, only: atomfns, allocate_temp_fn_on_grid, free_temp_fn_on_grid, &
        gridfunctions, fn_on_grid
      use set_bucket_module, only: rem_bucket, atomf_H_atomf_rem
      use ScalapackFormat, only: matrix_size
      use calc_matrix_elements_module, only: get_matrix_elements_new
      use set_bucket_module,           only: rem_bucket, atomf_H_atomf_rem ,atomf_atomf_rem
      use negf_output_module
      use MPI

      implicit none

      complex(double_cplx), intent(in) :: expH(:,:,:)
      real(double), intent(in) :: wtk,w(:,:,:), kps(3), Ef(2)
      integer, intent(in) :: spin, kp

      character(1),parameter :: xyz(3)=["x","y","z"]
      character(256) :: file_ds2
      integer :: phi_n_fn(2), grad_phi_m_fn(2), atom_grad_fn, ierr
      integer :: i1, i2, ii, nn, n_min, n_max, id1 ,id2, maxijk(3),jj
      integer :: matMOcoeff(2)
      complex(double_cplx) :: ngradm_tmp1(3,3), ngradm_tmp2(3,3), ngradm_tmp(3,3)
      real(double) :: ngradm_re, ngradm_im, tmp_re, tmp_im, weight_nm, fac

      if (.not.allocated(sigma)) then

        atom_grad_fn = allocate_temp_fn_on_grid(atomf) ! gradient of paos
        do id1 = 1, 3
          mat_dS2(id1) = allocate_temp_matrix(Hrange,0,sf,sf) ! right-side overlap derivatives
          call matrix_scale(0d0, mat_dS2(id1))
          gridfunctions(atom_grad_fn)%griddata = 0d0
          call single_PAO_to_grad(id1, atom_grad_fn)
          call get_matrix_elements_new(inode-1, rem_bucket(atomf_atomf_rem), &
            mat_dS2(id1), atomfns,atom_grad_fn)

        end do
        call free_temp_fn_on_grid(atom_grad_fn)

!~         allocate(ngradm_summed(matrix_size,matrix_size), sigma(3,3))
        allocate(sigma(3,3))
        ngradm_summed=0d0
        sigma=0d0
        do id1 = 1, 3
          file_ds2="dS2_"//xyz(id1)
          call write_mat(mat_dS2(id1),Hrange,maxijk,file_ds2)
        end do
      end if

      matMOcoeff(1) = allocate_temp_matrix(Hrange,0,sf,sf) ! real part
      matMOcoeff(2) = allocate_temp_matrix(Hrange,0,sf,sf) ! imaginary part

      write(io_lun, fmt='(A,i8,3e24.12)') "Calculate Kubo-Greenwood conductivity for k-point ",kp,kps
!~       call get_n_min_max(w(:, kp, spin), Ef(spin), 300d0, 1d-12, n_min, n_max)
!~       nn = (n_max - n_min + 1 + 1) * (n_max - n_min + 1) * 0.5

      nn = (matrix_size + 1) * matrix_size * 0.5

      ii = 0
      ngradm_tmp = 0d0
      do i1 = 1, -1 !matrix_size ! n_min, n_max
        do i2 = 1, i1
          ii = ii+1
          if (mod(ii, nint(nn * 0.01d0)).eq.0) write(io_lun,fmt='(2i8)', advance="no") nint(ii / (nn * 0.01d0) )
          weight_nm = get_weight_nm(w(i1, kp, spin), w(i2, kp, spin), Ef(spin), 300d0, 1d-3)

          call matrix_scale(0d0, matMOcoeff(1))
          call matrix_scale(0d0, matMOcoeff(2))

          call build_nm(Hrange, kps, expH(:,:,spin), i1, i2, matMOcoeff)

          do id1 = 1, 3
            do id2 = id1, id1
              tmp_re = matrix_product_trace(mat_dS2(id1), matMOcoeff(1))
              tmp_im = matrix_product_trace(mat_dS2(id1), matMOcoeff(2))
              ngradm_tmp1(id1,id2) = cmplx(tmp_re, tmp_im)
            end do
          end do

          call matrix_scale(0d0, matMOcoeff(1))
          call matrix_scale(0d0, matMOcoeff(2))

          call build_nm(Hrange, kps, expH(:,:,spin), i2, i1, matMOcoeff)

          do id1 = 1, 3
            do id2 = id1, id1
              tmp_re = matrix_product_trace(mat_dS2(id1), matMOcoeff(1))
              tmp_im = matrix_product_trace(mat_dS2(id1), matMOcoeff(2))
              ngradm_tmp2(id1,id2) = cmplx(tmp_re, tmp_im)
            end do
          end do

          if (i1.eq.i2) then
            fac=1d0
          else
            fac=2d0
          end if

          ngradm_tmp = ngradm_tmp + ngradm_tmp1 * ngradm_tmp2 * weight_nm * fac

!~               ngradm_summed(i1, i2) = ngradm_summed(i1,i2) + ngradm_tmp
!~               ngradm_summed(i2, i1) = ngradm_summed(i1,i2)

        end do
      end do

      sigma = sigma + ngradm_tmp * wtk

      write(io_lun,*)

      do id1 = 1, 3
        do id2 = id1, id1
          write(io_lun,fmt='(1A,X,1A,X,2e24.12)' ) xyz(id1),xyz(id2), ngradm_tmp(id1,id2)
        end do
      end do
      write(io_lun, fmt='(A)') " finished"

      call MPI_BARRIER(MPI_COMM_WORLD,ierr)
      call free_temp_matrix(matMOcoeff(2))
      call free_temp_matrix(matMOcoeff(1))

    end subroutine get_conductivity

    subroutine get_conductivity_direct(w, expH, wtk, kp, kps, spin)

      use numbers
      use datatypes
      use GenComms, only: cq_abort, inode, ionode, myid,io_lun, gsum
      use PAO_grid_transform_module, only: single_PAO_to_grid, single_PAO_to_grad
      use matrix_data, only: Hrange
      use global_module, only: sf, atomf
      use mult_module, only: SF_to_AtomF_transform, matrix_scale,allocate_temp_matrix, &
       free_temp_matrix,matH
      use calc_matrix_elements_module, only: act_on_vectors_new
      use functions_on_grid, only: atomfns, allocate_temp_fn_on_grid, free_temp_fn_on_grid, &
        gridfunctions, fn_on_grid
      use set_bucket_module, only: rem_bucket, atomf_H_atomf_rem
      use ScalapackFormat, only: matrix_size
      use calc_matrix_elements_module, only: get_matrix_elements_new
      use set_bucket_module,           only: rem_bucket, atomf_H_atomf_rem ,atomf_atomf_rem

      implicit none

      complex(double_cplx), intent(in) :: expH(:,:,:)
      real(double), intent(in) :: wtk,w(:,:,:), kps(3)
      integer, intent(in) :: spin, kp

      integer :: matMOcoeff(2), phi_n_fn(2), grad_phi_m_fn(2), atom_grad_fn,i1,i2,mat_S,ijk(3)
      complex(double_cplx) :: ngradm_tmp1,ngradm_tmp2,ngradm_tmp

      if (.not.allocated(ngradm_summed)) then
        allocate(ngradm_summed(matrix_size,matrix_size))
        ngradm_summed=0d0
      end if

      matMOcoeff(1) = allocate_temp_matrix(Hrange,0,sf,sf) ! real part
      matMOcoeff(2) = allocate_temp_matrix(Hrange,0,sf,sf) ! imaginary part

      grad_phi_m_fn(1) = allocate_temp_fn_on_grid(atomf)
      grad_phi_m_fn(2) = allocate_temp_fn_on_grid(atomf)

      atom_grad_fn = allocate_temp_fn_on_grid(atomf)
      gridfunctions(atom_grad_fn)%griddata = 0d0
      call single_PAO_to_grad(3, atom_grad_fn)

      do i1=1, matrix_size
        do i2=1, matrix_size
        write(io_lun,fmt='(i8)', advance="no" ) matrix_size*matrix_size-((i2-1)*matrix_size+i1)

        gridfunctions(grad_phi_m_fn(1))%griddata = 0d0
        gridfunctions(grad_phi_m_fn(2))%griddata = 0d0
        call matrix_scale(0d0,matMOcoeff(1))
        call matrix_scale(0d0,matMOcoeff(2))

        call build_nm(Hrange, kps, expH(:,:,spin),i1,i2,matMOcoeff)

        call act_on_vectors_new(inode-1, rem_bucket(atomf_H_atomf_rem), &
          matMOcoeff(1), grad_phi_m_fn(1), atom_grad_fn)
        call act_on_vectors_new(inode-1, rem_bucket(atomf_H_atomf_rem), &
          matMOcoeff(2), grad_phi_m_fn(2), atom_grad_fn)

        call get_n_grad_m(ngradm_tmp1, grad_phi_m_fn, atomfns)

        gridfunctions(grad_phi_m_fn(1))%griddata = 0d0
        gridfunctions(grad_phi_m_fn(2))%griddata = 0d0
        call matrix_scale(0d0,matMOcoeff(1))
        call matrix_scale(0d0,matMOcoeff(2))

         call build_nm(Hrange, kps, expH(:,:,spin),i2,i1,matMOcoeff)

        call act_on_vectors_new(inode-1, rem_bucket(atomf_H_atomf_rem), &
            matMOcoeff(1), grad_phi_m_fn(1), atom_grad_fn)
        call act_on_vectors_new(inode-1, rem_bucket(atomf_H_atomf_rem), &
            matMOcoeff(2), grad_phi_m_fn(2), atom_grad_fn)

        call get_n_grad_m(ngradm_tmp2, grad_phi_m_fn, atomfns)

        ngradm_tmp = ngradm_tmp1*ngradm_tmp2
        ngradm_summed(i1,i2) = ngradm_summed(i1,i2) + ngradm_tmp * wtk
      end do
    end do
    write(io_lun,*) " finished"

!~       write(io_lun,fmt='(7e16.8,i6)') ngradm_tmp,ngradm_tmp1,ngradm_tmp2, wtk, kp
!~       write(io_lun,*) ngradm

      call free_temp_fn_on_grid(grad_phi_m_fn(2))
      call free_temp_fn_on_grid(grad_phi_m_fn(1))

      call free_temp_matrix(matMOcoeff(2))
      call free_temp_matrix(matMOcoeff(1))

    end subroutine get_conductivity_direct

    subroutine get_mo_matrix(mat_range, localEig,iband,mat_coeff,kps,fac)

      !use maxima_module, only: mx_nponn, mx_at_prim
      use numbers
      use matrix_module,   only: matrix, matrix_halo
      use group_module,    only: parts
      use primary_module,  only: bundle
      use cover_module,    only: BCS_parts
      use ScalapackFormat, only: CC_to_SC,maxrow,maxcol,proc_block,    &
           SC_to_refx,SC_to_refy, block_size_r,  &
           block_size_c, blocks_c, proc_start,   &
           matrix_size
      use global_module,   only: numprocs, iprint_DM, id_glob,         &
           ni_in_cell, x_atom_cell, y_atom_cell, &
           z_atom_cell, max_wf, out_wf,io_lun
      use mpi
      use GenBlas,         only: dot
      use GenComms,        only: myid,inode,cq_abort
      use mult_module,     only: store_matrix_value_pos, matrix_pos,matrix_index
      use matrix_data,     only: mat, halo
      use species_module,  only: nsf_species

      implicit none

  type Krecv_data
     integer                               :: orbs
     integer,      dimension(:),   pointer :: ints
     !integer,     dimension(:),   pointer :: ndimi
     integer,      dimension(:),   pointer :: ndimj
     integer,      dimension(:,:), pointer :: prim_atom
     integer,      dimension(:,:), pointer :: locj
     real(double), dimension(:,:), pointer :: dx, dy, dz
  end type Krecv_data

      ! Passed variables

      integer :: mat_range, mat_coeff(2)
      real(double_cplx) :: fac,kps(3)
      complex(double_cplx), dimension(:,:), intent(in) :: localEig

      integer :: part, memb, neigh, ist, prim_atom, owning_proc, locatom
      integer :: Col_FSC_part, Col_FSC_seq,  FSC_atom
      integer :: i, j, k, proc

      integer :: maxloc, maxint, maxsend, curr, gcspart, CC, orb_count

      integer :: ierr, atom, inter, prim,  col_sup, send_proc, recv_proc
      integer, dimension(:,:), allocatable :: atom_list

      integer, dimension(:), allocatable :: current_loc_atoms, &
           LocalAtom, prim_orbs
      integer, dimension(MPI_STATUS_SIZE) :: mpi_stat

      complex(double_cplx) :: zsum, zphase
      real(double) :: dx, dy, dz, phase

      logical :: flag, flag_write_out
      integer :: FSCpart, ipart, iband, iwf, len_occ,sf1,ah,wheremat2
      type(Krecv_data), dimension(:), allocatable :: recv_info
      complex(double_cplx), dimension(:,:), allocatable :: RecvBuffer, &
         SendBuffer
      integer, dimension(:,:), allocatable :: ints, &
         send_prim, send_info, send_orbs, send_off

    send_proc = myid
    recv_proc = myid
    maxloc = 0
    maxint = 0
    maxsend = 0
    do i=1,numprocs
       if(current_loc_atoms(i)>maxloc) maxloc = current_loc_atoms(i)
    end do
   ! Allocate recv_info
    allocate( &
         prim_orbs(bundle%mx_iprim),STAT=ierr)
    if(ierr/=0) call cq_abort('buildK: Error allocating send_info !',ierr)
    send_info = 0
    send_orbs = 0
    send_off = 0
    prim_orbs = 0
    orb_count = 0
    do j=1,bundle%n_prim
       prim_orbs(j) = orb_count
       orb_count = orb_count + nsf_species(bundle%species(j))
    end do
    allocate(recv_info(numprocs),STAT=ierr)
    if(ierr/=0) call cq_abort('buildK: Error allocating recv_info !',ierr)
    do i=1,numprocs
       ! Build the list of which primary set atoms we send to which processor
       curr = 0
       orb_count = 0
       do j=1,bundle%n_prim
          orb_count = orb_count + nsf_species(bundle%species(j))
       end do
       allocate(recv_info(i)%ints(maxloc),recv_info(i)%ndimj(maxloc), &
            recv_info(i)%prim_atom(maxint,maxloc), recv_info(i)%locj(maxint,maxloc), &
            recv_info(i)%dx(maxint,maxloc),recv_info(i)%dy(maxint,maxloc), recv_info(i)%dz(maxint,maxloc),STAT=ierr)
       recv_info(i)%orbs = 0
       recv_info(i)%ints = 0
       !recv_info(i)%ndimi = 0
       recv_info(i)%ndimj = 0
       recv_info(i)%prim_atom = 0
       recv_info(i)%locj = 0
       recv_info(i)%dx = 0.0_double
       recv_info(i)%dy = 0.0_double
       recv_info(i)%dz = 0.0_double
       if(ierr/=0) call cq_abort('buildK: Error allocating recv_info !',ierr)
    end do

    do part = 1,bundle%groups_on_node ! Loop over primary set partitions

       if(bundle%nm_nodgroup(part)>0) then ! If there are atoms in partition
          CC = parts%ngnode(parts%inode_beg(myid+1)+part-1)
          do memb = 1,bundle%nm_nodgroup(part) ! Loop over atoms

             prim_atom = bundle%nm_nodbeg(part)+memb-1
             do neigh = 1, mat(part,mat_range)%n_nab(memb) ! Loop over neighbours of atom

                ist = mat(part,mat_range)%i_acc(memb)+neigh-1
                ! Establish FSC number of neighbour
                Col_FSC_part = BCS_parts%lab_cell(mat(part,mat_range)%i_part(ist))
                Col_FSC_seq  = mat(part,mat_range)%i_seq(ist)
                ! Now use i_cc2node(Col_FSC_part) to establish which processor owns this atom
                owning_proc = parts%i_cc2node(Col_FSC_part)
                ! Find Fundamental Simulation Cell atom
                FSC_atom = id_glob(parts%icell_beg(Col_FSC_part)+Col_FSC_seq-1)
                ! Work out a map from primary atom + FSC + identifier to distance and position in data_Matrix
                locatom = LocalAtom(FSC_atom) ! Which atom in the list on the remote proc is this ?

                recv_info(owning_proc)%ints(locatom) = recv_info(owning_proc)%ints(locatom) + 1

                gcspart = BCS_parts%icover_ibeg(mat(part,mat_range)%i_part(ist))+mat(part,mat_range)%i_seq(ist)-1
                !recv_info(owning_proc)%ndimi(locatom) = mat(part,range)%ndimi(memb)
                recv_info(owning_proc)%ndimj(locatom) = mat(part,mat_range)%ndimj(ist)
                if(recv_info(owning_proc)%ints(locatom)==1) &
                     recv_info(owning_proc)%orbs = recv_info(owning_proc)%orbs + mat(part,mat_range)%ndimj(ist)
                recv_info(owning_proc)%prim_atom(recv_info(owning_proc)%ints(locatom),locatom) = prim_atom
                recv_info(owning_proc)%locj(recv_info(owning_proc)%ints(locatom),locatom) = halo(mat_range)%i_halo(gcspart)
                ! Build the distances between atoms - needed for phases
                FSCpart = BCS_parts%lab_cell(mat(part,mat_range)%i_part(ist))!gcspart)
                recv_info(owning_proc)%dx(recv_info(owning_proc)%ints(locatom),locatom) = &
                     BCS_parts%xcover(gcspart)-bundle%xprim(prim_atom)
                recv_info(owning_proc)%dy(recv_info(owning_proc)%ints(locatom),locatom) = &
                     BCS_parts%ycover(gcspart)-bundle%yprim(prim_atom)
                recv_info(owning_proc)%dz(recv_info(owning_proc)%ints(locatom),locatom) = &
                     BCS_parts%zcover(gcspart)-bundle%zprim(prim_atom)
             end do ! End do neigh=1,mat%n_nab
          end do ! End do memb =1,nm_nodgroup
       end if ! End if nm_nodgroup > 0
    end do ! End do part=1,groups_on_node

      do part = 1,bundle%groups_on_node ! Loop over primary set partitions
         if(bundle%nm_nodgroup(part)>0) then ! If there are atoms in partition
            CC = parts%ngnode(parts%inode_beg(myid+1)+part-1)
            do memb = 1,bundle%nm_nodgroup(part) ! Loop over atoms
               prim_atom = bundle%nm_nodbeg(part)+memb-1

                  neigh = 1 ! only need neighbor 1 which should be the atom itself

                  ist = mat(part,mat_range)%i_acc(memb)+neigh-1

                  Col_FSC_part = BCS_parts%lab_cell(mat(part,mat_range)%i_part(ist))
                  Col_FSC_seq  = mat(part,mat_range)%i_seq(ist)

                  locatom =  memb!LocalAtom(FSC_atom) ! Which atom in the list on the remote proc is this ?

                  gcspart = BCS_parts%icover_ibeg(mat(part,mat_range)%i_part(ist))+mat(part,mat_range)%i_seq(ist)-1
                phase = kps(1)*recv_info(recv_proc+1)%dx(inter,locatom) + kps(2)*recv_info(recv_proc+1)%dy(inter,locatom) + &
                     kps(3)*recv_info(recv_proc+1)%dz(inter,locatom)
                  dx=kps(1)*recv_info(recv_proc+1)%dx(inter,locatom)
                  dy=kps(1)*recv_info(recv_proc+1)%dy(inter,locatom)
                  dz=kps(1)*recv_info(recv_proc+1)%dz(inter,locatom)

                  phase = kps(1)*dx + kps(2)*dy + kps(3)*dz
                  if (fac.eq.0)  then
                    zphase=1d0
                  else
                    zphase=zexp(dcmplx(0d0,fac*phase))
                  end if
!~                   write(0,fmt='(9e24.12)') zphase,phase,dx,dy,dz,kps(1),kps(2),kps(3)
                  Ah = matrix_index(mat_coeff(1))
                  sf1 = mat(part,Ah)%ndimi(locatom)
                  do col_sup = 1, sf1
                    wheremat2 = (col_sup - 1) * sf1 + col_sup - 1 + mat(part,Ah)%onsite(locatom)
                    if (fac.eq.0) then
                      zsum = conjg(localEig(iband,prim_orbs(prim_atom)+col_sup))
                    else
                      zsum = (localEig(iband,prim_orbs(prim_atom)+col_sup))*zphase
                    end if
!~                     write(0,*) "zsum ",zsum
                    call store_matrix_value_pos(mat_coeff(1),whereMat2,real(zsum,double))  ! assume here real expansion coefficients, i.e. gamma point
                    call store_matrix_value_pos(mat_coeff(2),whereMat2,aimag(zsum))  ! assume here real expansion coefficients, i.e. gamma point
                  end do  ! End loop over NSF
            end do ! End do memb =1,nm_nodgroup
         end if ! End if nm_nodgroup > 0
      end do ! End do part=1,groups_on_node

      deallocate(prim_orbs,STAT=ierr)
      if(ierr.ne.0) call cq_abort('get_mo_matrix: Error allocating send_info !',ierr)

    end subroutine get_mo_matrix

  subroutine build_nm(range, kps, localEig,iband,jband,matBand)

    !use maxima_module, only: mx_nponn, mx_at_prim
    use numbers
    use matrix_module,   only: matrix, matrix_halo
    use group_module,    only: parts
    use primary_module,  only: bundle
    use cover_module,    only: BCS_parts
    use ScalapackFormat, only: CC_to_SC,maxrow,maxcol,proc_block,    &
         SC_to_refx,SC_to_refy, block_size_r,  &
         block_size_c, blocks_c, proc_start,   &
         matrix_size
    use global_module,   only: numprocs, iprint_DM, id_glob,         &
         ni_in_cell, x_atom_cell, y_atom_cell, &
         z_atom_cell, max_wf, out_wf
    use mpi
    use GenBlas,         only: dot
    use GenComms,        only: myid, io_lun, cq_abort
    use mult_module,     only: store_matrix_value_pos, matrix_pos
    use matrix_data,     only: mat, halo
    use species_module,  only: nsf_species

    implicit none

  type Krecv_data
     integer                               :: orbs
     integer,      dimension(:),   pointer :: ints
     !integer,     dimension(:),   pointer :: ndimi
     integer,      dimension(:),   pointer :: ndimj
     integer,      dimension(:,:), pointer :: prim_atom
     integer,      dimension(:,:), pointer :: locj
     real(double), dimension(:,:), pointer :: dx, dy, dz
  end type Krecv_data

    ! Passed variables
    integer :: range
    real(double) :: kps(3)
    complex(double_cplx), dimension(:,:), intent(in) :: localEig
    integer :: matBand(2), iband, jband
    ! Local variables
    type(Krecv_data), dimension(:), allocatable :: recv_info
    integer :: part, memb, neigh, ist, prim_atom, owning_proc, locatom
    integer :: Row_FSC_part, Row_FSC_seq, Col_FSC_part, Col_FSC_seq, &
         FSC_atom
    integer :: SCblockr, SCblockc, SCrowc, i, j, k, proc, stat, &
         supfn_r, supfn_c
    integer :: maxloc, maxint, maxsend, curr, gcspart, CC, orb_count
    integer :: len, send_size, recv_size, send_proc, recv_proc, nsf1, &
         sendtag, recvtag
    integer :: req1, req2, ierr, atom, inter, prim, wheremat, row_sup,&
         col_sup
    integer, dimension(:,:), allocatable :: ints, atom_list, &
         send_prim, send_info, send_orbs, send_off
    integer, dimension(:), allocatable :: current_loc_atoms, &
         LocalAtom, num_send, norb_send, send_FSC, recv_to_FSC, &
         mapchunk, prim_orbs
    integer, dimension(MPI_STATUS_SIZE) :: mpi_stat
    real(double) :: phase, rfac, ifac, rcc, icc, rsum,zphase
    complex(double_cplx) :: zsum
    complex(double_cplx), dimension(:,:), allocatable :: RecvBuffer, &
         SendBuffer
    logical :: flag, flag_write_out
    integer :: FSCpart, ipart, iwf, len_occ
    ! for spin polarisation
    real(double) :: occ_correction

    ! get occ_correction
    occ_correction = one

    ! Allocate data and zero arrays
    allocate(ints(numprocs,bundle%mx_iprim),&
         current_loc_atoms(numprocs),atom_list(numprocs,bundle%&
         mx_iprim), LocalAtom(ni_in_cell),send_prim(numprocs,bundle%&
         mx_iprim), num_send(numprocs),norb_send(numprocs),STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error allocating ints, &
         &current_loc_atoms and atom_list !',stat)
    ints = 0
    current_loc_atoms = 0
    atom_list = 0
    LocalAtom = 0
    send_prim = 0
    num_send = 0
    norb_send = 0

    ! Step one - work out which processors we need to exchange data with
    do part = 1,bundle%groups_on_node ! Loop over primary set partitions

       if(bundle%nm_nodgroup(part)>0) then ! If there are atoms in partition
          CC = parts%ngnode(parts%inode_beg(myid+1)+part-1)
          do memb = 1,bundle%nm_nodgroup(part) ! Loop over atoms

             prim_atom = bundle%nm_nodbeg(part)+memb-1
             do neigh = 1, mat(part,range)%n_nab(memb) ! Loop over neighbours of atom
                if(iprint_DM>=5.AND.myid==0) write(io_lun,3) myid,neigh
                ist = mat(part,range)%i_acc(memb)+neigh-1
                ! Establish FSC number of neighbour
                Col_FSC_part = BCS_parts%lab_cell(mat(part,range)%i_part(ist))
                Col_FSC_seq  = mat(part,range)%i_seq(ist)
                ! Now use i_cc2node(Col_FSC_part) to establish which processor owns this atom
                owning_proc = parts%i_cc2node(Col_FSC_part)
                ! Find Fundamental Simulation Cell atom
                FSC_atom = id_glob(parts%icell_beg(Col_FSC_part)+Col_FSC_seq-1)
                ! Find if we have seen this before
                flag = .false.
                if(iprint_DM>=5.AND.myid==0) write(io_lun,*) 'prim, neigh, FSC: ',prim_atom, neigh, FSC_atom
                if(iprint_DM>=5.AND.myid==0) write(io_lun,*) 'curr_loc_atoms: ',current_loc_atoms(owning_proc)
                if(current_loc_atoms(owning_proc)>0) then
                   do i=1,current_loc_atoms(owning_proc)
                      if(atom_list(owning_proc,i)==FSC_atom) then
                         if(iprint_DM>=5.AND.myid==0) write(io_lun,*) 'Loc atom: ',i, LocalAtom(FSC_atom)
                         ints(owning_proc,LocalAtom(FSC_atom)) = ints(owning_proc,LocalAtom(FSC_atom)) + 1
                         send_prim(owning_proc,prim_atom) = nsf_species(bundle%species(prim_atom))
                         flag = .true.
                         exit
                      end if
                   end do
                end if ! current_loc_atoms(owning_proc)>0
                if(flag) then
                   cycle
                end if
                ! Record
                current_loc_atoms(owning_proc) = current_loc_atoms(owning_proc) + 1
                atom_list(owning_proc,current_loc_atoms(owning_proc)) = FSC_atom
                LocalAtom(FSC_atom) = current_loc_atoms(owning_proc)
                ints(owning_proc,LocalAtom(FSC_atom)) = ints(owning_proc,LocalAtom(FSC_atom)) + 1
                send_prim(owning_proc,prim_atom) = nsf_species(bundle%species(prim_atom))
             end do ! End do neigh=1,mat%n_nab
          end do ! End do memb =1,nm_nodgroup
       end if ! End if nm_nodgroup > 0
    end do ! End do part=1,groups_on_node
    ! Find max value of current_loc_atoms and interactions

    if(iprint_DM>3.AND.myid==0) write(io_lun,*) 'buildK: Stage two'
    maxloc = 0
    maxint = 0
    maxsend = 0
    do i=1,numprocs
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) myid,' Curr loc atoms: ',i,current_loc_atoms(i)
       if(current_loc_atoms(i)>maxloc) maxloc = current_loc_atoms(i)
       do j=1,bundle%mx_iprim ! Needs to be mx_iprim because goes over primary atoms on REMOTE processors
          if(ints(i,j)>maxint) maxint = ints(i,j)
          if(send_prim(i,j)>0) num_send(i) = num_send(i) + 1
          norb_send(i) = norb_send(i) + send_prim(i,j)
          if(iprint_DM>=5.AND.myid==0) write(io_lun,4) myid,j,send_prim(i,j),num_send(i)
       end do
       if(num_send(i)>maxsend) maxsend = num_send(i)
    end do
    if(iprint_DM>=4.AND.myid==0) write(io_lun,*) myid,' Maxima: ',maxloc, maxint, maxsend
    ! Allocate recv_info
    allocate(send_info(numprocs,maxsend),send_orbs(numprocs,maxsend),send_off(numprocs,maxsend), &
         prim_orbs(bundle%mx_iprim),STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error allocating send_info !',stat)
    send_info = 0
    send_orbs = 0
    send_off = 0
    prim_orbs = 0
    orb_count = 0
    do j=1,bundle%n_prim
       prim_orbs(j) = orb_count
       orb_count = orb_count + nsf_species(bundle%species(j))
    end do
    allocate(recv_info(numprocs),STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error allocating recv_info !',stat)
    do i=1,numprocs
       ! Build the list of which primary set atoms we send to which processor
       curr = 0
       orb_count = 0
       do j=1,bundle%n_prim
          if(send_prim(i,j)>0) then
             curr = curr+1
             send_info(i,curr)=j
             send_off(i,curr)=orb_count
             send_orbs(i,curr)=nsf_species(bundle%species(j))
          end if
          orb_count = orb_count + nsf_species(bundle%species(j))
       end do
       allocate(recv_info(i)%ints(maxloc),recv_info(i)%ndimj(maxloc), &
            recv_info(i)%prim_atom(maxint,maxloc), recv_info(i)%locj(maxint,maxloc), &
            recv_info(i)%dx(maxint,maxloc),recv_info(i)%dy(maxint,maxloc), recv_info(i)%dz(maxint,maxloc),STAT=stat)
       recv_info(i)%orbs = 0
       recv_info(i)%ints = 0
       !recv_info(i)%ndimi = 0
       recv_info(i)%ndimj = 0
       recv_info(i)%prim_atom = 0
       recv_info(i)%locj = 0
       recv_info(i)%dx = 0.0_double
       recv_info(i)%dy = 0.0_double
       recv_info(i)%dz = 0.0_double
       if(stat/=0) call cq_abort('buildK: Error allocating recv_info !',stat)
    end do

    do part = 1,bundle%groups_on_node ! Loop over primary set partitions
       if(iprint_DM>=5.AND.myid==0) write(io_lun,1) myid,part
       if(bundle%nm_nodgroup(part)>0) then ! If there are atoms in partition
          CC = parts%ngnode(parts%inode_beg(myid+1)+part-1)
          do memb = 1,bundle%nm_nodgroup(part) ! Loop over atoms
             if(iprint_DM>=5.AND.myid==0) write(io_lun,2) myid,memb
             prim_atom = bundle%nm_nodbeg(part)+memb-1
             do neigh = 1, mat(part,range)%n_nab(memb) ! Loop over neighbours of atom
                if(iprint_DM>=5.AND.myid==0) write(io_lun,3) myid,neigh
                ist = mat(part,range)%i_acc(memb)+neigh-1
                ! Establish FSC number of neighbour
                Col_FSC_part = BCS_parts%lab_cell(mat(part,range)%i_part(ist))
                Col_FSC_seq  = mat(part,range)%i_seq(ist)
                ! Now use i_cc2node(Col_FSC_part) to establish which processor owns this atom
                owning_proc = parts%i_cc2node(Col_FSC_part)
                ! Find Fundamental Simulation Cell atom
                FSC_atom = id_glob(parts%icell_beg(Col_FSC_part)+Col_FSC_seq-1)
                ! Work out a map from primary atom + FSC + identifier to distance and position in data_Matrix
                locatom = LocalAtom(FSC_atom) ! Which atom in the list on the remote proc is this ?
                if(iprint_DM>=5.AND.myid==0) write(io_lun,*) myid,' own, FSC, loc: ',owning_proc, FSC_atom, locatom, &
                     recv_info(owning_proc)%ints(locatom)
                recv_info(owning_proc)%ints(locatom) = recv_info(owning_proc)%ints(locatom) + 1
                if(iprint_DM>=5.AND.myid==0) write(io_lun,*) myid,' ints: ',recv_info(owning_proc)%ints(locatom)
                gcspart = BCS_parts%icover_ibeg(mat(part,range)%i_part(ist))+mat(part,range)%i_seq(ist)-1
                !recv_info(owning_proc)%ndimi(locatom) = mat(part,range)%ndimi(memb)
                recv_info(owning_proc)%ndimj(locatom) = mat(part,range)%ndimj(ist)
                if(recv_info(owning_proc)%ints(locatom)==1) &
                     recv_info(owning_proc)%orbs = recv_info(owning_proc)%orbs + mat(part,range)%ndimj(ist)
                recv_info(owning_proc)%prim_atom(recv_info(owning_proc)%ints(locatom),locatom) = prim_atom
                recv_info(owning_proc)%locj(recv_info(owning_proc)%ints(locatom),locatom) = halo(range)%i_halo(gcspart)
                ! Build the distances between atoms - needed for phases
                FSCpart = BCS_parts%lab_cell(mat(part,range)%i_part(ist))!gcspart)
                recv_info(owning_proc)%dx(recv_info(owning_proc)%ints(locatom),locatom) = &
                     BCS_parts%xcover(gcspart)-bundle%xprim(prim_atom)
                recv_info(owning_proc)%dy(recv_info(owning_proc)%ints(locatom),locatom) = &
                     BCS_parts%ycover(gcspart)-bundle%yprim(prim_atom)
                recv_info(owning_proc)%dz(recv_info(owning_proc)%ints(locatom),locatom) = &
                     BCS_parts%zcover(gcspart)-bundle%zprim(prim_atom)
!~                  recv_info(owning_proc)%dx(recv_info(owning_proc)%ints(locatom),locatom) = BCS_parts%xcover(gcspart)- &
!~                       x_atom_cell(parts%icell_beg(FSCpart)+mat(part,range)%i_seq(ist)-1)
!~                  recv_info(owning_proc)%dy(recv_info(owning_proc)%ints(locatom),locatom) = BCS_parts%ycover(gcspart)- &
!~                       y_atom_cell(parts%icell_beg(FSCpart)+mat(part,range)%i_seq(ist)-1)
!~                  recv_info(owning_proc)%dz(recv_info(owning_proc)%ints(locatom),locatom) = BCS_parts%zcover(gcspart)- &
!~                       z_atom_cell(parts%icell_beg(FSCpart)+mat(part,range)%i_seq(ist)-1)

             end do ! End do neigh=1,mat%n_nab
          end do ! End do memb =1,nm_nodgroup
       end if ! End if nm_nodgroup > 0
    end do ! End do part=1,groups_on_node
    ! Work out length
    ! NB we send all bands up to last occupied one (for deltaSCF this will include some empty)
    len = 2 !matrix_size !max(iband,jband)

    ! Step three - loop over processors, send and recv data and build K
    allocate(send_fsc(bundle%mx_iprim),recv_to_FSC(bundle%mx_iprim),mapchunk(bundle%mx_iprim),STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error allocating send_fsc, recv_to_FSC and mapchunk',stat)
    send_fsc = 0
    recv_to_FSC = 0
    mapchunk = 0
    send_proc = myid
    recv_proc = myid
    ! Two messages per process; use tag and tag + 1 below
    sendtag = 1
    recvtag = 1
    do i=1,numprocs
       send_size = len*norb_send(send_proc+1)!num_send(send_proc+1)*nsf
       recv_size = len*recv_info(recv_proc+1)%orbs!current_loc_atoms(recv_proc+1)*nsf
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Send and recv sizes: ',send_size, recv_size
       ! Fill SendBuffer
       allocate(SendBuffer(len,norb_send(send_proc+1)),STAT=stat)
       if(stat/=0) call cq_abort('buildK: Unable to allocate SendBuffer !',stat)
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Filling SendBuffer'
       orb_count = 0
       do j=1,num_send(send_proc+1)
          do nsf1=1,send_orbs(send_proc+1,j)
             orb_count = orb_count+1
             SendBuffer(1,orb_count) = localEig(iband,send_off(send_proc+1,j)+nsf1)
             SendBuffer(2,orb_count) = localEig(jband,send_off(send_proc+1,j)+nsf1)
          end do
          ! We also need to send a list of what FSC each primary atom sent corresponds to - use bundle%ig_prim
          send_FSC(j) = bundle%ig_prim(send_info(send_proc+1,j))
          if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Building send_FSC: ',send_info(send_proc+1,j), &
               bundle%ig_prim(send_info(send_proc+1,j)),send_FSC(j)
       end do
       if(orb_count/=norb_send(send_proc+1)) call cq_abort("Orbital mismatch in buildK: ",orb_count,norb_send(send_proc+1))
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Sending'
       ! Now send
       if(send_size>0) then
          if(send_proc/=myid) then
             call MPI_issend(send_FSC,num_send(send_proc+1),MPI_INTEGER,send_proc,sendtag,MPI_COMM_WORLD,req1,ierr)
             call MPI_issend(SendBuffer,send_size,MPI_DOUBLE_COMPLEX,send_proc,sendtag+1,MPI_COMM_WORLD,req2,ierr)
          end if
       end if
       ! Now receive data
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Alloc RecvBuffer ',len,recv_info(recv_proc+1)%orbs
       !allocate(RecvBuffer(len,current_loc_atoms(recv_proc+1)*nsf),STAT=stat)
       allocate(RecvBuffer(len,recv_info(recv_proc+1)%orbs),STAT=stat)
       if(stat/=0) call cq_abort('buildK: Unable to allocate RecvBuffer !',stat)
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Recving'
       if(recv_size>0) then
          if(recv_proc/=myid) then
             call MPI_recv(recv_to_FSC,current_loc_atoms(recv_proc+1),MPI_INTEGER,recv_proc,recvtag,MPI_COMM_WORLD,mpi_stat,ierr)
             if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Got recv_to_FSC'
             call MPI_recv(RecvBuffer,recv_size,MPI_DOUBLE_COMPLEX,&
                  recv_proc,recvtag+1,MPI_COMM_WORLD,mpi_stat,ierr)
             if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Got RecvBuffer'
          else
             if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'On-proc: getting recv_to_FSC'
             recv_to_FSC(1:current_loc_atoms(recv_proc+1)) = send_FSC(1:current_loc_atoms(recv_proc+1))
             if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'On-proc: getting RecvBuffer'
             RecvBuffer(1:len,1:recv_info(recv_proc+1)%orbs) = SendBuffer(1:len,1:recv_info(recv_proc+1)%orbs)
          end if
          if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Doing the mapchunk', recv_to_FSC
          do j=1,current_loc_atoms(recv_proc+1)
             mapchunk(j) = LocalAtom(recv_to_FSC(j))
          end do
          if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'filling buffer'
          orb_count = 0
          do atom = 1,current_loc_atoms(recv_proc+1)
             locatom = mapchunk(atom)
             if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Atom, loc: ',atom,locatom,recv_info(recv_proc+1)%ints(locatom)
             ! Scale the eigenvector coefficients we've received
             ! The factor of 0.5 is because the occupation numbers are from 0->2 (we expect 0->1 in K)
             ! The occupation numbers contain the k-point weight
             ! When we're doing M12 not K then occ also contains the eigenvalue
             !do col_sup = 1,nsf
             !   do j=1,len
             !      RecvBuffer(j,(atom-1)*nsf+col_sup) = RecvBuffer(j,(atom-1)*nsf+col_sup)*0.5_double*occs(j)
             !   end do
             !end do
             ! N.B. the routine used for dot is zdotc which takes the complex conjugate of the first vector
             do inter = 1,recv_info(recv_proc+1)%ints(locatom)
                prim = recv_info(recv_proc+1)%prim_atom(inter,locatom)
                if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Inter: ',inter,prim
                phase = kps(1)*recv_info(recv_proc+1)%dx(inter,locatom) + kps(2)*recv_info(recv_proc+1)%dy(inter,locatom) + &
                     kps(3)*recv_info(recv_proc+1)%dz(inter,locatom)
                if(iprint_DM>=5.AND.myid==0) write(io_lun,*) 'Prim, where, phase: ',prim, whereMat, phase
                rfac = cos(phase)
                ifac = sin(phase)
                zphase=zexp(dcmplx(0d0,phase))
                do row_sup = 1,recv_info(recv_proc+1)%ndimj(locatom)
                   do col_sup = 1,nsf_species(bundle%species(prim))
                      whereMat = matrix_pos(matBand(1),recv_info(recv_proc+1)%prim_atom(inter,locatom), &
                           recv_info(recv_proc+1)%locj(inter,locatom),col_sup,row_sup)

                            zsum = conjg(localEig(jband,prim_orbs(prim)+col_sup))*RecvBuffer(1,orb_count+row_sup)*zexp(dcmplx(0d0,phase))
!~                             write(0,fmt='(3i5,9e16.8)') orb_count+row_sup,prim_orbs(prim)+col_sup,wheremat,conjg(localEig(jband,prim_orbs(prim)+col_sup)),RecvBuffer(iband,orb_count+row_sup),zexp(dcmplx(0d0,phase)),recv_info(recv_proc+1)%dz(inter,locatom)
                            call store_matrix_value_pos(matBand(1),whereMat,real(zsum))
                            call store_matrix_value_pos(matBand(2),whereMat,aimag(zsum))
                   end do ! col_sup=nsf
                end do ! row_sup=nsf
             end do ! inter=recv_info%ints
             ! Careful - we only want to increment after ALL interactions done
             orb_count = orb_count + recv_info(recv_proc+1)%ndimj(locatom)
          end do ! atom=current_loc_atoms
       end if ! recv_size>0
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Calling MPI_Wait'
       if(send_size>0.AND.myid/=send_proc) then
          call MPI_Wait(req1,mpi_stat,ierr)
          call MPI_Wait(req2,mpi_stat,ierr)
       end if
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Calling dealloc'
       deallocate(RecvBuffer,STAT=stat)
       if(stat/=0) call cq_abort("buildK: Failed to dealloc buffer",stat)
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Calling dealloc'
       deallocate(SendBuffer,STAT=stat)
       if(stat/=0) call cq_abort("buildK: Failed to dealloc buffer",stat)
       ! Increment/decrement recv and send, and wrap
       ! Remember that we go from 0->numprocs-1
       if(iprint_DM>=4.AND.myid==0) write(io_lun,*) 'Doing proc thang'
       send_proc = send_proc +1
       if(send_proc.GT.numprocs-1) send_proc = 0
       recv_proc = recv_proc -1
       if(recv_proc.LT.0) recv_proc = numprocs-1
    end do ! do i=numprocs
    ! Now deallocate all arrays
    deallocate(send_fsc,recv_to_FSC,mapchunk,STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error deallocating send_fsc, recv_to_FSC and mapchunk !',stat)
    do i=numprocs,1,-1
       deallocate(recv_info(i)%ints,recv_info(i)%prim_atom,recv_info(i)%locj,&
            recv_info(i)%dx,recv_info(i)%dy,recv_info(i)%dz,recv_info(i)%ndimj,STAT=stat)
       if(stat/=0) call cq_abort('buildK: Error deallocating recvinfo !',i,stat)
    end do
    deallocate(prim_orbs,send_off,send_orbs,send_info,STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error allocating send_info !',stat)
    deallocate(recv_info,STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error allocating recv_info !',stat)
    deallocate(ints,current_loc_atoms,atom_list,LocalAtom,send_prim,num_send,norb_send,STAT=stat)
    if(stat/=0) call cq_abort('buildK: Error allocating ints etc !',stat)

    return
1   format(10x,'Processor: ',i5,' Partition: ',i5)
2   format(10x,'Processor: ',i5,' Atom: ',i5)
3   format(10x,'Processor: ',i5,' Neighbour: ',i5)
4   format(10x,'Proc: ',i5,' Prim, send_prim, num_send: ',3i5)
  end subroutine build_nm

    subroutine get_n_grad_m(ngradm, atom_fns_n, atom_fns_grad_m)

      use datatypes
      use numbers
      use global_module, only: io_lun
      use dimens,                      only: n_my_grid_points, grid_point_volume
      use block_module,                only: n_pts_in_block
      use primary_module,              only: domain
      use set_blipgrid_module,         only: naba_atoms_of_blocks
      use GenComms,                    only: gsum, inode, ionode
      use global_module,               only: iprint_SC, atomf, ni_in_cell
      use functions_on_grid,           only: gridfunctions, fn_on_grid
      use maxima_module,   ONLY: maxngrid

      implicit none

      ! output

      complex(double_cplx) :: ngradm

      ! Passed variables

      integer, intent(in) :: atom_fns_n(2), atom_fns_grad_m

      ! Local variables
      integer :: blk, i_count_alpha, n, n_i, n_point

      real(double) :: a1,b1,a2,b2
      complex(double_cplx), allocatable :: tmp1(:),tmp2(:)
      complex(double_cplx) :: ii=cmplx(0d0,1d0)

      complex(double_cplx), external :: zdotc

      if (inode == ionode .and. iprint_SC >= 2) &
          write (io_lun,fmt='(2x,"Entering get_n_grad_m")')

      ngradm = 0d0
      allocate(tmp1(maxngrid),tmp2(maxngrid))
      tmp1=0d0
      tmp2=0d0
      i_count_alpha = 0

      do blk = 1, domain%groups_on_node
        n_point = (blk - 1) * n_pts_in_block
        i_count_alpha = (naba_atoms_of_blocks(atomf)%ibegin_blk_orb(blk)-1) * n_pts_in_block
        if (naba_atoms_of_blocks(atomf)%no_of_atom(blk) > 0) then   !TM 30/Jun/2003
            do n_i = 1, naba_atoms_of_blocks(atomf)%no_of_orb(blk)*n_pts_in_block, n_pts_in_block
              do n=1, n_pts_in_block

                  a1 = gridfunctions(atom_fns_n(1))%griddata(i_count_alpha+n_i+n-1)
                  b1 = gridfunctions(atom_fns_n(2))%griddata(i_count_alpha+n_i+n-1)
                  a2 = gridfunctions(atom_fns_grad_m)%griddata(i_count_alpha+n_i+n-1)
!~                   b2 = gridfunctions(atom_fns_grad_m(2))%griddata(i_count_alpha+n_i+n-1)
                  tmp1(n_point+n)=tmp1(n_point+n)+(a1+ii*b1)*a2
!~                   tmp2(n_point+n)=tmp2(n_point+n)+a2

              end do
            end do
        end if !(naba_atoms_of_blocks(atomf)%no_of_atom(blk) > 0)   !TM 30/Jun/2003
      end do ! blk

!~       ngradm = zdotc(n_my_grid_points,tmp1,1,tmp2,1)
!~       write(io_lun,*) n_my_grid_points
!~       write(0,fmt='(2e24.12)') conjg(tmp1(1:n_my_grid_points))*tmp2(1:n_my_grid_points)
!~       ngradm = sum(conjg(tmp1(1:n_my_grid_points))*tmp2(1:n_my_grid_points))
!~       ngradm = sum((tmp1(1:n_my_grid_points))*tmp2(1:n_my_grid_points))
      ngradm = sum((tmp1(1:n_my_grid_points)))
      call gsum(ngradm)
      ngradm = grid_point_volume * ngradm

    end subroutine get_n_grad_m

    function dfdE(x, Ef, T)
      implicit none

      real(double) :: dfdE
      real(double), intent(in) :: x, Ef, T

      real(double) :: beta

      beta = 1d0/(T * kb)
      dfdE = -beta / ( exp((x - Ef) * beta * 0.5d0) + exp(-(x - Ef) * beta * 0.5d0))**2

    end function dfdE

    subroutine get_n_min_max(w,Ef,T,eps,n_min,n_max)

      use global_module, only: io_lun

      implicit none

      real(double) :: w(:),Ef,T,eps
      integer :: n_min,n_max

      integer :: n,i

      n=size(w)

      do n_min=1,n
        if (abs(dfdE(w(n_min), Ef, T)).ge.eps) exit
      end do

      do n_max=n,1,-1
        if (abs(dfdE(w(n_max), Ef, T)).ge.eps) exit
      end do

      write(io_lun,fmt='(A,e16.8,A,2i8)') "For T =", T, " K consider states between ",n_min, n_max

    end subroutine get_n_min_max

!~ to get weight we need integral_-inf,inf dE df/dE*(eta/(E-E_n)^2+eta^2)*(eta/(E-E_m)^2+eta^2)
!~ df/dE -> delta(E-Ef) for T->0 but lets keep the finite temperature broading for now.
    function get_weight_nm(En, Em, Ef, T, eta)
      use GenComms, only: io_lun
      implicit none

      real(double) :: get_weight_nm
      real(double), intent(in) :: En, Em, Ef, T, eta

      real(double) :: f1, dx, eps, x, f, xmin , xmax
      integer :: ix, nmax, ii

      dx = min(abs(En-Ef),abs(Em-Ef))*1d-3
      xmin = min(Ef,min(En,Em))-max(kb*T,eta)*100
      xmax = max(Ef,min(En,Em))+max(kb*T,eta)*100
      nmax = nint((xmax-xmin)/dx) + 1

      f1 = 0d0
      do ix = 2, nmax-1
        x = xmin + dx * (ix -1)
        f = dfdE(x, Ef, T) * lorentz_function(x, En, eta)* lorentz_function(x, Em, eta)
        f1 = f1 + f
      end do

      f1 = f1 * 2d0
      x = xmin
      f1 = f1 + dfdE(x, Ef, T) * lorentz_function(x, En, eta)* lorentz_function(x, Em, eta)
      x = xmax
      f1 = f1 + dfdE(x, Ef, T) * lorentz_function(x, En, eta)* lorentz_function(x, Em, eta)

      get_weight_nm = f1 * dx

!~       write(io_lun, fmt='(2e24.12,i8)') get_weight_nm,( eta*eta / ( ( (Ef-En)**2 + eta**2 )  * ( (Ef-Em)**2 + eta**2 ) ) ),nmax

    end function get_weight_nm

    function lorentz_function(x,xn,eta)
      implicit none

        real(double) :: lorentz_function
        real(double), intent(in) :: x, xn, eta

        lorentz_function = eta /  ( (x-xn)**2 + eta**2 )

    end function lorentz_function

end module kubo_greenwood


      PROGRAM CNS
C
C  Crystallography & NMR System (CNS)
C
C  A program for X-ray crystallographic and solution NMR structure
C  determination.
C
C  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++=+
C  +===============================================================+
C  + Authors: A.T.Brunger, P.D.Adams, G.M.Clore, W.L.DeLano,       +
C  +          P.Gros, R.W.Grosse-Kunstleve, J.-S.Jiang,            +
C  +          J.Kuszewski, M.Nilges, N.S.Pannu, R.J.Read,          +
C  +          L.M.Rice, T.Simonson, G.L.Warren                     +
C  +===============================================================+
C  + Copyright 1997-2007 Yale University                           +
C  +===============================================================+
C  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C
C common (global) variables and constants
      INCLUDE 'cns.inc'
      INCLUDE 'comand.inc'
      INCLUDE 'cnst.inc'
      INCLUDE 'param.inc'
      INCLUDE 'mtf.inc'
      INCLUDE 'funct.inc'
      INCLUDE 'seed.inc'
      INCLUDE 'vector.inc'
      INCLUDE 'timer.inc'
      INCLUDE 'symbol.inc'
      INCLUDE 'update.inc'
      INCLUDE 'version.inc'
C =====
C local
C =====
      INTEGER ICYCLE, I, PROMPTLEN
      LOGICAL QOPEN, QFORM, QWRITE
      DOUBLE PRECISION DUMMY
      DOUBLE COMPLEX CDUMMY
      CHARACTER*12 USERNM
      CHARACTER*14 SYSNM
      CHARACTER*32 HOSTNM
      CHARACTER*11  DATE
      CHARACTER*8  TIME
      CHARACTER*20 PROMPT
C
C =====
C begin
C =====
C
C initialize the file handling facility
      CALL VOPEN(0,'$$INITIAL$$',' ',' ',ERROR)
C
C CHARACTER*4 array CSTACK initialization
      CALL CINIST(.FALSE.)
C
C HEAP initialization and sanity check
      CALL INITHP
      CALL HEAPVFY(ERROR)
      IF (ERROR) THEN
        CALL WRNDIE(-5, 'HEAPVFY', 'FATAL INTERNAL ERROR.')
        CALL DIE
      END IF
      CALL INITHP
C
C initialize command parsing
      CALL INIPRS
      CALL DECLAR( 'CNS_VERSION', 'ST', CNSVERSION, DUMMY, CDUMMY )
      CALL DECLAR( 'CNS_PATCH', 'ST', CNSPATCH, DUMMY, CDUMMY )
C
C initialize machine dependent variables
      CALL SETFPEPS
C
C initialize the interacting group setup
      CALL PIGRSET('INIT')
C
C initialize the nonbonded list
      CALL NBDSET('INIT')
C
C initialize the fast nonbonded setup
      CALL FNBSET('INIT')
C
C initialize the trajectory writing facility
      CALL TRTINI
C
C initialize the parameter learning facility
      CALL PRTINI
C
C torsion angle dynamics
      CALL TORINI
C
C initialize the distance geometry bounds matrix stores
      CALL DGINIT
C=====================================================================
C #if defined(CNS_SOLVE_COMPILE)
C=====================================================================
C initialize ARIA
      CALL ARIINI
C
C initialize j coupling refinement
      CALL COUPINIT
C
C initialize carbon chemical shift stuff
      CALL CSHIFTINIT
C
C initialize the proton chemical shift stuff
      CALL HSHIFTINIT
C
C initialize the 1-bond J coupling stuff
      CALL ONEINIT
C
C initialize the Ramachandran stuff
      CALL RAMAINIT
C
C initialize the angle database stuff
      CALL ANGLEDBINIT
C
C initialize Tensor Anisotropy refinement
C      CALL TENSOINIT
C
C initial susceptibility anisotropy refinement
      CALL VEANINIT
C
C initial susceptibility anisotropy refinement
      CALL SANIINIT
C
C initial diffusion anisotropy refinement
      CALL DANIINIT
C
C rotation search clustering
      CALL CLUSINI
C
C mapyard module
      CALL INIMYCOMMON(.TRUE.)
C
C psearch module
      CALL INIPSTCOMMON(.TRUE.)
C=====================================================================
C #endif
C=====================================================================
C set bond, angle, dihedral, improper type-based parameter update flags
      UPBOND=.TRUE.
      UPANGL=.TRUE.
      UPDIHE=.TRUE.
      UPIMPR=.TRUE.
C
C initialize scalar stores
      DO I=1,MAXSTO
      PTRSTO(I)=0
      LENSTO(I)=0
      END DO
C
C constraints
      CALL CSTRES
C
C dihedral angle restraints
      CALL CDIINI
C
C NOE tables
      CALL NOEINI
C
C XAFS restraints
C      CALL XAFINI
C
C crystallographic restraints
      CALL XRERES
C
C energy term flags and descriptors
      CALL ENEINI
C
C non-crystallographic symmetry operators and counters
      CALL NCSINR
      CALL NCSINS
C
C planarity restraints
      CALL PLNINR
C
C set counter for some ENERGY calls
      ICYCLE=0
C
C RTF
      CALL RTFINI
C
C MTF
      CALL MTFRES
C
C parameters
      CALL PARINI
C
C chebychev poynomials
      CALL CHEINI
C
C message level and program abort level
      WRNLEV=5
      BOMLEV=0
C
C random number generator seed
      SEED=314159.0D0
C
C display and print files are set to system output (default)
      DUNIT=6
      PUNIT=6
C
C journal file unit is set to -1 (switched off)
      PRUNIT=-1
C
C initialize timer
      CALL VINTIM
      TIMER=0
C
C initialize prompt

C=====================================================================
C #if defined(CNS_SOLVE_COMPILE)
C=====================================================================
      PROMPT='CNSsolve>'
C=====================================================================
C #else
C=====================================================================
C      PROMPT='CNSrefine>'
C=====================================================================
C #endif
C=====================================================================
      PROMPTLEN=20
      CALL TRIMM(PROMPT,PROMPTLEN)
C
C write header
      CALL CNSHEADER(DATE,TIME,USERNM,SYSNM,HOSTNM)
C
C Verify FFT: Make sure FFT library actually works
      CALL VFYFFT
C
C Verify numerical code: Make sure a representative routine
C                        functions correctly
      CALL VFYNUM
C
      WRITE(6,'(1X)')
C
C command parsing
      CALL PUSEND(PROMPT(1:PROMPTLEN))
      DONE=.FALSE.
      DO WHILE (.NOT.DONE)
      CALL NEXTWD(PROMPT(1:PROMPTLEN))
      CALL MISCOM(PROMPT(1:PROMPTLEN),USED)
      IF (.NOT.USED) THEN
C
      IF (WD(1:4).EQ.'HELP') THEN
C
      CALL CNSHELP('cns')
C=====================================================================
C #if defined(CNS_SOLVE_COMPILE)
C=====================================================================
      ELSE IF (WD(1:4).EQ.'ANGL' ) THEN
      CALL READANGLEDB
      ELSE IF (WD(1:4).EQ.'CARB' ) THEN
      CALL READCSHIFT
      ELSE IF ((WD(1:4).EQ.'CONF' ).OR.(WD(1:4).EQ.'RAMA')) THEN
      CALL READRAMA
      ELSE IF (WD(1:4).EQ.'COUP' ) THEN
      CALL READCOUP
      ELSE IF (WD(1:4).EQ.'DANI' ) THEN
      CALL READDANI
      ELSE IF (WD(1:4).EQ.'ONEB' ) THEN
      CALL READONEBOND
C      ELSE IF (WD(1:5).EQ.'TENSO' ) THEN
C      CALL READTENSO
      ELSE IF (WD(1:4).EQ.'SANI' ) THEN
      CALL READSANI
      ELSE IF (WD(1:4).EQ.'VEAN' ) THEN
      CALL READVEAN
      ELSE IF (WD(1:4).EQ.'PROT' ) THEN
      CALL READHSHIFT
      ELSE IF (WD(1:4).EQ.'MIND' ) THEN
      CALL MINDWR
C=====================================================================
C #endif
C=====================================================================
      ELSE IF (WD(1:4).EQ.'ARIA' ) THEN
      CALL ARISET
      ELSE IF (WD(1:4).EQ.'CONN' ) THEN
      CALL CONNEC
      ELSE IF (WD(1:4).EQ.'COOR' ) THEN
      CALL CORMAN
      ELSE IF (WD(1:4).EQ.'DELE' ) THEN
      CALL DELTIC
      ELSE IF (WD(1:4).EQ.'DIST' ) THEN
      CALL DISTAN
      ELSE IF (WD(1:4).EQ.'DO' ) THEN
      CALL SCDO
      ELSE IF (WD(1:4).EQ.'DUPL' ) THEN
      CALL DUPLIC
      ELSE IF (WD(1:4).EQ.'DYNA' ) THEN
      CALL DYNMCS
      ELSE IF (WD(1:4).EQ.'ENER' ) THEN
      CALL PGETE(ICYCLE)
      ELSE IF (WD(1:4).EQ.'FAST' ) THEN
      CALL FNBSET('PARSE')
      ELSE IF (WD(1:3).EQ.'FIX' ) THEN
      CALL FIX
      ELSE IF (WD(1:4).EQ.'FLAG' ) THEN
      CALL EFLAGS('PARSE')
      ELSE IF (WD(1:4).EQ.'IDEN' ) THEN
      CALL SCIDEN
      ELSE IF (WD(1:4).EQ.'IGRO' ) THEN
      CALL PIG
      ELSE IF (WD(1:4).EQ.'MINI' ) THEN
      CALL MINIMI
      ELSE IF (WD(1:4).EQ.'MMDG') THEN
      CALL MMDG
      ELSE IF (WD(1:4).EQ.'MODE') THEN
      CALL MODES
      ELSE IF (WD(1:3).EQ.'NCS') THEN
      CALL NCSPAR
      ELSE IF (WD(1:4).EQ.'NOE ' ) THEN
      CALL NOESET
      ELSE IF (WD(1:4).EQ.'PARA' ) THEN
      CALL PARRDR
      ELSE IF (WD(1:4).EQ.'PATC' ) THEN
      CALL PATSET
      ELSE IF (WD(1:4).EQ.'PICK' ) THEN
      CALL PICK(.FALSE.)
      ELSE IF (WD(1:4).EQ.'PRIN' ) THEN
      CALL PRINT
      ELSE IF (WD(1:4).EQ.'READ' ) THEN
      CALL READD
      ELSE IF (WD(1:4).EQ.'REST' ) THEN
      CALL RSTRAN
      ELSE IF (WD(1:4).EQ.'ROTM' ) THEN
      CALL ROTMAN
      ELSE IF (WD(1:4).EQ.'SEGM' ) THEN
      CALL SEGMNT
      ELSE IF (WD(1:4).EQ.'SHOW' ) THEN
      CALL SCSHOW
      ELSE IF (WD(1:4).EQ.'STRU' ) THEN
      CALL MTFPRS
      ELSE IF (WD(1:4).EQ.'SURF' ) THEN
      CALL SURFAC
      ELSE IF (WD(1:4).EQ.'TEST' ) THEN
      CALL TESTCNS
      ELSE IF (WD(1:4).EQ.'TOPO' ) THEN
      CALL RTFRDR
      ELSE IF (WD(1:4).EQ.'WRIT' ) THEN
      CALL WRITT
C      ELSE IF (WD(1:4).EQ.'XAFS' ) THEN
C      CALL XAFS
      ELSE IF (WD(1:4).EQ.'XRAY' ) THEN
      CALL XRAY
      ELSE IF (WD(1:4).EQ.'?   ' ) THEN
      CALL SHOWAL
      ELSE IF (WD(1:4).EQ.'STOP'.OR.EOF ) THEN
      DONE=.TRUE.
      ENDIND=ENDIND-1
      ELSE
      CALL CHKEND(PROMPT(1:PROMPTLEN),DONE)
      IF (DONE) THEN
      WRITE(6,'(A)')
     &' %CNS-ERR: "END" not allowed. "STOP" terminates program'
      DONE=.FALSE.
      ENDIND=ENDIND+1
      END IF
      END IF
      END IF
      END DO
C
C terminate program
C
C=====================================================================
C #if defined(CNS_SOLVE_COMPILE)
C=====================================================================
C free ARIA lists
      CALL ARIHP(0,0,0)
C free proton chemical shift restraints list
      CALL HSHIFTSHP
C free j-coupling restraints list
      CALL COUPHP
C free carbon chemical shift restraints list
      CALL CARBHP
C free onebond j-coupling restraints list
      CALL ONEHP
C free conf. torsion angle database restraints list
      CALL RAMAHP
C free diffusion anisotropy restraints list
      CALL DANIHP
C free susceptibility anisotropy restraints list
      CALL SANIHP
C free susceptibility anisotropy restraints list
      CALL VEANHP
C free diffusion anisotropy restraints list
C      CALL TENSOHP
C free conf. angle database restraints list
      CALL ANGLEDBFREE
C rotation search clustering
      CALL CLUSFRE
C=====================================================================
C #endif
C=====================================================================
C free dihedral angle restraints list
      CALL CDIHP(0)
C free NOE restraints list
      CALL NOEHP(0)
C free XAFS restraints list
C      CALL XAFHP(0)
C free XRAY atom lists, reflections, and maps
      CALL XRAFRE
      CALL XRAATM(0)
      CALL XRMAPR(-1)
C
C free NCS group lists
      CALL NCSFIN
C
C free PLN group lists
      CALL PLNFIN
C
C free buffer stores
      DO I=1,MAXSTO
      IF (PTRSTO(I).NE.0) CALL FREHP(PTRSTO(I),IREAL8(LENSTO(I)))
      END DO
C
C free nonbonded lists
      DO I=1,NPIGMAX
      CALL RENBND(0,0,0,0,0,0,0,0,0,I)
      ENDDO
C
C free PIG arrays
      CALL PIGRSET('FREE')
C
C free up space for the trajectory writing facility
      CALL TRTFRE
C
C free up space for the parameter learning facility
      CALL PRTFRE
C
C free up torsion angle stuff
      CALL TORHP(0,.TRUE.)
C
C free up space for the distance geometry bounds matrices
      CALL DGRESZ(0)
C
C write info about STACK and HEAP
      CALL PRISTK
      CALL PRINHP
      CALL PRIEND
C
C close all files
      DO I=1,99
      CALL VINQRE('UNIT',WDT,WDTMAX,WDTLEN,QOPEN,QFORM,QWRITE,I)
      IF (QOPEN) CALL VCLOSE(I,'KEEP',ERROR)
      END DO
C
C write info about maximum dynamic memory usage and total CPU time
      CALL PRFINAL
C
      END
C
C======================================================================
C
      SUBROUTINE CNSHEADER(DATE,TIME,USERNM,SYSNM,HOSTNM)
C
      IMPLICIT NONE
C
      INCLUDE 'version.inc'
C I/O
      CHARACTER*11  DATE
      CHARACTER*8  TIME
      CHARACTER*12 USERNM
      CHARACTER*14 SYSNM
      CHARACTER*32 HOSTNM
C local
      INTEGER      HNLEN, TMP, PTRSZ, STLEN
      CHARACTER*(1) CNSPTMP
      CHARACTER*(4) ST
C
C write header
      WRITE(6,'(10X,A)')
     &'============================================================'
      WRITE(6,'(10X,A,58X,A)') '|','|'
      WRITE(6,'(10X,A,12X,A,12X,A)')
     &'|','Crystallography & NMR System (CNS)','|'
C=====================================================================
C #if defined(CNS_SOLVE_COMPILE)
C=====================================================================
      WRITE(6,'(10X,A,25X,A,25X,A)')
     &'|','CNSsolve','|'
C=====================================================================
C #else
C=====================================================================
C      WRITE(6,'(10X,A,24X,A,25X,A)')
C     &'|','CNSrefine','|'
C=====================================================================
C #endif
C=====================================================================
      WRITE(6,'(10X,A,58X,A)') '|','|'
      WRITE(6,'(10X,A)')
     &'============================================================'
      CNSPTMP=CNSPATCH
      IF (CNSPTMP.EQ.'0') THEN
      WRITE(6,'(10X,2A)')
     &' Version: ',CNSVERSION
      ELSE
      WRITE(6,'(10X,4A)')
     &' Version: ',CNSVERSION,' at patch level ',CNSPATCH
      END IF
      WRITE(6,'(10X,A)')
     &' Status: General release with ARIA enhancements'
      WRITE(6,'(10X,A)')
     &'============================================================'
      WRITE(6,'(10X,A,/,10X,A,/,10X,A,/,10X,A)')
     &' Written by: A.T.Brunger, P.D.Adams, G.M.Clore, W.L.DeLano,',
     &'             P.Gros, R.W.Grosse-Kunstleve, J.-S.Jiang,',
     &'             J.Kuszewski, M.Nilges, N.S.Pannu, R.J.Read,',
     &'             L.M.Rice, T.Simonson, G.L.Warren.'
      WRITE(6,'(10X,A)')
     &' Copyright (c) 1997-2007 Yale University'
      WRITE(6,'(10X,A)')
     &'============================================================'
C
      CALL VHOSTNAME(HOSTNM, HNLEN)
      CALL GETSYS(SYSNM,14,TMP)
C
      CALL CNSQPTRSZ(PTRSZ)
      PTRSZ=PTRSZ*8
      STLEN=4
      CALL ENCODI(PTRSZ,ST,4,STLEN)
C
      WRITE(6,'(10X,7A)')
     & ' Running on machine: ',HOSTNM(1:HNLEN),
     & ' (',SYSNM(1:TMP),',',ST(1:STLEN),'-bit)'
C
      CALL GETNAM(USERNM,12,TMP)
      WRITE(6,'(10X,2A)')
     & ' Program started by: ',USERNM(1:TMP)
C
      CALL VTIME(TIME,8,TMP)
      CALL VDATE(DATE,11,TMP)
      WRITE(6,'(10X,4A)')
     & ' Program started at: ',TIME,' on ',DATE(1:TMP)
C
      WRITE(6,'(10X,A)')
     &'============================================================'
C
      WRITE(6,'(1X)')
C
      RETURN
      END
C
C======================================================================
C


      SUBROUTINE SQUARE(X)
      PRINT X^2
      RETURN
      CALL SQUARE(5)
      END


        !COMPILER-GENERATED INTERFACE MODULE: Tue Oct 10 17:23:05 2017
        MODULE IRONCYCLE__genmod
          INTERFACE
            SUBROUTINE IRONCYCLE(TEMP,DET,PP_NZ,PP_ND,PP_PN,PP_DZ,      &
     &FE_SCAV,DETFE,DFE)
              REAL(KIND=8), INTENT(IN) :: TEMP
              REAL(KIND=8), INTENT(IN) :: DET
              REAL(KIND=8), INTENT(IN) :: PP_NZ
              REAL(KIND=8), INTENT(IN) :: PP_ND
              REAL(KIND=8), INTENT(IN) :: PP_PN
              REAL(KIND=8), INTENT(IN) :: PP_DZ
              REAL(KIND=8), INTENT(OUT) :: FE_SCAV
              REAL(KIND=8), INTENT(INOUT) :: DETFE
              REAL(KIND=8), INTENT(INOUT) :: DFE
            END SUBROUTINE IRONCYCLE
          END INTERFACE
        END MODULE IRONCYCLE__genmod


MODULE params_letkf

USE common, ONLY: r_size

IMPLICIT NONE

PUBLIC

!-------------------------------------------------------------------------------
! Ensemble Size
!-------------------------------------------------------------------------------
INTEGER,PARAMETER :: nbv=10

!-------------------------------------------------------------------------------
! From letkf_local.f90
!-------------------------------------------------------------------------------

!STEVE: Testing "Vertical Tube" localization:
!       i.e. the localization is not applied vertically
! This provides the benefit that
! (1) the analysis only has to be computed once
! per horizontal gridpoint, thus providing a nlevX (40X) speedup
! (2) the altimetry, SST, SSH, and bottom pressure (GRACE) can now be applied
! as direct constraints on the water column.
!
! There is precedence for this as in the paper "Reconstructing the Ocean's
! Interior from Surface Data" Wang et al. (2013)
!
!STEVE: making namelist accessible:
LOGICAL :: DO_NO_VERT_LOC=.true. !STEVE: moved to letkf_local.f90 from letkf_tools.f90
INTEGER :: localization_method=1 !1 !(OCEAN) =0 for uniform radius (default), =1 for latitude-dependent

!-------------------------------------------------------------------------------
! From letkf_tools.f90
!-------------------------------------------------------------------------------

! > 0: globally constant covariance inflation
! < 0: 3D inflation values input from a GPV file "infl_mul.grd"
REAL(r_size) :: cov_infl_mul = 1.0d0 !(NO INFLATION) !-1.0d0 => adaptive multiplicative inflation
REAL(r_size) :: sp_infl_add = 0.d0 !additive inflation
LOGICAL :: DO_INFL_RESET = .true. !(DO_SFCFLUXES) STEVE: for inflating only the surface forcing fields. Reset the 3D ocean interior to 0% inflation (rho = 1.0)

!-------------------------------------------------------------------------------
! From common_mom4.f90
!-------------------------------------------------------------------------------
! For (DRIFTERS)
LOGICAL :: DO_DRIFTERS=.false.
! For (SFCFLUX)
LOGICAL :: DO_SFCFLUX=.false.
! For (ALTIMETRY)
LOGICAL :: DO_ALTIMETRY=.false.

END MODULE params_letkf


      subroutine readops

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine reads data from the HRU/subbasin management input file
!!    (.mgt). This file contains data related to management practices used in
!!    the HRU/subbasin.

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name       |units            |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!                                 |urban.dat
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name            |units          |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!                                    |daily
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    eof         |none          |end of file flag (=-1 if eof, else = 0)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    day         |none          |day operation occurs
!!    mgt_op      |none          |operation code number
!!                               |0 end of rotation year
!!                               |1 plant/beginning of growing season
!!    mgt1i       |none          |first management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt2i       |none          |second management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt3i       |none          |third management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt4        |none          |fourth management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt5        |none          |fifth management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt6        |none          |sixth management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt7        |none          |seventh management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt8        |none          |eighth management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    mgt9        |none          |ninth management parameter out of .mgt
!!                               |file (definition changes depending on
!!                               |mgt_op)
!!    titldum     |NA            |title line from input dataset
!!    vfscon(:)   |none          |Fraction of the total runoff from the entire field
!!                               |entering the most concentrated 10% of the VFS.
!!    vfsratio(:) |none          |Field area/VFS area ratio
!!    vfsch(:)    |none          |Fraction of flow entering the most concentrated 10% of the VFS.
!!	                           |which is fully channelized
!!	grwat_n(:)      |none      |Mannings's n for grassed waterway
!!	grwat_i(:)      |none      |Flag for the simulation of grass waterways
!!                                 | gwat_i = 0 inactive
!!                                 |        = 1 active
!!	grwat_l(:)      |km	   |Length of grass Waterway
!!	grwat_w(:)      |m         |Average width of grassed waterway
!!	grwat_d(:)      |m         |Depth of grassed waterway from top of bank
!!                                 |  to bottom
!!	grwat_s(:)      |m         |Average slope of grassed waterway channel
!!	grwat_spcon(:)  |none      |Linear parameter for calculating sediment
!!                                 |  in grassed waterways
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: Jdt

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      character (len=80) :: titldum
	integer :: eof
	integer :: mon, day, mgt_op, mgt2i, mgt1i
	real :: mgt3,mgt4,mgt5,mgt6,mgt7,mgt8,mgt9

	read (111,5000,end=999) titldum

!!      read scheduled operations

          iops = 0

          do
          mon = 0
          day = 0
          year = 0.
          mgt_op = 0
          mgt1i = 0
          mgt2i = 0
          mgt3 = 0.
          mgt4 = 0.
          mgt5 = 0.
          mgt6 = 0
          mgt7 = 0.
          mgt8 = 0.
		mgt9 = 0.

          read (111,5200,iostat=eof) mon, day, iyear, mgt_op, mgt1i,
     & mgt2i, mgt3, mgt4, mgt5, mgt6, mgt7, mgt8, mgt9
	    if (eof < 0) exit
          iops = iops + 1
          iopday(iops,ihru) = Jdt (ndays,day,mon)
          iopyr(iops,ihru) = iyear
          mgt_ops(iops,ihru) = mgt_op

          select case (mgt_op)

          case (0)  !! end of operations file

          case (1)  !! terracing
             terr_p(iops,ihru) = mgt4
             terr_cn(iops,ihru) = mgt5
             terr_sl(iops,ihru) = mgt6

          case (2)  !! tile drainage
             drain_d(iops,ihru) = mgt4
             drain_t(iops,ihru) = mgt5
             drain_g(iops,ihru) = mgt6
             if (mgt7 < 1.e-6) mgt7 = 6000.0
             drain_idep(iops,ihru) = mgt7

          case (3)  !! contouring
             cont_cn(iops,ihru) = mgt4
             cont_p(iops,ihru) =  mgt5

          case (4)  !! filter
		     filter_i(iops,ihru) = mgt1i  !! on off flag
		     filter_ratio(iops,ihru) = mgt3
		     filter_con(iops,ihru) = mgt4
		     filter_ch(iops,ihru) = mgt5

          case (5)  !! strip cropping
             strip_n(iops,ihru) = mgt4
             strip_cn(iops,ihru) = mgt5
             strip_c(iops,ihru) = mgt6
             strip_p(iops,ihru) = mgt7

          case (6)  !! fire
             fire_cn(iops,ihru) = mgt4

          case (7)  !! grass waterways
             gwati(iops,ihru) = mgt1i
             gwatn(iops,ihru) = mgt3
             gwatspcon(iops,ihru) = mgt4
             gwatd(iops,ihru) = mgt5
             gwatw(iops,ihru) = mgt6
             gwatl(iops,ihru) = mgt7
             gwats(iops,ihru) = mgt8
!! Set defaults
!! Mannings via Fiener, 2006
	if (gwatn(iops,ihru) <=0.) gwatn(iops,ihru) = 0.35
!! length based on one side of a square HRU
	if (gwatl(iops,ihru) <=0.) gwatl(iops,ihru) = hru_km(ihru)**.5
!! default to a workable depth based on with and 8:1 sideslopes
	if (gwatd(iops,ihru) <= 0.) then
		gwatd(iops,ihru) = 3. / 64. * gwatw(iops,ihru)
	end if
!! Default to 3/4 HRU slope
	if (gwats(iops,ihru) <=0.) gwats(iops,ihru) = hru_slp(ihru)*.75
!! default sed coeff to 0.005
	if (gwatspcon(iops,ihru)<= 0.) gwatspcon(iops,ihru) = 0.005

          case (8) !! plant parameter update
             cropno_upd(iops,ihru) = mgt1i
             hi_upd(iops,ihru) = mgt4
             laimx_upd(iops,ihru) = mgt5

	!!	case (9) !! Residue Managment  mjw
	!! Force residue to a minimum value regardless of tillage.		mjw
	!!	so_res_flag(iops,ihru) = mgt1i !!mjw
	!!	so_res(iops,ihru) = mgt4 !!mjw

		case (10) !! Generic Conservation Practice  mjw
	!! Get user defined removal eff and use these		mjw
		ro_bmp_flag(iops,ihru) = mgt1i !! Flag to turn on or off user BMP
		ro_bmp_sed(iops,ihru) = mgt3 !! Sediment
		ro_bmp_pp(iops,ihru) = mgt4 !! Particulate P
		ro_bmp_sp(iops,ihru) = mgt5 !! Soluble P
		ro_bmp_pn(iops,ihru) = mgt7 !! Particulate N1123
		ro_bmp_sn(iops,ihru) = mgt8 !! Soluble N
		ro_bmp_bac(iops,ihru) = mgt9 !! Bacteria
          end select
          end do

      close (111)

  999 return
 5000 format (a)
 5200 format (1x,i2,1x,i2,5x,i4,1x,i2,1x,i4,1x,i3,1x,f6.2,1x,f12.5,1x,
     &        f6.2,1x,f11.5,1x,f8.2,1x,f6.2,1x,2f5.2)
      end


program test
c*****************************************************************
c     tests traversing directories to find all events
c****************************************************************
      implicit none
c
c     Constants
c
      include 'maxparticles.inc'
      include 'run_config.inc'
      include 'run.inc'
      include 'cuts.inc'
      integer    maxsubprocesses
      parameter (maxsubprocesses=9999)
      integer    cmax_events
      parameter (cmax_events=5000000)
      integer    sfnum
      parameter (sfnum=17)   !Unit number for scratch file
      integer    maxexternal
      parameter (maxexternal=2*max_particles-3)
c
c     for the run_card
c
      real*8 sf1,sf2,pb1,pb2,D
      integer lhaid
      character*7 pdlabel
c
c     Local
c
      character*300 subname(maxsubprocesses)
      character*310 pathsubname(maxsubprocesses)         !needed for MadWeight
      character*80 down_path                           !needed for MadWeight
      character*40 filename                         !needed for MadWeight
      character*4  card_number                         !needed for MadWeight
      character*20 run_name                            !needed for MadWeight
      integer pos1,pos2,pos3                           ! needed for MadWeight
      integer i,j,m,ns,nreq,ievent
      integer kevent,revent,iarray(cmax_events)
      double precision sum, xsec, xerr, goal_wgt,xarray(cmax_events)
      double precision xdum,rxsec
      integer i4,r8,record_length
      integer jseed,iseed
      real xran1
      double precision wgt,maxwgt
      double precision p(0:4,maxexternal)
      integer ic(7,maxexternal),n
      double precision sscale,aqcd,aqed
      character*20 param(maxpara),value(maxpara)
      integer npara,nunwgt
      double precision xtrunc, min_goal,max_goal
      logical keep(cmax_events),done
      integer ntry
      logical gridrun,gridpack
c
c     PARAM_CARD
c
      character*30 param_card_name
      common/to_param_card_name/param_card_name

      character*1000 buff
      logical u_syst, has_negative
      character*(s_bufflen) s_buff(7)
      integer nclus
      character*(clus_bufflen) buffclus(max_particles)
      data s_buff/7*''/
      data jseed/-1/
      data buffclus/max_particles*' '/
c-----
c  Begin Code
c-----
c
c     Get requested number of events
c
      include 'run_card.inc'

      has_negative = .false.
      if (gridpack) then
c        load the gridpack file
         call load_gridpack_para(npara,param,value)
         call get_logical(npara,param,value," gridrun ",gridrun,.false.)
      endif

      if (gridrun.and.gridpack) then
        call get_integer(npara,param,value," gevents "  ,nreq  ,2000   )
      else
        nreq = nevents
      endif
c   Get information for the <init> block
      param_card_name = '%(param_card_name)s'
      call setrun

c      nreq = 10000
c
c     Get total cross section
c
      xsec = 0d0
      xerr = 0d0
c $B$ input_file $B$
      filename='results.dat'
c $E$ input_file $E$

      open(unit=15,file=filename,status='old',err=21)
      read(15,*,err=20) xsec,xerr,xdum,xdum,xdum,xdum,xdum,xdum,xdum,rxsec
      write(*,*) "Results.dat xsec = ",rxsec," abs xsec = ",xsec
 20   close(15)
 21   if (nreq .gt. 0 .and. xsec .ne. 0) then
         goal_wgt = xsec/nreq/4d0   !Extra factor of 4 for weighted events
      else
         goal_wgt = 0d0    !Write out everything
      endif
c
c     Get list of subprocesses
c
      call get_subprocess(subname,ns)

c
c     Create scratch file to hold events
c
      I4 = 4
      R8 = 8
      record_length = 4*I4+maxexternal*I4*7+maxexternal*5*R8+3*R8+
     &   1000+7*s_bufflen+max_particles*clus_bufflen
C $B$ scratch_name $B$ !this is tag for automatic modification by MW
      filename='scratch'
C $E$ scratch_name $E$ !this is tag for automatic modification by MW
      open(unit=sfnum,access='direct',file=filename,err=999,
     &     recl=record_length)
c
c     Loop through subprocesses filling up scratch file with events
c
      sum=0d0
      kevent=0
      revent=0
      maxwgt=0d0
      write(*,*) 'SubProcess/Channel     kept   read   xsec '

C $B$ down_path $B$ !this is tag for automatic modification by MW
      down_path=''
c $E$ down_path $E$ !this is tag for automatic modification by MW
      do i=1,ns
c         write(*,*) 'Subprocess: ',subname(ns)
         pos3=index(subname(i),' ')
         pathsubname(i)=subname(i)(1:pos3-1)//down_path
         call read_channels(pathsubname(i),sum,kevent,revent,goal_wgt,maxwgt)
      enddo
c
c     Get Random order for events
c
      do i=1,kevent
         iarray(i)=i
         xarray(i)=xran1(jseed)
      enddo
      call sortO3(xarray,iarray,kevent)
c
c     Write out the events in iarray order
c
C $B$ output_file1 $B$ !this is tag for automatic modification by MW
      filename='../Events/events.lhe'
C $E$ output_file1 $E$ !this is tag for automatic modification by MW

      open(unit=15,file=filename,status='unknown',err=98)
      call writebanner(15,kevent,rxsec,maxwgt,xsec/kevent,xerr)
      do i=1,kevent
            read(sfnum,rec=iarray(i)) wgt,n,
     &           ((ic(m,j),j=1,maxexternal),m=1,7),ievent,
     &           ((p(m,j),m=0,4),j=1,maxexternal),sscale,aqcd,aqed,
     &           buff,(s_buff(j),j=1,7),(buffclus(j),j=1,max_particles)
c     Systematics info on/off
         if(s_buff(1)(1:7).eq.'<mgrwt>') then
            u_syst=.true.
         else
            u_syst=.false.
         endif
c        Find nclus
         nclus=max_particles
         do j=1,max_particles
            if(buffclus(j).eq.' ')then
               nclus=j-1
               exit
            elseif(buffclus(j).eq.'</clustering>') then
               nclus=j
               exit
            endif
         enddo
         call write_event(15,P,wgt,n,ic,ievent,sscale,aqcd,aqed,buff,
     $        u_syst,s_buff,nclus,buffclus)
      enddo
      close(15)
c
c     Now select unweighted events.
c
      goal_wgt = sum/(nreq*1.03)
      min_goal = goal_wgt/5d0
      max_goal = goal_wgt*5d0
      ntry = 1
c
c     Loop to refine guess for goal_wgt while keeping xtrunc<0.01
c
      done=.false.
      do while(.not. done)
         done=.true.
         nunwgt=0
         xtrunc=0d0
         do i=1,kevent
            read(sfnum,rec=iarray(i)) wgt,n,
     &           ((ic(m,j),j=1,maxexternal),m=1,7),ievent,
     &           ((p(m,j),m=0,4),j=1,maxexternal),sscale,aqcd,aqed,
     &        buff
            if (dabs(wgt) .gt. goal_wgt*xran1(jseed)) then
               keep(i) = .true.
               if (wgt.lt.0d0) has_negative = .true.
               nunwgt=nunwgt+1
               if (dabs(wgt) .gt. goal_wgt) then
                  xtrunc=xtrunc+dabs(wgt)-goal_wgt
               endif
            else
               keep(i)=.false.
            endif
         enddo
         if (xtrunc .gt. 0.01d0*sum) then
            done=.false.
            min_goal = max(goal_wgt,min_goal)
            goal_wgt = goal_wgt*1.3d0
            write(*,*) 'Iteration ',ntry, ' too large truncation ',xtrunc/sum,nunwgt
c            write(*,*) min_goal,goal_wgt,max_goal
         elseif (nunwgt .lt. nreq) then
            done=.false.
            max_goal = min(goal_wgt,max_goal)
            goal_wgt = goal_wgt*0.95d0
            write(*,*) 'Iteration ',ntry, ' too few events ',xtrunc/sum,nunwgt
c            write(*,*) min_goal,goal_wgt,max_goal
            if (goal_wgt .lt. min_goal) then
               done=.true.
               write(*,*) 'Failed to find requested number ',
     $              'of unweighted events',nreq,nunwgt
            endif
         endif
         ntry=ntry+1
         if (ntry .gt. 20) done=.true.
      enddo
      if (nunwgt .lt. nreq) then
         write(*,*) 'Unable to get ',nreq,' events. Writing ',nunwgt
         nreq = nunwgt
      else
         write(*,*) 'Found ',nunwgt,' events writing first ',nreq
      endif
      write(*,*) 'Unweighting selected ',nreq, ' events.'
      write(*,'(a,f5.2,a)') 'Truncated ',xtrunc*100./sum,
     $     '%% of cross section'

C $B$ output_file2 $B$ !this is tag for automatic modification by MW
      filename='../Events/unweighted_events.lhe'
C $E$ output_file2 $E$ !this is tag for automatic modification by MW

      open(unit=15,file=filename,status='unknown',err=99)
      call writebanner_u(15,nreq,rxsec,xtrunc,xsec/nreq,xerr, has_negative)
      ntry = 0
      do i=1,kevent
         if (keep(i) .and. ntry .lt. nreq) then
            read(sfnum,rec=iarray(i)) wgt,n,
     &           ((ic(m,j),j=1,maxexternal),m=1,7),ievent,
     &           ((p(m,j),m=0,4),j=1,maxexternal),sscale,aqcd,aqed,
     &           buff,(s_buff(j),j=1,7),(buffclus(j),j=1,max_particles)
            wgt=dsign(xsec/nreq,wgt)
c     Systematics info on/off
            if(s_buff(1)(1:7).eq.'<mgrwt>') then
               u_syst=.true.
            else
               u_syst=.false.
            endif
c        Find nclus
            do j=1,max_particles
               if(buffclus(j).eq.' ')then
                  nclus=j-1
                  exit
               elseif(buffclus(j).eq.'</clustering>') then
                  nclus=j
                  exit
               endif
            enddo
            call write_event(15,P,wgt,n,ic,ievent,sscale,aqcd,aqed,
     $           buff,u_syst,s_buff,nclus,buffclus)
            ntry=ntry+1
         endif
      enddo
      close(15)
      close(sfnum)
      goto 1000
 98   write(*,*) 'Error writing events.dat'
      goto 1000
 99   write(*,*) 'Error writing unweighted_events.dat'
      goto 1000
 999  write(*,*) 'Error opening scratch file'
 1000 continue
      end

      subroutine writebanner(lunw,nevent,sum,maxwgt,wgt,xerr)
c**************************************************************************************
c     Writes out banner information at top of event file
c**************************************************************************************
      implicit none
c
c     Arguments
c
      integer lunw,nevent
      double precision sum,maxwgt,wgt,xerr
c
c     Local
c
      integer i,j

c
c     Information required for 1>N processes
c
      include 'nexternal.inc'

c
c     Les Houches init block (for the <init> info)
c
      integer maxpup
      parameter(maxpup=%(maxpup)i)
      integer idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
      double precision ebmup,xsecup,xerrup,xmaxup
      common /heprup/ idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
     &     idwtup,nprup,xsecup(maxpup),xerrup(maxpup),
     &     xmaxup(maxpup),lprup(maxpup)

c
c     Global
c
c      double precision etmin(3:nexternal),etamax(3:nexternal)
c      double precision                    r2min(3:nexternal,3:nexternal)
c      double precision s_min(nexternal,nexternal)
c      common/to_cuts/  etmin     ,etamax     , r2min, s_min

c-----
c  Begin Code
c-----
c
c     gather the info
c
c      call setpara('param_card.dat')
c      call setcuts
c
c     write it out
c
c      call write_para(lunw)
c      write(lunw,'(a70)') '##                                                                    '
c      write(lunw,'(a70)') '##-------------------                                                 '
c      write(lunw,'(a70)') '## Run-time options                                                   '
c      write(lunw,'(a70)') '##-------------------                                                 '
c      write(lunw,'(a70)') '##                                                                    '
c     write(lunw,'(a70)') '##********************************************************************'
c     write(lunw,'(a70)') '## Standard Cuts                                                     *'
c     write(lunw,'(a70)') '##********************************************************************'
c      write(lunw,'(a13,8i8)')   '## Particle  ',(i,i=3,nexternal)
c      write(lunw,'(a13,8f8.1)') '## Et       >',(etmin(i),i=3,nexternal)
c      write(lunw,'(a13,8f8.1)') '## Eta      <',(etamax(i),i=3,nexternal)
c      do j=3,nexternal-1
c         write(lunw,'(a,i2,a,8f8.1)') '## d R #',j,'  >',(-0.0,i=3,j),
c     &        (r2min(i,j),i=j+1,nexternal)
c         do i=j+1,nexternal
c            r2min(i,j)=r2min(i,j)**2 !Since r2 returns distance squared
c         enddo
c      enddo
c      do j=3,nexternal-1
c         write(lunw,'(a,i2,a,8f8.1)') '## s min #',j,'>',
c     &        (s_min(i,j),i=3,nexternal)
c      enddo
c      write(lunw,'(a70)') '#********************************************************************'
c
c     Now write out specific information on the event set
c
c
      write(lunw,'(a)') '<MGGenerationInfo>'
      write(lunw,'(a30,i11)')   '#  Number of Events        :  ',nevent
      write(lunw,'(a30,e11.5)') '#  Integrated weight (pb)  :  ',sum
      write(lunw,'(a30,e11.5)') '#  Max wgt                 :  ',maxwgt
      write(lunw,'(a30,e11.5)') '#  Average wgt             :  ',wgt
      write(lunw,'(a)') '</MGGenerationInfo>'

C   Write out compulsory init info
      write(lunw,'(a)') ''
      write(lunw,'(a)') '<init>'
      if(nincoming.eq.2)then

          write(lunw,90) (idbmup(i),i=1,2),(ebmup(i),i=1,2),(pdfgup(i),i=1,2),
     $                   (pdfsup(i),i=1,2),2,nprup
         do i=1,nprup
             write(lunw,91) xsecup(i),xerr*xsecup(i)/sum,maxwgt,lprup(i) ! FACTOR OF nevts for maxwgt and wgt? error?
         enddo
      elseif(nincoming.eq.1)then
          write(lunw,90) (idbmup(i),i=1,2),(ebmup(i),i=1,2),-1,-1,
     $   -1,-1,2,nprup
          do i=1,nprup
             write(lunw,91) xsecup(i),xerr*xsecup(i)/sum,maxwgt,lprup(i) ! FACTOR OF nevts for maxwgt and wgt? error?
          enddo
      endif
      write(lunw,'(a)') '</init>'
 90   FORMAT(2i9,2e19.11,2i2,2i8,i2,i4)
 91   FORMAT(3e19.11,i4)
      end

      subroutine writebanner_u(lunw,nevent,sum,maxwgt,wgt,xerr,has_negative)
c**************************************************************************************
c     Writes out banner information at top of event file
c**************************************************************************************
      implicit none
c
c     Arguments
c
      integer lunw,nevent
      double precision sum,maxwgt,wgt,xerr
      logical has_negative
c
c     Local
c
      integer i,j
      double precision tmpsum
      integer lhastrategy
c
c     Les Houches init block (for the <init> info)
c
      integer maxpup
      parameter(maxpup=%(maxpup)i)
      integer idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
      double precision ebmup,xsecup,xerrup,xmaxup
      common /heprup/ idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
     &     idwtup,nprup,xsecup(maxpup),xerrup(maxpup),
     &     xmaxup(maxpup),lprup(maxpup)

c
c     Flag on how to write the LHE events
c     Include <clustering> tag for Pythia 8 CKKW-L matching
c
      logical clusinfo
      double precision lhe_version
      COMMON/TO_LHEFORMAT/lhe_version,clusinfo
c
c     Global
c
c      double precision etmin(3:nexternal),etamax(3:nexternal)
c      double precision                    r2min(3:nexternal,3:nexternal)
c      double precision s_min(nexternal,nexternal)
c      common/to_cuts/  etmin     ,etamax     , r2min, s_min

c-----
c  Begin Code
c-----
c
c     gather the info
c
c      call setpara('param_card.dat')
c      call setcuts
c
c     write it out
c
c      call write_para(lunw)
c      write(lunw,'(a70)') '##                                                                    '
c      write(lunw,'(a70)') '##-------------------                                                 '
c      write(lunw,'(a70)') '## Run-time options                                                   '
c      write(lunw,'(a70)') '##-------------------                                                 '
c      write(lunw,'(a70)') '##                                                                    '
c     write(lunw,'(a70)') '##********************************************************************'
c     write(lunw,'(a70)') '## Standard Cuts                                                     *'
c     write(lunw,'(a70)') '##********************************************************************'
c      write(lunw,'(a13,8i8)')   '## Particle  ',(i,i=3,nexternal)
c      write(lunw,'(a13,8f8.1)') '## Et       >',(etmin(i),i=3,nexternal)
c      write(lunw,'(a13,8f8.1)') '## Eta      <',(etamax(i),i=3,nexternal)
c      do j=3,nexternal-1
c         write(lunw,'(a,i2,a,8f8.1)') '## d R #',j,'  >',(-0.0,i=3,j),
c     &        (r2min(i,j),i=j+1,nexternal)
c         do i=j+1,nexternal
c            r2min(i,j)=r2min(i,j)**2 !Since r2 returns distance squared
c         enddo
c      enddo
c      do j=3,nexternal-1
c         write(lunw,'(a,i2,a,8f8.1)') '## s min #',j,'>',
c     &        (s_min(i,j),i=3,nexternal)
c      enddo
c      write(lunw,'(a70)') '##********************************************************************'
c
c     Now write out specific information on the event set
c

      write(lunw,'(a)') '<MGGenerationInfo>'
      write(lunw,'(a30,i11)')   '#  Number of Events        :  ',nevent
      write(lunw,'(a30,e11.5)') '#  Integrated weight (pb)  :  ',sum
      write(lunw,'(a30,e11.5)') '#  Truncated wgt (pb)      :  ',maxwgt
      write(lunw,'(a30,e11.5)') '#  Unit wgt                :  ',wgt
      write(lunw,'(a)') '</MGGenerationInfo>'

      if (has_negative) then
        lhastrategy = -3
      else
        lhastrategy = 3
      endif

C   Write out compulsory init info
      write(lunw,'(a)') ''
      write(lunw,'(a)') '<init>'
      write(lunw,90) (idbmup(i),i=1,2),(ebmup(i),i=1,2),(pdfgup(i),i=1,2),
     $   (pdfsup(i),i=1,2),lhastrategy,nprup
      do i=1,nprup
         write(lunw,91) xsecup(i),xerr*xsecup(i)/sum,sum/nevent,lprup(i) ! FACTOR OF nevts for maxwgt and wgt? error?
      enddo
      if (lhe_version.ge.3) then
        write(lunw,'(a)') "<generator name='MadGraph5_aMC@NLO' version='X.X.X'>           "
        write(lunw,'(a)') "please cite 1405.0301 </generator>"
      endif
      write(lunw,'(a)') '</init>'
 90   FORMAT(2i9,2e19.11,2i2,2i8,i3,i4)
 91   FORMAT(3e19.11,i4)

      end

      subroutine read_channels(dir,sum,kevent,revent,goal_wgt,maxwgt)
c*****************************************************************
c     tests traversing directories to find all events
c****************************************************************
      implicit none
c
c     Constants
c
      character*(*) symfile
      parameter (symfile='symfact.dat')
      include 'maxparticles.inc'
c
c     Arguments
c
      character*(*) dir
      integer kevent,revent
      double precision sum,goal_wgt,maxwgt
c
c     Local
c
      integer i,j, k, ip
      double precision xi
      character*300 dirname,dname,channame
      integer ncode,npos
      character*20 formstr
c-----
c  Begin Code
c-----
      i = index(dir," ")
c     ncode is number of digits needed for the bw coding
      ncode=int(dlog10(3d0)*(max_particles-3))+1
      dname = dir(1:i-1)// "/" // symfile
      open(unit=35, file=dname ,status='old',err=59)
      do while (.true.)
         read(35,*,err=99,end=99) xi,j
         if (j .gt. 0) then
            j=1 ! symmetry factor already read in auto_dsig.f
            k = int(xi*(1+10**(-ncode)))
            npos=int(dlog10(dble(k)))+1
            if ( (xi-k) .eq. 0) then
c              Write with correct number of digits
               write(formstr,'(a,i1,a)') '(a,i',npos,',a)'
               write(dirname, formstr) 'G',k,'/'
            else if(npos+ncode+1.lt.10) then               !Handle B.W.
c              Write with correct number of digits
               write(formstr,'(a,i1,a,i1,a)') '(a,f',npos+ncode+1,
     $                 '.',ncode,',a)'
               write(dirname,formstr)  'G',xi,'/'
            else               !Handle B.W.
c              Write with correct number of digits
               write(formstr,'(a,i2,a,i1,a)') '(a,f',npos+ncode+1,
     $                 '.',ncode,',a)'
               write(dirname,formstr)  'G',xi,'/'
            endif
            ip = index(dirname,'/')
            channame = dname(1:i-1)// "/" //dirname(1:ip)
            call read_dir_events(channame(1:i+ip),j,kevent,revent,sum,goal_wgt,maxwgt)
            write(*,'(a,2i8,e10.3)') channame(1:i+ip),kevent,revent,sum
         endif
 98   enddo
 99   close(35)
      return
c
c     Come here if there isn't a symfact file. Means we will work on
c     this file alone
c
 59   dirname="./"
      j = 1
      ip = 2
      channame = dirname(1:ip)
      call read_dir_events(channame,j,kevent,revent,sum,goal_wgt,maxwgt)
      write(*,'(a30,i8,e10.3)') channame(1:i+ip),kevent,sum
      return
      end

      subroutine read_dir_events(channame,nj,kevent,revent,sum,goal_wgt,maxwgt)
c********************************************************************
c********************************************************************
      implicit none
c
c     parameters
c
      integer    sfnum
      parameter (sfnum=17)   !Unit number for scratch file
      character*(*) scaled_file
      parameter (scaled_file='events.lhe')
      include 'maxparticles.inc'
      integer    maxexternal
      parameter (maxexternal=2*max_particles-3)
      include 'run_config.inc'
      include 'run.inc'
      integer    max_read
      parameter (max_read = 5000000)
c
c     Arguments
c
      character*(*) channame
      integer nj,kevent,revent
      double precision sum,goal_wgt,maxwgt
c
c     Local
c
      double precision wgt
      double precision p(0:4,maxexternal)
      double precision gsfact
      real xwgt(max_read),xtot
      integer i,j,k,m, ic(7,maxexternal),n
      double precision sscale,aqcd,aqed,tmpsum
      integer ievent,jseed
      logical done,found
      character*1000 buff
      logical u_syst
      character*(s_bufflen) s_buff(7)
      character*300 fullname
      integer nclus
      character*(clus_bufflen) buffclus(max_particles)
      data buffclus/max_particles*' '/
c
c     Les Houches init block (for the <init> info)
c
      integer maxpup
      parameter(maxpup=%(maxpup)i)
      integer idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
      double precision ebmup,xsecup,xerrup,xmaxup
      common /heprup/ idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
     &     idwtup,nprup,xsecup(maxpup),xerrup(maxpup),
     &     xmaxup(maxpup),lprup(maxpup)
      data nprup/0/
      data xsecup/maxpup*0d0/
c
c     external
c
      real xran1
c
c     data
c
      data jseed/-1/
c-----
c  Begin Code
c-----
      fullname = channame // "gscalefact.dat"
      gsfact = 1d0
      open (unit=15,file=fullname,status='old',err=12)
      read(15,*) gsfact    !Scale factor for grid runs that only use some channels
 12   close(15)
      if (gsfact .eq. 0d0) return
      fullname = channame // scaled_file
      open(unit=15,file=fullname, status='old',err=999)
      done=.false.
c
c     Start by initializing all event variables to zero (not really necessary)
c
      do j=1,maxexternal
         do i=1,7
            ic(i,j)=0
         enddo
         do i=0,4
            p(i,j) = 0d0
         enddo
      enddo
c
c     Now loop through events
c
      do while (.not. done)
         call read_event(15,P,wgt,n,ic,ievent,sscale,aqcd,aqed,buff,
     $        u_syst,s_buff,nclus,buffclus,done)
         if (.not. done) then
            revent = revent+1
            wgt = wgt*nj*gsfact                 !symmetry factor * grid factor
            if (dabs(wgt) .gt. maxwgt) maxwgt=dabs(wgt)
            if (dabs(wgt) .ge. goal_wgt*xran1(jseed)) then
               kevent=kevent+1
               if (dabs(wgt) .lt. goal_wgt) wgt = dsign(goal_wgt,wgt)
               write(sfnum,rec=kevent) wgt,n,
     &           ((ic(m,j),j=1,maxexternal),m=1,7),ievent,
     &           ((p(m,j),m=0,4),j=1,maxexternal),sscale,aqcd,aqed,
     &           buff,(s_buff(j),j=1,7),(buffclus(j),j=1,max_particles)
               sum=sum+dabs(wgt)
               found=.false.
               do i=1,nprup
                  if(ievent.eq.lprup(i))then
                     xsecup(i)=xsecup(i)+wgt
                     found=.true.
                  endif
               enddo
               if(.not.found)then
                  nprup=nprup+1
                  lprup(nprup)=ievent
                  xsecup(nprup)=wgt
               endif
            endif
         endif
         if (kevent .ge. max_read) then
            write(*,*) 'Error too many events to read in combine_events',
     $           kevent
            write(*,*) 'Increase cmax_events and max_read in ',
     $                 'Source/combine_events.f'
            stop
         endif
      enddo
 99   close(15)
 55   format(i3,4e19.11)
c      write(*,*) 'Found ',kevent,' events'
c      write(*,*) 'Integrated weight',sum
      return
 999  write(*,*) 'Error opening file ',channame,scaled_file

      end

      subroutine get_subprocess(subname,ns)
c*****************************************************************
c     tests traversing directories to find all events
c****************************************************************
      implicit none
c
c     Constants
c
      character*(*) plist
      parameter (plist='subproc.mg')
c
c     Arguments
c
      character*300 subname(*)
      integer ns
c-----
c  Begin Code
c-----
      ns = 1
      open(unit=15, file=plist,status='old',err=99)
      do while (.true.)
         read(15,*,err=999,end=999) subname(ns)
         ns=ns+1
      enddo
 99   subname(ns) = './'
      write(*,*) "Did not find ", plist
      return
 999  ns = ns-1
      write(*,*) "Found ", ns," subprocesses"
      close(15)
      end

      function xran1(idum)
      dimension r(97)
      parameter (m1=259200,ia1=7141,ic1=54773,rm1=3.8580247e-6)
      parameter (m2=134456,ia2=8121,ic2=28411,rm2=7.4373773e-6)
      parameter (m3=243000,ia3=4561,ic3=51349)
      data iff /0/
      save r, ix1,ix2,ix3
      if (idum.lt.0.or.iff.eq.0) then
        iff=1
        ix1=mod(ic1-idum,m1)
        ix1=mod(ia1*ix1+ic1,m1)
        ix2=mod(ix1,m2)
        ix1=mod(ia1*ix1+ic1,m1)
        ix3=mod(ix1,m3)
        do 11 j=1,97
          ix1=mod(ia1*ix1+ic1,m1)
          ix2=mod(ia2*ix2+ic2,m2)
          r(j)=(float(ix1)+float(ix2)*rm2)*rm1
11      continue
        idum=1
      endif
      ix1=mod(ia1*ix1+ic1,m1)
      ix2=mod(ia2*ix2+ic2,m2)
      ix3=mod(ia3*ix3+ic3,m3)
      j=1+(97*ix3)/m3
      if(j.gt.97.or.j.lt.1)then
         write(*,*) 'j is bad in ran1.f',j, 97d0*ix3/m3
         STOP
      endif
      xran1=r(j)
      r(j)=(float(ix1)+float(ix2)*rm2)*rm1
      return
      end

      subroutine sort2(array,aux1,n)
      implicit none
! Arguments
      integer n
      integer aux1(n)
      double precision array(n)
!  Local Variables
      integer i,k
      double precision temp
      logical done

!-----------
! Begin Code
!-----------
      do i=n-1,1,-1
         done = .true.
         do k=1,i
            if (array(k) .lt. array(k+1)) then
               temp = array(k)
               array(k) = array(k+1)
               array(k+1) = temp
               temp = aux1(k)
               aux1(k) = aux1(k+1)
               aux1(k+1) = temp
               done = .false.
            end if
         end do
         if (done) return
      end do
      end

      subroutine sortO3(array,aux1,n)

c   O-Sort Version 3, Sorting routine by Erik Oosterwal
c   http://www.geocities.com/oosterwal/computer/sortroutines.html

      implicit none

! Arguments
      integer n
      integer aux1(n)
      double precision array(n)
!  Local Variables
      integer step,i,itemp
      double precision SngPhi,SngFib

      SngPhi = 0.78             ! Define phi value
      SngFib = n * SngPhi       ! Set initial real step size
      step = int(SngFib)        ! set initial integer step size

      do while (step > 0)
        do i = 1,n-step         ! Set the range of the lower search cells
          if (array(aux1(i))<array(aux1(i+step))) then ! Compare cells
            itemp = aux1(i)     !                       \
            aux1(i) = aux1(i+step) !                     | Swap cells
            aux1(i+step) = itemp !                      /
          end if
        enddo

        SngFib = SngFib * SngPhi ! Decrease the Real step size
        Step = Int(SngFib)      ! Set the integer step value

      enddo

      end