  subroutine ek_bulk
     ! Calculate bulk's energy bands using wannier TB method
     !
     ! Copyright (c) 2010 QuanSheng Wu. All rights reserved.

     use wmpi
     use para

     implicit none

     integer :: ik, i, j
     integer :: knv3
     integer :: Nwann
     integer :: ierr
     real(dp) :: emin
     real(dp) :: emax
     real(Dp) :: k(3)
     real(Dp) :: W(Num_wann)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     ! eigen value of H
	  real(dp), allocatable :: eigv(:,:)
	  real(dp), allocatable :: eigv_mpi(:,:)
	  real(dp), allocatable :: weight(:,:,:)
	  real(dp), allocatable :: weight_mpi(:,:,:)

     knv3= nk3_band
     allocate( eigv    (Num_wann, knv3))
     allocate( eigv_mpi(Num_wann, knv3))
     allocate( weight    (Num_wann,Num_wann, knv3))
     allocate( weight_mpi(Num_wann,Num_wann, knv3))
     eigv    = 0d0
     eigv_mpi= 0d0
     weight = 0d0
     weight_mpi = 0d0

     do ik= 1+cpuid, knv3, num_cpu
        if (cpuid==0) write(stdout, *)'BulkBand, ik, knv3 ', ik, knv3

        k = k3points(:, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk_old(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'V', 'U', Num_wann ,Hamk_bulk, W)

        if (sum(abs(k))<1e-5) call  orbital_momenta(k, Hamk_bulk)

        eigv(:, ik)= W
        do i=1, Num_wann  !> band
           do j=1, Num_wann/2  !> projector
              weight(j, i, ik)= sqrt(abs(Hamk_bulk(j, i))**2+ &
                 abs(Hamk_bulk(j+ Num_wann/2, i))**2)
           enddo ! j
        enddo ! i
     enddo ! ik

#if defined (MPI)
     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
     call mpi_allreduce(weight, weight_mpi,size(weight),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     eigv_mpi= eigv
     weight_mpi= weight
#endif

     weight= weight_mpi/maxval(weight_mpi)*255d0

     outfileindex= outfileindex+ 1
     if (cpuid==0)then
        open(unit=outfileindex, file='bulkek.dat')

        do i=1, Num_wann
           do ik=1, knv3
              write(outfileindex, '(2f19.9, 1000i5)')k3len(ik),eigv_mpi(i, ik), &
                 int(weight(:, i, ik))
           enddo
           write(outfileindex, *)' '
        enddo
        close(outfileindex)
     endif

     !> minimum and maximum value of energy bands
     emin=  minval(eigv_mpi)-0.5d0
     emax=  maxval(eigv_mpi)+0.5d0

     !> write script for gnuplot
     outfileindex= outfileindex+ 1
     if (cpuid==0) then
        open(unit=outfileindex, file='bulkek.gnu')
        write(outfileindex, '(a)') 'set terminal  postscript enhanced color font ",30"'
        write(outfileindex,'(2a)') '#set palette defined ( 0  "green", ', &
           '5 "yellow", 10 "red" )'
        write(outfileindex, '(a)')"set output 'bulkek.eps'"
        write(outfileindex, '(a)')'set style data linespoints'
        write(outfileindex, '(a)')'unset ztics'
        write(outfileindex, '(a)')'unset key'
        write(outfileindex, '(a)')'set pointsize 0.8'
        write(outfileindex, '(a)')'set view 0,0'
        write(outfileindex, '(a)')'set xtics font ",24"'
        write(outfileindex, '(a)')'set ytics font ",24"'
        write(outfileindex, '(a)')'set ylabel font ",24"'
        write(outfileindex, '(a)')'set ylabel "Energy (eV)"'
        write(outfileindex, '(a)')'set ylabel offset 1.5,0'
        write(outfileindex, '(a, f10.5, a)')'set xrange [0: ', maxval(k3len), ']'
        write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']'
        write(outfileindex, 202, advance="no") (k3line_name(i), k3line_stop(i), i=1, nk3lines)
        write(outfileindex, 203)k3line_name(nk3lines+1), k3line_stop(nk3lines+1)

        do i=1, nk3lines-1
           write(outfileindex, 204)k3line_stop(i+1), emin, k3line_stop(i+1), emax
        enddo
        write(outfileindex, '(2a)')"plot 'bulkek.dat' u 1:2 ",  &
            "w lp lw 2 pt 7  ps 0.2 lc rgb 'black', 0 w l lw 2"
        close(outfileindex)
     endif

     202 format('set xtics (',:20('"',A3,'" ',F10.5,','))
     203 format(A3,'" ',F10.5,')')
     204 format('set arrow from ',F10.5,',',F10.5,' to ',F10.5,',',F10.5, ' nohead')

   return
   end subroutine ek_bulk

  subroutine ek_bulk_spin
  ! Calculate bulk's energy band using wannier TB method
  ! also calculate spin direction for each band and each kpoint

     use wmpi
     use para

     implicit none

     integer :: ik, i, j, ib
	  integer :: knv3
     integer :: ierr
     integer :: nwann
     real(dp) :: sx, sy, sz
     real(dp) :: emin
     real(dp) :: emax
     real(dp) :: k(3)
     real(dp) :: W(Num_wann)

     ! Hamiltonian of bulk system
     complex(dp), allocatable :: Hamk_bulk(:, :)
     complex(dp), allocatable :: sigmax(:, :)
     complex(dp), allocatable :: sigmay(:, :)
     complex(dp), allocatable :: sigmaz(:, :)
     complex(dp), allocatable :: psi(:)

     ! eigen value of H
	  real(dp), allocatable :: eigv(:,:)
	  real(dp), allocatable :: eigv_mpi(:,:)
	  real(dp), allocatable :: spin(:, :, :)
	  real(dp), allocatable :: spin_mpi(:, :, :)

     knv3= nk3_band
     allocate( psi( Num_wann))
     allocate( Hamk_bulk( Num_wann, Num_wann))
     allocate( sigmax( Num_wann, Num_wann))
     allocate( sigmay( Num_wann, Num_wann))
     allocate( sigmaz( Num_wann, Num_wann))
     allocate( eigv    (Num_wann, knv3))
     allocate( eigv_mpi(Num_wann, knv3))
     allocate( spin    (3, Num_wann, knv3))
     allocate( spin_mpi(3, Num_wann, knv3))
     psi = 0d0
	  eigv = 0d0
	  eigv_mpi= 0d0
     spin= 0d0
     spin_mpi= 0d0
     sigmax= 0d0
     sigmay= 0d0
     sigmaz= 0d0

     nwann= Num_wann/2

     if (SOC==0) stop 'you should set soc=0 in the input file'
     !> construct spin matrix
     do i= 1, nwann
        sigmax(i, i+ nwann)= 1d0
        sigmax(i+ nwann, i)= 1d0
        sigmay(i, i+ nwann)= -zi
        sigmay(i+ nwann, i)= zi
        sigmaz(i, i)= 1d0
        sigmaz(i+ nwann, i+ nwann)= -1d0
     enddo

     do ik= 1+cpuid, knv3, num_cpu
        if (cpuid==0) write(stdout, *)'BulkBandSpin, ik, knv3 ', ik, knv3

        k = k3points(:, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk_old(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'V', 'U', Num_wann ,Hamk_bulk, W)

        eigv(:, ik)= W

        do ib= 1, Num_wann
           psi(:)= Hamk_bulk(:, ib)
           sx= 0d0
           sy= 0d0
           sz= 0d0
           do i= 1, Num_wann
              do j= 1, Num_wann
                 sx= sx+ conjg(psi(i))* sigmax(i, j)* psi(j)
                 sy= sy+ conjg(psi(i))* sigmay(i, j)* psi(j)
                 sz= sz+ conjg(psi(i))* sigmaz(i, j)* psi(j)
              enddo ! j
           enddo ! i
           spin(1, ib, ik)= sx
           spin(2, ib, ik)= sy
           spin(3, ib, ik)= sz
        enddo ! ib

     enddo ! ik

#if defined (MPI)
     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
     call mpi_allreduce(spin,spin_mpi,size(spin),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     eigv_mpi= eigv
     spin_mpi= spin
#endif

     outfileindex= outfileindex+ 1
     if (cpuid==0)then
        open(unit=outfileindex, file='bulkek.dat')

        do i=1, Num_wann
           do ik=1, knv3
              write(outfileindex, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik), spin(:, i, ik)
           enddo
           write(outfileindex, *)' '
        enddo
        close(outfileindex)
     endif

     !> minimum and maximum value of energy bands
     emin= minval(eigv_mpi)-0.5d0
     emax= maxval(eigv_mpi)+0.5d0

     !> write script for gnuplot
     outfileindex= outfileindex+ 1
     if (cpuid==0) then
        open(unit=outfileindex, file='bulkek.gnu')
        write(outfileindex, '(a)') 'set terminal  postscript enhanced color font 24'
        write(outfileindex,'(2a)') '#set palette defined ( 0  "green", ', &
           '5 "yellow", 10 "red" )'
        write(outfileindex, '(a)')"set output 'bulkek.eps'"
        write(outfileindex, '(a)')'set style data linespoints'
        write(outfileindex, '(a)')'unset ztics'
        write(outfileindex, '(a)')'unset key'
        write(outfileindex, '(a)')'set pointsize 0.8'
        write(outfileindex, '(a)')'set view 0,0'
        write(outfileindex, '(a)')'set ylabel "Energy (eV)"'
        write(outfileindex, '(a, f10.5, a)')'set xrange [0: ', maxval(k3len), ']'
        write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']'
        write(outfileindex, 202, advance="no") (k3line_name(i), k3line_stop(i), i=1, nk3lines)
        write(outfileindex, 203)k3line_name(nk3lines+1), k3line_stop(nk3lines+1)

        do i=1, nk3lines-1
           write(outfileindex, 204)k3line_stop(i+1), emin, k3line_stop(i+1), emax
        enddo
        write(outfileindex, '(2a)')"plot 'bulkek.dat' u 1:2 ",  &
            "w lp lw 2 pt 7  ps 0.2, \"
        write(outfileindex, '(2a)')"     'bulkek.dat' u 1:2:($3/6):($4/6) ",  &
            "w vec"
        close(outfileindex)
     endif

     202 format('set xtics (',:20('"',A3,'" ',F10.5,','))
     203 format(A3,'" ',F10.5,')')
     204 format('set arrow from ',F10.5,',',F10.5,' to ',F10.5,',',F10.5, ' nohead')

   return
   end subroutine ek_bulk_spin

   subroutine ek_bulk_fortomas
     ! only for IrF4 project

     use wmpi
     use para

     implicit none

     integer :: ik1, ik2, ik3
     integer :: Nk_t
     integer :: ierr
     real(Dp) :: k(3), k1, k2, k3
     real(Dp) :: W(Num_wann)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     if (cpuid==0)then
        open(unit=14, file='bulkek-fortomas.dat')
        open(unit=15, file='bulkek-math.dat')
     endif

     Nk_t= 10
     if (cpuid==0) write (15, '(A)', advance="NO")'{'
     do ik1=0, Nk_t
     if (cpuid==0) write (15, '(A)', advance="NO")'{'
     do ik2=0, Nk_t
     if (cpuid==0) write (15, '(A)', advance="NO")'{'
     do ik3=0, Nk_t
        k1= dble(ik1)/Nk_t
        k2= dble(ik2)/Nk_t
        k3= dble(ik3)/Nk_t

        k(1)= 0.5d0*k2+ 0.5d0*k3
        k(2)= 0.5d0*k3+ 0.5d0*k1
        k(3)= 0.5d0*k1+ 0.5d0*k2

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk_old(k, Hamk_bulk)

        !> diagonalization by call zheev in lapack
        W= 0d0
        call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)

        if (cpuid==0) then
           write(14, '(3i5, 4f12.8)')ik1, ik2, ik3, W(9:12)
           if (ik3/=Nk_t) then
              write(15, '(a, 4(f12.7, a))', advance="No")"{", W(9), ",", W(10), ",", W(11), ",", W(12), "},"
           else
              write(15, '(a, 4(f12.7, a))', advance="No")"{", W(9), ",", W(10), ",", W(11), ",", W(12), "}"
           endif
        endif
     enddo !ik3
     if (ik2/=Nk_t) then
     if (cpuid==0) write (15, '(A)', advance="NO")'},'
     else
     if (cpuid==0) write (15, '(A)', advance="NO")'}'
     endif
     enddo !ik2
     if (ik1/=Nk_t) then
     if (cpuid==0) write (15, '(A)', advance="NO")'},'
     else
     if (cpuid==0) write (15, '(A)', advance="NO")'}'
     endif
     enddo !ik1
     if (cpuid==0) write (15, '(A)', ADVANCE="NO")'}'
     if (cpuid==0) close(14)

   return
   end subroutine ek_bulk_fortomas

  subroutine ek_bulk_mirror_z
     ! Use the eigenvalue of mirror z to label the energy bands

     use wmpi
     use para

     implicit none

     integer :: ik, i, j
	  integer :: knv3
     integer :: ierr
     real(dp) :: emin
     real(dp) :: emax
     real(Dp) :: k(3)
     real(Dp) :: W(Num_wann)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)
     complex(Dp) :: Hamk     (Num_wann,Num_wann)
     complex(Dp) :: mat1     (Num_wann,Num_wann)
     complex(Dp) :: mat2     (Num_wann,Num_wann)

     ! eigen value of H
	  real(dp), allocatable :: eigv(:,:)
	  real(dp), allocatable :: eigv_mpi(:,:)
     logical, allocatable :: mirror_plus(:, :)
     logical, allocatable :: mirror_minus(:, :)

     knv3= nk3_band
     allocate( eigv    (Num_wann, knv3))
     allocate( eigv_mpi(Num_wann, knv3))
     allocate( mirror_plus(Num_wann, knv3))
     allocate( mirror_minus(Num_wann, knv3))
     mirror_plus= .False.
     mirror_minus= .False.
     eigv    = 0d0
     eigv_mpi= 0d0

     do ik= 1+cpuid, knv3, num_cpu
        if (cpuid==0) write(stdout, *)'BulkBandmirrorz, ik, knv3 ', ik, knv3

        k = k3points(:, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk_old    (k, Hamk_bulk)

        k = k3points(:, ik)
        k(3)= -k(3)
        Hamk= 0d0
        call ham_bulk_old    (k, Hamk)

        !> symmetrization
        call mat_mul(Num_wann, mirror_z, hamk, mat1)
        call mat_mul(Num_wann, mat1, mirror_z, mat2)
        hamk= (Hamk_bulk+ mat2)/2.d0

        !> diagonal hamk
        call eigensystem_c('V', 'U', Num_wann, hamk, W)

        mat2= conjg(transpose(hamk))

        !> calculate mirror eigenvalue
        call mat_mul(Num_wann, mat2, mirror_z, mat1)
        call mat_mul(Num_wann, mat1, hamk, mat2)

        !> get mirror_plus and mirror_minus
        do i=1, Num_wann
           if (abs(real(mat2(i, i))-1d0)< 1e-3) then
              mirror_plus(i, ik)= .true.
           else
              mirror_minus(i, ik)= .true.
           endif
        enddo

       !if (cpuid.eq.0)write(*, *)ik,&
       !   (mirror_plus(i, ik), i=1, Num_wann)
        eigv(:, ik)= W

     enddo  ! ik

#if defined (MPI)
     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     eigv_mpi= eigv
#endif

     if (cpuid==0)then
        open(unit=14, file='bulkek.dat')
        do i=1, Num_wann
           do ik=1, knv3
              write(14, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik)
           enddo
           write(14, *)' '
        enddo
        close(14)

        open(unit=15, file='bulkekmirrorplus.dat')
        open(unit=16, file='bulkekmirrorminus.dat')
        do i=1, Num_wann
           do ik=1, knv3
              if (mirror_plus(i, ik)) then
                 write(15, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik)
              else
                 write(16, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik)
              endif
           enddo
           write(15, *)' '
           write(16, *)' '
        enddo
        close(15)
        close(16)

     endif

     !> minimum and maximum value of energy bands
     emin= minval(eigv_mpi)-0.5d0
     emax= maxval(eigv_mpi)+0.5d0

     !> write script for gnuplot
     outfileindex= outfileindex+ 1
     if (cpuid==0) then
        open(unit=outfileindex, file='bulkek.gnu')
        write(outfileindex, '(a)') 'set terminal  postscript enhanced color'
        write(outfileindex,'(2a)') '#set palette defined ( 0  "green", ', &
           '5 "yellow", 10 "red" )'
        write(outfileindex, '(a)')"set output 'bulkek.eps'"
        write(outfileindex, '(a)')'set style data linespoints'
        write(outfileindex, '(a)')'unset ztics'
        write(outfileindex, '(a)')'unset key'
        write(outfileindex, '(a)')'set pointsize 0.8'
        write(outfileindex, '(a)')'set view 0,0'
        write(outfileindex, '(a)')'set xtics font ",24"'
        write(outfileindex, '(a)')'set ytics font ",24"'
        write(outfileindex, '(a)')'set ylabel font ",24"'
        write(outfileindex, '(a)')'set ylabel "Energy (eV)"'
        write(outfileindex, '(a, f10.5, a)')'set xrange [0: ', maxval(k3len), ']'
        write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']'
        write(outfileindex, 202, advance="no") (k3line_name(i), k3line_stop(i), i=1, nk3lines)
        write(outfileindex, 203)k3line_name(nk3lines+1), k3line_stop(nk3lines+1)

        do i=1, nk3lines-1
           write(outfileindex, 204)k3line_stop(i+1), emin, k3line_stop(i+1), emax
        enddo
        write(outfileindex, '(2a)')"plot 'bulkek.dat' u 1:2 ",  &
            "w lp lw 2 pt 7  ps 0.2, 0 w l"
        close(outfileindex)
     endif

     202 format('set xtics (',:20('"',A3,'" ',F10.5,','))
     203 format(A3,'" ',F10.5,')')
     204 format('set arrow from ',F10.5,',',F10.5,' to ',F10.5,',',F10.5, ' nohead')

   return
   end subroutine ek_bulk_mirror_z

  subroutine ek_bulk_mirror_x
  !> calculate bulk band for a given mirror symmetry

     use wmpi
     use para

     implicit none

     integer :: ik, i, j
     integer :: knv3
     integer :: ierr
     real(dp) :: emin
     real(dp) :: emax
     real(Dp) :: k(3)
     real(Dp) :: W(Num_wann)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)
     complex(Dp) :: Hamk     (Num_wann,Num_wann)
     complex(Dp) :: mat1     (Num_wann,Num_wann)
     complex(Dp) :: mat2     (Num_wann,Num_wann)
     complex(dp) :: inv_mirror_x(Num_wann, Num_wann)

     ! eigen value of H
	  real(dp), allocatable :: eigv(:,:)
	  real(dp), allocatable :: eigv_mpi(:,:)
     logical, allocatable :: mirror_plus(:, :)
     logical, allocatable :: mirror_minus(:, :)

     knv3= nk3_band
     allocate( eigv    (Num_wann, knv3))
     allocate( eigv_mpi(Num_wann, knv3))
     allocate( mirror_plus(Num_wann, knv3))
     allocate( mirror_minus(Num_wann, knv3))
     mirror_plus= .False.
     mirror_minus= .False.
     eigv    = 0d0
     eigv_mpi= 0d0

     do ik= 1+cpuid, knv3, num_cpu
        if (cpuid==0) write(stdout, *)'EkBulk_mirror, ik, knv3 ', ik, knv3

        k = k3points(:, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk_old    (k, Hamk_bulk)

       !k = k3points(:, ik)
       !k(1)= -k(1)
       !Hamk= 0d0
       !call ham_bulk_old    (k, Hamk)

        hamk=  Hamk_bulk
        !> symmetrization
        inv_mirror_x=mirror_x

        call inv(Num_wann, inv_mirror_x)

       !print *, maxval(abs(inv_mirror_x-mirror_x))
       !stop

        call mat_mul(Num_wann, inv_mirror_x, hamk, mat1)
        call mat_mul(Num_wann, mat1, mirror_x, mat2)
        hamk= (Hamk_bulk+ mat2)/2.d0
       !hamk=  mat2

        !> diagonal hamk
        call eigensystem_c('V', 'U', Num_wann, hamk, W)

        mat2= conjg(transpose(hamk))

        !> calculate mirror eigenvalue
        call mat_mul(Num_wann, mat2, mirror_x, mat1)
        call mat_mul(Num_wann, mat1, hamk, mat2)

        !> get mirror_plus and mirror_minus
        do i=1, Num_wann
           if (abs(real(mat2(i, i))-1d0)< 1e-3) then
              mirror_plus(i, ik)= .true.
           else
              mirror_minus(i, ik)= .true.
           endif
        enddo

       !if (cpuid.eq.0)write(*, *)ik,&
       !   (mirror_plus(i, ik), i=1, Num_wann)
        eigv(:, ik)= W

     enddo  ! ik

#if defined (MPI)
     call mpi_allreduce(eigv,eigv_mpi,size(eigv),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     eigv_mpi= eigv
#endif

     if (cpuid==0)then
        open(unit=14, file='bulkek.dat')
        do i=1, Num_wann
           do ik=1, knv3
              write(14, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik)
           enddo
           write(14, *)' '
        enddo
        close(14)

        open(unit=15, file='bulkekmirrorplus.dat')
        open(unit=16, file='bulkekmirrorminus.dat')
        do i=1, Num_wann
           do ik=1, knv3
              if (mirror_plus(i, ik)) then
                 write(15, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik)
              else
                 write(16, '(1000f19.9)')k3len(ik),eigv_mpi(i, ik)
              endif
           enddo
           write(15, *)' '
           write(16, *)' '
        enddo
        close(15)
        close(16)

     endif

     !> minimum and maximum value of energy bands
     emin= minval(eigv_mpi)-0.5d0
     emax= maxval(eigv_mpi)+0.5d0

     !> write script for gnuplot
     outfileindex= outfileindex+ 1
     if (cpuid==0) then
        open(unit=outfileindex, file='bulkek.gnu')
        write(outfileindex, '(a)') 'set terminal  postscript enhanced color'
        write(outfileindex,'(2a)') '#set palette defined ( 0  "green", ', &
           '5 "yellow", 10 "red" )'
        write(outfileindex, '(a)')"set output 'bulkek.eps'"
        write(outfileindex, '(a)')'set style data linespoints'
        write(outfileindex, '(a)')'unset ztics'
        write(outfileindex, '(a)')'unset key'
        write(outfileindex, '(a)')'set pointsize 0.8'
        write(outfileindex, '(a)')'set view 0,0'
        write(outfileindex, '(a)')'set xtics font ",24"'
        write(outfileindex, '(a)')'set ytics font ",24"'
        write(outfileindex, '(a)')'set ylabel font ",24"'
        write(outfileindex, '(a)')'set ylabel "Energy (eV)"'
        write(outfileindex, '(a, f10.5, a)')'set xrange [0: ', maxval(k3len), ']'
        write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']'
        write(outfileindex, 202, advance="no") (k3line_name(i), k3line_stop(i), i=1, nk3lines)
        write(outfileindex, 203)k3line_name(nk3lines+1), k3line_stop(nk3lines+1)

        do i=1, nk3lines-1
           write(outfileindex, 204)k3line_stop(i+1), emin, k3line_stop(i+1), emax
        enddo
        write(outfileindex, '(2a)')"plot 'bulkek.dat' u 1:2 ",  &
            "w lp lw 2 pt 7  ps 0.2, 0 w l"
        close(outfileindex)
     endif

     202 format('set xtics (',:20('"',A3,'" ',F10.5,','))
     203 format(A3,'" ',F10.5,')')
     204 format('set arrow from ',F10.5,',',F10.5,' to ',F10.5,',',F10.5, ' nohead')

   return
   end subroutine ek_bulk_mirror_x


program flcube !@(#) track a cube with the locator
!(LICENSE:PD)
use M_draw
use M_draw, only : D_BLACK
implicit none
real,parameter     :: TRANS = 20.0, SC = 0.1
integer, parameter :: FACE = 1, FILLED = 2, OUTLINE = 3
character(len=10)  :: device
character(len=1)   :: but
logical            :: back, fill, hatch
integer            :: idum
real               :: x,y
real               :: tdir
real               :: scal
integer            :: nplanes
   write(*,*)'x,y,z = translate'
   write(*,*)'s     = apply scale'
   write(*,*)'+,-   = change scale/translate direction'
   write(*,*)'f,h   = fill, hatch'
   write(*,*)'b     = toggle backface'
   write(*,*)'q     = quit'

!     print*, 'Enter output device:'
!     read(*, '(a)') device
   device=' '

   call prefposition(50, 50)
   call prefsize(500, 500)

   call vinit(device)

   call window(-800.0, 800.0, -800.0, 800.0, -800.0, 800.0)
   call lookat(0.0, 0.0, 1500.0, 0.0, 0.0, 0.0, 0.0)

   tdir = TRANS
   scal = SC

!
! Start with a very ordinary filled cube like in the original demo...
!
   call polyhatch(.false.)
   call hatchang(45.0)
   call hatchpitch(40.0)
   call polyfill(.true.)

   fill = .true.
   hatch = .false.
   back = .true.

   call makeobj(FACE)
   call makepoly()
   call rect(-200.0, -200.0, 200.0, 200.0)
   call closepoly()
   call closeobj()

   call makecube(FILLED)

   nplanes = getdepth()
   if (nplanes .eq. 1) call makecube(OUTLINE)

   call backface(back)
!
! Setup drawing into the backbuffer....
!
   if (backbuffer().lt.0) then
      call vexit()
      write(*,*)'Device can''t support doublebuffering'
      stop
   endif

   INFINITE: do
      idum = slocator(x, y)
      call pushmatrix()
      call rotate(100.0 * x, 'y')
      call rotate(100.0 * y, 'x')
      call color(D_BLACK)
      call clear()
      call callobj(FILLED)
      if (nplanes .eq. 1 .and. (fill .or. hatch)) call callobj(OUTLINE)
      call popmatrix()
      call swapbuffers()

      but = char(checkkey())
      select case(but)
       case('x')
         call translate(tdir, 0.0, 0.0)
       case('y')
         call translate(0.0, tdir, 0.0)
       case('z')
         call translate(0.0, 0.0, tdir)
       case('s')
         call scale(scal, scal, scal)
       case('f')
         fill = .not. fill
         hatch = .false.
         call polyfill(fill)
       case('h')
         hatch = .not. hatch
         fill = .false.
         call polyhatch(hatch)
       case('b')
         back = .not. back
         call backface(back)
       case('-')
         tdir = -tdir
         if (scal .lt. 1.0) then
            scal = 1.0 + SC
         else
            scal = 1.0 - SC
         endif
       case('+')
         tdir = TRANS
       case('q',char(27))
         call vexit()
         stop
      end select
   enddo INFINITE
contains

   subroutine makecube(obj)
   use M_draw
   use M_draw, only : D_BLACK, D_RED, D_GREEN, D_YELLOW, D_BLUE, D_CYAN, D_MAGENTA, D_WHITE
   implicit none

   integer           :: obj
   integer,parameter :: OUTLINE=3, FILLED=2, FACE=1

      call makeobj(obj)
      if (obj .eq. OUTLINE) then
         call pushattributes()
         call color(D_BLACK)
         call polyfill(.false.)
         call polyhatch(.false.)
      endif

      call pushmatrix()
      call translate(0.0, 0.0, 200.0)
      if (obj .eq. FILLED) call color(D_RED)
      call callobj(FACE)
      call popmatrix()

      call pushmatrix()
      call translate(200.0, 0.0, 0.0)
      call rotate(90.0, 'y')
      if (obj .eq. FILLED) call color(D_GREEN)
      call callobj(FACE)
      call popmatrix()

      call pushmatrix()
      call translate(0.0, 0.0, -200.0)
      call rotate(180.0, 'y')
      if (obj .eq. FILLED) call color(D_BLUE)
      call callobj(FACE)
      call popmatrix()

      call pushmatrix()
      call translate(-200.0, 0.0, 0.0)
      call rotate(-90.0, 'y')
      if (obj .eq. FILLED) call color(D_CYAN)
      call callobj(FACE)
      call popmatrix()

      call pushmatrix()
      call translate(0.0, 200.0, 0.0)
      call rotate(-90.0, 'x')
      if (obj .eq. FILLED) call color(D_MAGENTA)
      call callobj(FACE)
      call popmatrix()

      call pushmatrix()
      call translate(0.0, -200.0, 0.0)
      call rotate(90.0, 'x')
      if (obj .eq. FILLED) call color(D_YELLOW)
      call callobj(FACE)
      call popmatrix()

      if (obj .eq. OUTLINE) call popattributes()

      call closeobj()

   end subroutine makecube
end program flcube


module cell_to_edge_module

  use bl_types, only: dp_t
  use bl_error_module, only: bl_error

  implicit none

  private

  public :: cell_to_edge

contains

  subroutine cell_to_edge(s0_cell,s0_edge)

    use bl_constants_module, only: HALF
    use geometry, only: r_start_coord, r_end_coord, nr, &
                        numdisjointchunks, spherical
    use restrict_base_module

    real(kind=dp_t), intent(in   ) :: s0_cell(:,0:)
    real(kind=dp_t), intent(inout) :: s0_edge(:,0:)

    real(kind=dp_t)                ::  s0min,s0max,tmp
    integer                        ::  n,r,i,nlevs

    if (spherical .eq. 1) then
       call bl_error('calling cell_to_edge with spherical .eq. 1')
    end if

    nlevs = size(s0_cell,dim=1)

    do n=1,nlevs
       do i=1,numdisjointchunks(n)
          !$OMP PARALLEL DO PRIVATE(r,tmp,s0min,s0max)
          do r=r_start_coord(n,i),r_end_coord(n,i)+1

             if (r .eq. 0) then
                ! if we are at lower domain boundary
                s0_edge(n,r) = s0_cell(n,r)
             else if (r .eq. 1 .or. r .eq. r_start_coord(n,i)) then
                ! if we are at lower domain boundary+1 OR
                ! if we are at bottom of coarse-fine interface that is not a domain boundary
                s0_edge(n,r) = HALF*(s0_cell(n,r-1)+s0_cell(n,r))
             else if (r .eq. nr(n)) then
                ! if we are at upper domain boundary
                s0_edge(n,r) = s0_cell(n,r-1)
             else if (r .eq. nr(n)-1 .or. r .eq. r_end_coord(n,i)+1) then
                ! if we are at upper domain boundary-1 OR
                ! if we are at top of coarse-fine interface that is not a domain boundary
                s0_edge(n,r) = HALF*(s0_cell(n,r)+s0_cell(n,r-1))
             else
                ! fourth order
                tmp = 7.d0/12.d0 * (s0_cell(n,r  ) + s0_cell(n,r-1)) &
                     -1.d0/12.d0 * (s0_cell(n,r+1) + s0_cell(n,r-2))
                s0min      = min(s0_cell(n,r),s0_cell(n,r-1))
                s0max      = max(s0_cell(n,r),s0_cell(n,r-1))
                s0_edge(n,r) = min(max(tmp,s0min),s0max)
             end if

          end do
          !$OMP END PARALLEL DO
       end do
    end do

    ! make the edge values synchronous across levels
    call restrict_base(s0_edge, .false.)

  end subroutine cell_to_edge

end module cell_to_edge_module


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief calculate ice density  [kg/m^3]
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] ismpl local sample index
!>    @details
!>    Fukusako, S.:
!>    Thermophysical Properties of Ice, Snow,and Sea Ice
!>    International Journal of Thermophysics, 1990, 11, 353-372
!>
!>    There should be another source.
      DOUBLE PRECISION FUNCTION rhoi(i,j,k,ismpl)

        use arrays
        IMPLICIT NONE

        INTEGER i, j, k, ui, ismpl
        DOUBLE PRECISION plocal, tlocal

        tlocal = temp(i,j,k,ismpl)
        IF (tlocal>0.D0) tlocal = 0.D0

        rhoi = 917.D0 - 0.151D0*tlocal

        RETURN
      END


! Demonstrate performing a rotation on a pair of signals using the SAC library
program rotate_example
    implicit none

    integer,parameter :: nmax = 1000000
    integer :: npts, nerr
    real :: signal1(nmax), signal2(nmax)
    real :: rotated_signal1(nmax), rotated_signal2(nmax)
    real :: beg, dt
    real*8 :: angle
    real :: baz, cmpaz1
    logical :: lnpi, lnpo

    integer sac_compare

    ! Read in the two signals to be rotated
    call rsac1('signal1.sac', signal1, npts, beg, dt, nmax, nerr)
    call getfhv("cmpaz", cmpaz1, nerr)
    call getfhv("baz", baz, nerr);

    call rsac1('signal2.sac', signal2, npts, beg, dt, nmax, nerr)

    ! Set up parameters for rotation
    lnpi = .true.     ! input signals have "normal" polarity
    lnpo = .true.     ! output signals have "normal polarity

    angle = baz + 180.0 - cmpaz1;

    call rotate(signal1, signal2, npts, angle, lnpi, lnpo, rotated_signal1, rotated_signal2)

    nerr = sac_compare("signalr.sac", rotated_signal1, npts, beg, dt)
    nerr = sac_compare("signalt.sac", rotated_signal2, npts, beg, dt)

    ! write the seismogram with trend removed back to disk
    call wsac0('rotated1.sac', rotated_signal1, rotated_signal1, nerr)
    call wsac0('rotated2.sac', rotated_signal2, rotated_signal2, nerr)

end program rotate_example


! =============================================================================
!                       Test bilinear interpolation
!
!         This unit test checks the bilinear interpolation par2grid
! =============================================================================
program test_bilinear
    use unit_test
    use constants, only : pi, zero, one, f14, f32
    use parcel_container
    use parcel_interpl, only : par2grid, par2grid_timer
    use parcel_ellipse, only : get_ab
    use parameters, only : lower, update_parameters, vcell, dx, nx, nz, ngrid
    use fields, only : volg, field_alloc
    use timer
    implicit none

    double precision :: error
    integer :: i, j, k, jj, ii

    nx = 32
    nz = 32
    lower  = (/-f32, -f32/)
    extent =  (/0.4d0, 0.4d0/)

    call register_timer('par2grid', par2grid_timer)

    call update_parameters

    call field_alloc

    n_parcels = 4*nx*nz
    call parcel_alloc(n_parcels)

    k = 1
    do j = 0, nz-1
        do i = 0, nx-1
            do jj = 1, 4, 2
                do ii = 1, 4, 2
                    parcels%position(1, k) = lower(1) + i * dx(1) + f14 * dx(1) * ii
                    parcels%position(2, k) = lower(2) + j * dx(2) + f14 * dx(2) * jj
                    k = k + 1
                enddo
            enddo
        enddo
    enddo

    parcels%volume = f14 * vcell

    ! b11
    parcels%B(1, :) = get_ab(parcels%volume(1:n_parcels))

    ! b12
    parcels%B(2, :) = zero

    call par2grid

    error = abs(sum(volg(0:nz, 0:nx-1)) - dble(ngrid) * vcell)

    call print_result_dp('Test bilinear (par2grid)', error, atol=dble(1.0e-14))

end program test_bilinear


module constants

	! pi, g (gravity)
	real(kind(1d0)),parameter,public:: pi = 3.14159265358979323846d0, g = 9.81d0

end module constants


c
c------------------------------------------------------------
c
       subroutine reg_slopes(q,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,lstgrd,
     &                   lwidth,hx,hy,xlow,ylow,mptr,nvar,istage)

       use amr_module
       implicit double precision(a-h,o-z)

       dimension q(nvar,mitot,mjtot),qx(nvar,mitot,mjtot),
     &           qy(nvar,mitot,mjtot),irr(mitot,mjtot)
       dimension qxx(nvar,mitot,mjtot), qyy(nvar,mitot,mjtot)
       dimension qxy(nvar,mitot,mjtot)
       logical  quad, nolimiter
       include "cuserdt.i"
       common /order2/ ssw, quad, nolimiter

c
c  Set all slopes, even for irregular or solid.
c  Will be fixed in slope routines for irregular/solid cells called afterwards

c      # ssw = slope switch (1. for slopes, 0 for donor cell 0 slopes)
c      # now set in amrcart
c
c   ssw = 0 for ctu (no slopes), 1 for muscl (second order).
c   compute slopes using muscl limiter
c   q contains either conserved or primitive variables
c
c  now set for quadratic reconstruction. Limiting done elsewhere
c  initialized in method (in case no slopes at all)

       hx2 = 2.d0*hx
       hy2 = 2.d0*hy
       hxsq = hx*hx
       hysq = hy*hy
c
       if (ssw .eq. 0.d0) go to 99
c
       do 12 j = 1, mjtot
       do 10 i = 2, mitot-1
       !!  for now do for all if (irr(i,j) .ne. lstgrd) go to 10
       do 11 m = 1, nvar
          qx(m,i,j)  = (q(m,i+1,j) - q(m,i-1,j))/hx2
          qxx(m,i,j) = (q(m,i+1,j)-2.d0*q(m,i,j)+q(m,i-1,j))/hxsq
 11    continue
 10    continue
 12    continue
c
       do 22 j = 2, mjtot-1
       do 21 i = 1, mitot
       !! for now do for all if (irr(i,j) .ne. lstgrd) go to 21
       do 20 m = 1, nvar
          qy(m,i,j) = (q(m,i,j+1) - q(m,i,j-1))/hy2
          qyy(m,i,j) = (q(m,i,j+1)-2.d0*q(m,i,j)+q(m,i,j-1))/hysq
          ! next line relies on qxy=0 at first and last rows/cols, so
          ! qxy only exists in interior
          if (i .gt. 1 .and. i .lt. mitot) then
             qxy(m,i,j) = (qx(m,i,j+1) - qx(m,i,j-1))/hy2
          endif
 20    continue
 21    continue
 22    continue
c
 99    continue
       return
       end


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testEigenvalueSolver
#include "UnitTest.h"
USE UnitTest
USE IntrType
USE ExceptionHandler
USE trilinos_interfaces
USE ParameterLists
USE ParallelEnv
USE VectorTypes
USE MatrixTypes
USE EigenvalueSolverTypes

#ifdef FUTILITY_HAVE_PETSC
#include <petscversion.h>
#if (((PETSC_VERSION_MAJOR>=3) && (PETSC_VERSION_MINOR>6)) || (PETSC_VERSION_MAJOR>=4))
USE PETSCSYS
#endif
#endif

IMPLICIT NONE

TYPE(ExceptionHandlerType),TARGET :: e
TYPE(MPI_EnvType) :: mpiTestEnv
TYPE(ParamType) :: pList, optList
CLASS(EigenvalueSolverType_Base),POINTER :: testEVS
CLASS(DistributedMatrixType),POINTER :: A => NULL()
CLASS(DistributedMatrixType),POINTER :: B => NULL()

#ifdef FUTILITY_HAVE_PETSC
#include <petscversion.h>
#if (((PETSC_VERSION_MAJOR>=3) && (PETSC_VERSION_MINOR>=6)) || (PETSC_VERSION_MAJOR>=4))
#include <petsc/finclude/petsc.h>
#else
#include <finclude/petsc.h>
#endif
#undef IS
PetscErrorCode  :: ierr
#ifdef FUTILITY_HAVE_SLEPC
CALL SlepcInitialize(PETSC_NULL_CHARACTER,ierr)
#else
CALL PETScInitialize(PETSC_NULL_CHARACTER,ierr)
#endif
#endif
!> set up default parameter list
CALL optList%clear()
CALL optList%add('EigenvalueSolverType->n',2_SIK)
CALL optList%add('EigenvalueSolverType->nlocal',2_SIK)
CALL optList%add('EigenvalueSolverType->solver',ARNOLDI)
CALL optList%add('EigenvalueSolverType->preconditioner','none')
CALL optList%add('EigenvalueSolverType->tolerance',1.0e-8_SRK)
CALL optList%add('EigenvalueSolverType->max_iterations',2_SIK)

!Configure exception handler for test
CALL e%setStopOnError(.FALSE.)
CALL e%setQuietMode(.TRUE.)
CALL eParams%addSurrogate(e)
CALL eEigenvalueSolverType%addSurrogate(e)
CALL mpiTestEnv%init(PE_COMM_SELF)

CREATE_TEST('Test Eigenvalue Solvers')

ALLOCATE(EigenvalueSolverType_SLEPC :: testEVS)
#ifdef FUTILITY_HAVE_SLEPC
REGISTER_SUBTEST('testInitSLEPc',testInitSLEPc)
REGISTER_SUBTEST('testSetMatSLEPc',testSetMatSLEPc)
REGISTER_SUBTEST('testSetX0SLEPc',testSetX0SLEPc)
REGISTER_SUBTEST('testSetConvSLEPc',testSetConvSLEPc)
REGISTER_SUBTEST('testSolveSLEPc',testSolveSLEPc)
REGISTER_SUBTEST('testGetResidSLEPc',testGetResidSLEPc)
REGISTER_SUBTEST('testClearSLEPc',testClearSLEPc)
#endif
IF(ASSOCIATED(A)) THEN
  IF(A%isInit) THEN
    CALL A%clear()
  ENDIF
  DEALLOCATE(A)
ENDIF
IF(ASSOCIATED(B)) THEN
  IF(B%isInit) THEN
    CALL B%clear()
  ENDIF
  DEALLOCATE(B)
ENDIF
DEALLOCATE(testEVS)
ALLOCATE(EigenvalueSolverType_Anasazi :: testEVS)
CALL optList%set('EigenvalueSolverType->solver',GD)
CALL optList%set('EigenvalueSolverType->n',30_SIK)
CALL optList%set('EigenvalueSolverType->nlocal',30_SIK)
#ifdef FUTILITY_HAVE_Trilinos
REGISTER_SUBTEST('testInitAnasazi',testInitAnasazi)
REGISTER_SUBTEST('testSetMatAnasazi',testSetMatAnasazi)
REGISTER_SUBTEST('testSetX0Anasazi',testSetX0Anasazi)
REGISTER_SUBTEST('testSetConvAnasazi',testSetConvAnasazi)
REGISTER_SUBTEST('testSolveAnasazi',testSolveAnasazi)
!REGISTER_SUBTEST('testGetResidAnasazi',testGetResidAnasazi)
REGISTER_SUBTEST('testClearAnasazi',testClearAnasazi)
#endif
FINALIZE_TEST()

CALL pList%clear()
CALL optList%clear()

IF(ASSOCIATED(A)) THEN
  IF(A%isInit) THEN
    CALL A%clear()
  ENDIF
  DEALLOCATE(A)
ENDIF
IF(ASSOCIATED(B)) THEN
  IF(B%isInit) THEN
    CALL B%clear()
  ENDIF
  DEALLOCATE(B)
ENDIF
DEALLOCATE(testEVS)

#ifdef FUTILITY_HAVE_PETSC
CALL PetscFinalize(ierr)
#else
CALL mpiTestEnv%finalize()
#endif
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE testInitSLEPc()
  CALL testEVS%init(mpiTestEnv,optList)
  ASSERT(testEVS%isInit,'%isInit')
  ASSERT(testEVS%n==2,'%n')
  ASSERT(testEVS%maxit==2,'%maxit')
  ASSERT(testEVS%tol==1.0E-8_SRK,'%tol')
  ASSERT(testEVS%SolverMethod==ARNOLDI,'%SolverMethod')
  ASSERT(testEVS%TPLType==SLEPC,'%SolverMethod')
  ASSERT(ASSOCIATED(testEVS%MPIparallelEnv),'%MPIenv')
  ASSERT(testEVS%X%isInit ,'%x')
  SELECTTYPE(testEVS); TYPE IS(EigenvalueSolverType_SLEPC)
#ifdef FUTILITY_HAVE_SLEPC
    ASSERT(testEVS%xi%isInit,'%xi')
#endif
  ENDSELECT
ENDSUBROUTINE testInitSLEPc
!
!-------------------------------------------------------------------------------
SUBROUTINE testClearSLEPc()
  CALL testEVS%clear()
  ASSERT(testEVS%solverMethod==-1,'%solverMethod')
  ASSERT(testEVS%TPLType==-1,'%TPLType')
  ASSERT(.NOT. ASSOCIATED(testEVS%MPIparallelEnv),'%MPIenv')
  ASSERT(.NOT. testEVS%OMPparallelEnv%isInit(),'%OMPenv')
  ASSERT(testEVS%n==-1,'%n')
  ASSERT(testEVS%maxit==-1,'%maxit')
  ASSERT(testEVS%tol==0.0_SRK,'%tol')
  ASSERT(testEVS%k==0.0_SRK,'%k')
  ASSERT(.NOT. ASSOCIATED(testEVS%A),'%A')
  ASSERT(.NOT. ASSOCIATED(testEVS%B),'%B')
  ASSERT(.NOT. ASSOCIATED(testEVS%X),'%x')
  SELECTTYPE(testEVS); TYPE IS(EigenvalueSolverType_SLEPC)
#ifdef FUTILITY_HAVE_SLEPC
    ASSERT(.NOT. (testEVS%xi%isInit),'%xi')
#endif
  ENDSELECT
ENDSUBROUTINE testClearSLEPc
!
!-------------------------------------------------------------------------------
SUBROUTINE testSetMatSLEPc()
  CALL plist%clear()
  CALL plist%add('MatrixType->n',2_SIK)
  CALL plist%add('MatrixType->nlocal',2_SIK)
  CALL plist%add('MatrixType->isSym',.FALSE.)
  CALL plist%add('MatrixType->matType',0_SIK)
  CALL plist%add('MatrixType->engine',VM_PETSC)
  CALL plist%add('MatrixType->MPI_COMM_ID',testEVS%MPIparallelEnv%comm)

  CALL DistributedMatrixFactory(A, plist)
  ASSERT(ASSOCIATED(A), "A matrix not ASSOCIATED")
  CALL DistributedMatrixFactory(B, plist)
  ASSERT(ASSOCIATED(B), "B matrix not ASSOCIATED")

  CALL B%set(1,1,0.1208_SRK)
  CALL B%set(2,1,-0.117_SRK)
  CALL B%set(2,2,0.184_SRK)
  CALL A%set(1,1,0.0015_SRK)
  CALL A%set(1,2,0.325_SRK)

  CALL testEVS%setMat(A,B)

  ASSERT(ASSOCIATED(testEVS%A),'%setMat A')
  ASSERT(ASSOCIATED(testEVS%B),'%setMat B')
  ASSERT(testEVS%A%isInit,'A%isInit')
  ASSERT(testEVS%B%isInit,'B%isInit')

ENDSUBROUTINE testSetMatSLEPc
!
!-------------------------------------------------------------------------------
SUBROUTINE testSolveSLEPc()
  REAL(SRK) :: kerr
  REAL(SRK) :: flux(2)

  CALL testEVS%solve()
  kerr=testEVS%k - (0.0015_SRK+0.117_SRK*0.325_SRK/0.184_SRK)/0.1208_SRK
  ASSERT(ABS(kerr)<=1.0E-8_SRK,'%solve k')
  FINFO() testEVS%k, kerr

  CALL testEVS%x%get(flux)
  ASSERT(ABS(flux(1)/flux(2)-0.184_SRK/0.117_SRK)<1.0E-8_SRK,'%solve flux')
  FINFO() flux

ENDSUBROUTINE testSolveSLEPc
!
!-------------------------------------------------------------------------------
SUBROUTINE testSetX0SLEPc()
#ifdef FUTILITY_HAVE_PETSC
  TYPE(PETScVectorType) :: x
  REAL(SRK) :: tmp(2)
  CALL plist%clear()
  CALL plist%add('VectorType->n',2_SIK)
  CALL plist%add('VectorType->nlocal',2_SIK)
  CALL plist%add('VectorType->MPI_COMM_ID',testEVS%MPIparallelEnv%comm)
  CALL x%init(plist)
  CALL x%set(1.5_SRK)
  CALL x%assemble()

  CALL testEVS%setX0(x)

  CALL testEVS%x%get(1,tmp(1))
  CALL testEVS%x%get(2,tmp(2))
  ASSERT(tmp(1)==1.5_SRK,'%x(1)')
  ASSERT(tmp(2)==1.5_SRK,'%x(2)')

  CALL x%clear()
#endif
ENDSUBROUTINE testSetX0SLEPc
!
!-------------------------------------------------------------------------------
SUBROUTINE testSetConvSLEPc()
  CALL testEVS%SetConv(1.0E-10_SRK,100)

  ASSERT(testEVS%tol==1.0E-10_SRK,'%tol')
  ASSERT(testEVS%maxit==100,'%maxit')

ENDSUBROUTINE testSetConvSLEPc
!
!-------------------------------------------------------------------------------
SUBROUTINE testGetResidSLEPc()
  INTEGER(SIK) :: it=0
  REAL(SRK) :: r=0.0_SRK

  CALL testEVS%getResidual(r,it)

  ASSERT(it>0,'iteration')
  ASSERT(ABS(r)<1.0E-10_SRK,'residual')

ENDSUBROUTINE testGetResidSLEPc
!
!-------------------------------------------------------------------------------
!
SUBROUTINE testInitAnasazi()
  CALL testEVS%init(mpiTestEnv,optList)
  ASSERT(testEVS%isInit,'%isInit')
  ASSERT(testEVS%n==30,'%n')
  ASSERT(testEVS%maxit==2,'%maxit')
  ASSERT(testEVS%tol==1.0E-8_SRK,'%tol')
  ASSERT(testEVS%SolverMethod==GD,'%SolverMethod')
  ASSERT(testEVS%TPLType==Anasazi,'%SolverMethod')
  ASSERT(ASSOCIATED(testEVS%MPIparallelEnv),'%MPIenv')
  ASSERT(testEVS%X%isInit ,'%x')
  SELECTTYPE(testEVS); TYPE IS(EigenvalueSolverType_Anasazi)
#ifdef FUTILITY_HAVE_Trilinos
    ASSERT(testEVS%x_scale%isInit,'%x_scale')
#endif
  ENDSELECT
ENDSUBROUTINE testInitAnasazi
!
!-------------------------------------------------------------------------------
SUBROUTINE testClearAnasazi()
  CALL testEVS%clear()
  ASSERT(testEVS%solverMethod==-1,'%solverMethod')
  ASSERT(testEVS%TPLType==-1,'%TPLType')
  ASSERT(.NOT. ASSOCIATED(testEVS%MPIparallelEnv),'%MPIenv')
  ASSERT(.NOT. testEVS%OMPparallelEnv%isInit(),'%OMPenv')
  ASSERT(testEVS%n==-1,'%n')
  ASSERT(testEVS%maxit==-1,'%maxit')
  ASSERT(testEVS%tol==0.0_SRK,'%tol')
  ASSERT(testEVS%k==0.0_SRK,'%k')
  ASSERT(.NOT. ASSOCIATED(testEVS%A),'%A')
  ASSERT(.NOT. ASSOCIATED(testEVS%B),'%B')
  ASSERT(.NOT. ASSOCIATED(testEVS%X) ,'%x')
  SELECTTYPE(testEVS); TYPE IS(EigenvalueSolverType_Anasazi)
#ifdef FUTILITY_HAVE_Trilinos
    ASSERT(.NOT. testEVS%x_scale%isInit,'%x_scale')
#endif
  ENDSELECT
ENDSUBROUTINE testClearAnasazi
!
!-------------------------------------------------------------------------------
SUBROUTINE testSetMatAnasazi()
  INTEGER(SIK) :: i
  CALL plist%clear()
  CALL plist%add('MatrixType->n',30_SIK)
  CALL plist%add('MatrixType->nlocal',30_SIK)
  CALL plist%add('MatrixType->isSym',.FALSE.)
  CALL plist%add('MatrixType->matType',0_SIK)
  CALL plist%add('MatrixType->engine',VM_TRILINOS)
  CALL plist%add('MatrixType->MPI_COMM_ID',testEVS%MPIparallelEnv%comm)

  CALL DistributedMatrixFactory(A,plist)
  CALL DistributedMatrixFactory(B,plist)

  CALL B%set(1,1,0.1208_SRK)
  CALL B%set(2,1,-0.117_SRK)
  CALL B%set(2,2,0.184_SRK)
  CALL A%set(1,1,0.0015_SRK)
  CALL A%set(1,2,0.325_SRK)
  !Adding rows 3-30 because minimum subspace is set to 25 and Anasazi doesn't
  ! like having a subspace bigger than problem size.  Adding diagonal entries
  ! into B but since A is all 0 for rows 3-30, there is no source so the flux
  ! is 0 thus having no impact on the solution
  DO i=3,30
    CALL B%set(i,i,0.1_SRK)
  ENDDO

  CALL testEVS%setMat(A,B)

  ASSERT(ASSOCIATED(testEVS%A),'%setMat A')
  ASSERT(ASSOCIATED(testEVS%B),'%setMat B')
  ASSERT(testEVS%A%isInit,'A%isInit')
  ASSERT(testEVS%B%isInit,'B%isInit')

ENDSUBROUTINE testSetMatAnasazi
!
!-------------------------------------------------------------------------------
SUBROUTINE testSolveAnasazi()
  INTEGER(SIK) :: i
  REAL(SRK) :: kerr
  REAL(SRK) :: flux(30)

  CALL testEVS%solve()
  kerr=testEVS%k - (0.0015_SRK+0.117_SRK*0.325_SRK/0.184_SRK)/0.1208_SRK
  ASSERT(ABS(kerr)<=1.0E-8_SRK,'%solve k')
  FINFO() testEVS%k, kerr

  DO i=1,30
    CALL testEVS%x%get(i,flux(i))
  ENDDO
  ASSERT(ABS(flux(1)/flux(2)-0.184_SRK/0.117_SRK)<1.0E-8_SRK,'%solve flux')
  FINFO() flux(1), flux(2)
  DO i=3,30
    ASSERT(ABS(flux(i))<=1.0E-10_SRK,'%solve flux')
    FINFO() i, flux(i)
  ENDDO

ENDSUBROUTINE testSolveAnasazi
!
!-------------------------------------------------------------------------------
SUBROUTINE testSetX0Anasazi()
#ifdef FUTILITY_HAVE_Trilinos
  TYPE(TrilinosVectorType) :: x
  REAL(SRK) :: tmp(30)
  INTEGER(SIK) :: i
  CALL plist%clear()
  CALL plist%add('VectorType->n',30_SIK)
  CALL plist%add('VectorType->nlocal',30_SIK)
  CALL plist%add('VectorType->MPI_COMM_ID',testEVS%MPIparallelEnv%comm)
  CALL x%init(plist)
  CALL x%set(1.5_SRK)
  CALL x%assemble()

  CALL testEVS%setX0(x)

  DO i=1,30
    CALL testEVS%x%get(i,tmp(i))
    ASSERT(tmp(i)==1.5_SRK,'%x(i)')
    FINFO() i,tmp(i)
  ENDDO

  CALL x%clear()
#endif
ENDSUBROUTINE testSetX0Anasazi
!
!-------------------------------------------------------------------------------
SUBROUTINE testSetConvAnasazi()
  CALL testEVS%SetConv(1.0E-10_SRK,100)

  ASSERT(testEVS%tol==1.0E-10_SRK,'%tol')
  ASSERT(testEVS%maxit==100,'%maxit')

ENDSUBROUTINE testSetConvAnasazi
!
!-------------------------------------------------------------------------------
SUBROUTINE testGetResidAnasazi()
  INTEGER(SIK) :: it=0
  REAL(SRK) :: r=0.0_SRK

  CALL testEVS%getResidual(r,it)

  ASSERT(it>0,'iteration')
  ASSERT(ABS(r)<1.0E-10_SRK,'residual')

ENDSUBROUTINE testGetResidAnasazi
!
!-------------------------------------------------------------------------------
!
ENDPROGRAM testEigenvalueSolver


      subroutine eigenft(npts,nfft,kspec,data,mxdata,dpss,
     $                   wsave,mxfreq,yk)
c
c  computes eigen-ft's by windowing real data with dpss and taking ffts
c  note that fft is unnormalized and window is such that
c  its sum of squares is one, so that psd=yk**2
c  the fft's are computed in pairs by placing adjacent dpss*data
c  in the real and imaginary parts of fft and sorting the result
c  using the symmetry properties of the fft
c
c  inputs:
c    npts  - number of data points in array data
c    nfft  - length of the fft
c    kspec - number of spectra to compute
c    data  - real array containing data series
c    mxdata- leading dimension of dpss
c    dpss  - double precision array containing kspec tapers
c            of length npts
c    wsave - real work vector of length at least 4*nfft+15
c    mxfreq- leading dimension of yk
c
c  outputs:
c    yk    - complex array containing kspec ffts of tapered data
c            of length nfft each
c
c  calls cffti,cfftf
c
c****************************************************************
c
      double precision dpss
      complex yk
      dimension data(npts),wsave(4*nfft+15),dpss(mxdata,kspec),
     $          yk(mxfreq,kspec)
c
      nfft2=nfft/2
      call cffti(nfft,wsave)
      do 40 j=1,kspec-1,2
        do 10 i=1,npts
   10     yk(i,j)=cmplx(dpss(i,j),dpss(i,j+1))*data(i)
        do 11 i=npts+1,nfft
   11     yk(i,j)=0.
        call cfftf(nfft,yk(1,j),wsave)
        yk(1,j+1)=cmplx(aimag(yk(1,j)),0.)
        yk(1,j)=cmplx(real(yk(1,j)),0.)
        do 20 i=2,nfft2+1
          yk(i,j+1)=cmplx(0.,-0.5)*(yk(i,j)-conjg(yk(nfft-i+2,j)))
   20     yk(i,j)=0.5*(yk(i,j)+conjg(yk(nfft-i+2,j)))
        do 30 i=nfft2+2,nfft
          yk(i,j)=conjg(yk(nfft-i+2,j))
   30     yk(i,j+1)=conjg(yk(nfft-i+2,j+1))
   40   continue
      if(mod(kspec,2).eq.0)return
c  get last fft if kspec is odd
      do 50 i=1,npts
   50   yk(i,kspec)=cmplx(dpss(i,kspec),0.d0)*data(i)
      do 51 i=npts+1,nfft
   51   yk(i,kspec)=0.
      call cfftf(nfft,yk(1,kspec),wsave)
      return
      end

c $Id$


subroutine mesh_dynamic(dtini_given, ppp,qqq, t0, t, tfin, saveInterval)

    use constants_module
    use arrays_module
    use matrix_module
    use var_module
    use arrays_section_module
    use xsec_attribute_module
    use sgate_module

    implicit none

    integer(kind=4), intent(in) :: ppp, qqq
    real(kind=4), intent(in) :: dtini_given, t0, t, tfin, saveInterval

    integer(kind=4) :: i, j, n, ntim, igate, pp, boundaryFileMaxEntry, noLatFlow, noQSKtable, saveFrequency
    real(kind=4) :: cour, da, dq, dxini, yy, x, thetas, thesinv
    real(kind=4) :: skk, qq, qn, xt, r_interpol, maxCourant, sfi, r_interpo_nn, frds
    real(kind=4) :: arean, areac, hyrdn, hyrdc, perimn, perimc, qcrit, s0ds, timesDepth, latFlowValue, q_sk_multi

    dtini = lastKnownDiffuDT

    !print*, 'in dynamic', dtini, dtini_given

		call correctDT(t0, t, saveInterval, tfin)
    !print*, 'Dynamic dtini', dtini
    !pause 5000
            ! Set upstream discharge
        dqp(1) = newQ(1) - oldQ(1)
        dap(1) = 0.0
        !print*, 'areas', area_norm, oldArea(1), newArea(1)

        !temp disabled!
        if (S_0 .gt. 0) then
            !print*, y_crit_us-z(1), y_norm_us-z(1)!; pause 5000
            if(y_crit_us .ge. y_norm_us) then ! Fr_us>1: supercritical flow
              if (frus2 .ge. 1.0) then
                print*, 'US boundary is supercritical'
                newY(1) = y_norm_us
                newArea(1) = area_norm
                dap(1)=area_norm -  oldArea(1)   !update from boundary condition time series
              endif
            endif
        endif
        !print*, y_norm_us, y_crit_us, dap(1)
        !pause 5000

        call section()
        ! Nazmul: The subroutine calls the attribute tables and interpolate according to the available water level
        thes=thetas

        call matrixp()

        do i=2,ncomp
            !cour=dt(i)/dx(i-1)
            cour=dtini/dx(i-1)
            !rhs1=-cour*(f1(i)-f1(i-1)-d1(i)+d1(i-1))+lateralFlow(i-1)*dtini !*dx(i)/dx(i-1)
            rhs1=-cour*(f1(i)-f1(i-1)-d1(i)+d1(i-1))+lateralFlow(i)*dtini !*dx(i)/dx(i-1)
            rhs2=-cour*(f2(i)-f2(i-1)-d2(i)+d2(i-1))+dtini*grav*(ci2(i)+aso(i))
            c11=g11inv(i)*b11(i-1)+g12inv(i)*b21(i-1)
            c12=g11inv(i)*b12(i-1)+g12inv(i)*b22(i-1)
            c21=g21inv(i)*b11(i-1)+g22inv(i)*b21(i-1)
            c22=g21inv(i)*b12(i-1)+g22inv(i)*b22(i-1)
            dap(i)=g11inv(i)*rhs1+g12inv(i)*rhs2-c11*dap(i-1)-c12*dqp(i-1)
            dqp(i)=g21inv(i)*rhs1+g22inv(i)*rhs2-c21*dap(i-1)-c22*dqp(i-1)
           ! print*,'rhs1=', rhs1, rhs2, c11, c12, c21, c22
        end do

!        if (option_dsbc.eq.1) then
!            dac(ncomp)=dap(ncomp)
!            yn=(area(ncomp)+dap(ncomp))/bo(ncomp)
!            arean=yn*bo(ncomp)
!            perimn=2.0*yn+bo(ncomp)
!            hyrdn=arean/perimn
!            s0ds=-((z(ncomp)-z(ncomp-1))/dx(ncomp))
!            qn=skk*arean*hyrdn**(2.0/3.0)*sqrt(s0ds)
!            dqp(ncomp)=qn-oldQ(ncomp)
!            dqc(ncomp)=dqp(ncomp)
!
!       elseif(option_dsbc.eq.2)then
!            dac(ncomp)=dap(ncomp)
!            yn=(area(ncomp)+dap(ncomp))/bo(ncomp)
!            areac=yn*bo(ncomp)
!            perimc=2.0*yn+bo(ncomp)
!            hyrdc=areac/perimc
!            s0ds=-((z(ncomp)-z(ncomp-1))/dx(ncomp))
!            qn=skk*areac*hyrdc**(2.0/3.0)*sqrt(s0ds)
!            qcrit=1.05*(((yn**3.0)*(bo(ncomp)**2.0)*grav)**(1.0/2.0))
!            write(*,*)qcrit
!            dqp(ncomp)=qcrit-oldQ(ncomp)
!            dqc(ncomp)=dqp(ncomp)

 !       else
            !dac(ncomp)=0.0
            !dap(ncomp)=0.0
            !dqc(ncomp)=dqp(ncomp)

!            dap(ncomp)=0.0	!checked email !for critical comment out
! change for unsteady flow
			!dap(ncomp) = newArea(ncomp) - oldArea(ncomp)
            !dac(ncomp)=dap(ncomp)	!checked email
            !dqc(ncomp)=dqp(ncomp)	!checked email
            !dac(ncomp)=newArea(ncomp) - oldArea(ncomp)
 !       endif

        !! New addition 20200624 start
        !Check Froud number at the downstream end

        frds=abs(oldQ(ncomp) + dqp(ncomp))/sqrt(grav*(newArea(ncomp))**3.0/bo(ncomp))   !!! applied q(n,ncomp)

       !frds=abs(q(n,ncomp) + dqp(ncomp))/sqrt(grav*ads**3.0/bo(ncomp))   !!! applied q(n,ncomp)

       if(frds .lt. 1.0) then
! Fr_ds <1: subcritical flow
!
          dap(ncomp)=newArea(ncomp) - oldArea(ncomp)    !update from downstream time series
          dac(ncomp)=dap(ncomp)
          dqc(ncomp)=dqp(ncomp)
       else
!
! Fr_ds>=1: supercritical
        print*, 'DS boundary is supercritical'
        print*, frds, newY(ncomp)-z(ncomp), oldQ(ncomp), dqp(ncomp), newArea(ncomp), bo(ncomp)!; pause 5000
         dac(ncomp)=dap(ncomp)
         dqc(ncomp)=dqp(ncomp)
       endif

!! New addition 20200624 end

        ! Update via predictor
        areap = area + dap
        qp = oldQ + dqp

        !do i=1,ncomp
        !    if (areap(i) .le. 0.) areap(i) = 0.01
        !end do

        ! applying lateral flow at the qp
        !do i=1,noLatFlow
        !    latFlowValue = r_interpol(lateralFlowTable(1, :, i),lateralFlowTable(2, :, i),dataInEachLatFlow(i),t)
        !    qp(latFlowLocations(i)) = qp(latFlowLocations(i)) + &
        !        latFlowValue*(dx(latFlowLocations(i)-1)+dx(latFlowLocations(i)))*0.5
        !    print*, 'lat flow=', latFlowValue, latFlowLocations(i), &
        !        latFlowValue*(dx(latFlowLocations(i)-1)+dx(latFlowLocations(i)))*0.5, &
        !        qp(latFlowLocations(i))
        !end do

        !print*, 'areap', (areap(i), i=1, ncomp)

        call secpred()
        thes=thesinv
        call matrixc()

        do i=ncomp-1,1,-1
            !cour=dt(i)/dx(i)
            cour=dtini/dx(i)
            !rhs1=-cour*(f1(i+1)-f1(i)-d1(i+1)+d1(i))+lateralFlow(i)*dtini
            rhs1=-cour*(f1(i+1)-f1(i)-d1(i+1)+d1(i))+lateralFlow(i+1)*dtini
            rhs2=-cour*(f2(i+1)-f2(i)-d2(i+1)+d2(i))+dt(i)*grav*(ci2(i)+aso(i))
            c11=g11inv(i)*b11(i+1)+g12inv(i)*b21(i+1)
            c12=g11inv(i)*b12(i+1)+g12inv(i)*b22(i+1)
            c21=g21inv(i)*b11(i+1)+g22inv(i)*b21(i+1)
            c22=g21inv(i)*b12(i+1)+g22inv(i)*b22(i+1)
            dac(i)=g11inv(i)*rhs1+g12inv(i)*rhs2-c11*dac(i+1)-c12*dqc(i+1)
            dqc(i)=g21inv(i)*rhs1+g22inv(i)*rhs2-c21*dac(i+1)-c22*dqc(i+1)
        end do
        ! Upstream boundary condition
        ! Prescribed discharge at the upstream
        ! Area correction is calculated

        if ( S_0 .gt. 0.) then
          if( y_crit_us .ge. y_norm_us ) then ! Steep slope
            frus2 = abs(newQ(1))/sqrt(grav*( dac(1)+areap(1) )**3.0/bo(1))
            !print*, 'frus2', frus2, newQ(1), oldArea(1), areap(1), dac(1), bo(1)
            !pause 5000
            if (frus2 .ge. 1) then   ! Fr_us>=1: supercritical flow
              dqc(1)=dqp(1)
              dac(1)=dap(1)
            else
              dqc(1)=dqp(1)	!checked email
              dap(1)=dac(1)	!checked email
            endif
          else
            dqc(1)=dqp(1)	!checked email
            dap(1)=dac(1)	!checked email
          endif
        else
          dqc(1)=dqp(1)	!checked email
          dap(1)=dac(1)	!checked email
        endif

        ! Final update
        do i=1,ncomp
            da=(dap(i)+dac(i))/2.0
            dq=(dqp(i)+dqc(i))/2.0
            newArea(i)=da+area(i)
            if(newArea(i) <= 0.0) newArea(i)=0.001

!           Now calculate y based on area calculated
!-------------------------------------
            elevTable(:) = xsec_tab(1,:,i)
            areaTable(:) = xsec_tab(2,:,i)

    !       interpolate the cross section attributes based on FINAL CALCULATED area
            xt=newArea(i)
            newY(i)=r_interpol(areaTable,elevTable,nel,xt)
!-------------------------------------

            newQ(i)=oldQ(i)+dq
            !froud(i)=abs(newQ(i))/sqrt(grav*newArea(i)**3.0/bo(i))

        end do
        !print*, newArea(1)
        !pause 5001

        do i=1,ncomp
            q_sk_multi = 1.0
            do pp = 1, size(Q_sk_tableEntry)
                if (  ( eachQSKtableNodeRange(1,pp) - i) * ( eachQSKtableNodeRange(2,pp) - i) .le. 0 ) then
                    q_sk_multi = r_interpo_nn(Q_Sk_Table(1,1:Q_sk_tableEntry(pp),pp),   &
                      Q_Sk_Table(2,1:Q_sk_tableEntry(pp),pp),Q_sk_tableEntry(pp),qp(i))
                end if
            end do

            sfi = ( newQ(i) / co(i) ) ** 2.0
            celerity2(i)=5.0 / 3.0 * sfi ** 0.3 * abs(newQ(i)) ** 0.4 / bo(i) ** 0.4 / (1/(sk(i)*q_sk_multi)) ** 0.6
        end do
        celerity =  sum(celerity2) / ncomp

end subroutine mesh_dynamic


!************************************************************************
		SUBROUTINE ZOOPLANKTON
!************************************************************************
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		REAL(8), PARAMETER :: pi= 3.14159265359d0
		REAL(8), PARAMETER :: alfa = 3.0d0, beta= 4.0d0
		INTEGER*4 i, j, k, nzoo
		PARAMETER (nzoo = 1)
		REAL(8) zoop(maxns,	nzoo)
		REAL(8) zoogrowth_rate(maxns,nzoo)
		REAL(8) grazing_algae (maxns, nzoo)
		REAL(8) pref_algae (nzoo, nchl)
		REAL(8) grazing_detrius (maxns, nzoo)
		REAL(8) pref_detrius (nzoo)
		REAL(8) grazing_max (nzoo)
		REAL(8)	half_sat_const (nzoo)
		REAL(8)	pref_zoo2algae (nzoo, nchl), pref_zoo2det (nzoo)
		REAL(8) temp_opt, temp_ref, kmax, temp_const
		REAL(8)	total_feed (maxns, nzoo)
		REAL(8)	phyto(maxns,nchl)
		REAL(8)	POC (maxns)
		REAL(8) pred1,pred2,sum_pref
		REAL(8) zoop_growth(maxns, nzoo), zoop_death(maxns,nzoo)
		REAL(8) mortality (nzoo), predation (maxns, nzoo)
		PARAMETER (pred1 = 0.15d0, pred2 = 40.0d0)

!gbs-------Zooplankton feeding------------------------------------
		DO i = 1,ns
			POC(i)=0.0d0
			DO k = 1,nchl
!gbs-------------Respiration and mortality------------------------
				POC(i) = POC(i)+death(i,k)
				PHYTO(i,k)= wqual(i,k)
			ENDDO	 !j

			DO j=1,nzoo
				zoogrowth_rate(i,j) = 1.0d0

				IF (zoop(i,j).le.0.00001d0) THEN
					zoop(i,j)=0.0001d0
				ELSE
					zoop(i,j)=zoop(i,j)
				ENDIF
			ENDDO
		ENDDO !i
!gbs---------------------------------------------------------------
!		IF(iclock.ge.sunrise.and.iclock+nosecs.le.sunset) THEN ! Day conditions
!			GOTO 1
!		ELSE
!			GOTO 99
!		ENDIF
    1 CONTINUE
!gbs-------------------------------------------------------------------
		DO j = 1, nzoo
			grazing_max (j) = 0.45d0      !per day
			half_sat_const (j) = 120.0d0
			pref_zoo2det (j)=0.01
			mortality(j) = 0.05
			DO k = 1, nchl
				pref_zoo2algae (j, k)=0.25
			ENDDO
		ENDDO

!		zoo = alfa*sin(pi*jday/180 + beta)
!     zoop = 0.01D0
!gbs	Growth of zooplankton---------------------------------------------
		DO i = 1,ns
!-------------Temperature multiplier---------------------------
			temp_opt=5.6d0   !

         IF(temp(i).le.temp_opt) THEN	   !!  temp(i)
				kmax =0.1*DEXP(-0.004*((temp(i)-temp_opt)**2.0))
			ELSEIF(temp(i).gt.temp_opt) THEN
				kmax =0.1*DEXP(-0.004*((temp_opt-temp(i))**2.0))			     !28 33
			ENDIF
			DO j = 1,nzoo
!--------------preference of zooplnkton to eat to diff phytoplankton---
            sum_pref=0.0d0
				total_feed(i,j)=0.0d0
            DO k=1,nchl
					sum_pref=pref_zoo2algae(j,k)*phyto(i,k)
				ENDDO
				DO k=1,nchl

					pref_algae (j,k)=pref_zoo2algae(j,k)*phyto(i,k)/		&
									(sum_pref+pref_zoo2det(j)*POC(i))
					total_feed(i,j)=sum_pref+pref_zoo2det(j)*POC(i)
				ENDDO
				pref_detrius (j)=pref_zoo2det(j)*POC(i)/						&
                        (sum_pref+pref_zoo2det(j)*POC(i))

!-------------- grazing rate determination ------------------------------

				grazing_algae (i,j)=0.0d0
				DO k=1,nchl
	   			grazing_algae (i,j)= grazing_max(j)*pref_algae (j,k)*phyto(i,k)/		&
                   (half_sat_const(j)+total_feed(i,j))
               grazing_detrius(i,j) = grazing_max(j)*pref_detrius (j)*death(i,k)/	&
                  (half_sat_const(j)+total_feed(i,j))
				ENDDO

!---------------- ZOOP Growth -------------------------------------------
				zoop_growth(i,j) = zoop(i,j)*zoogrowth_rate(i,j)*kmax*						&
                  (grazing_algae (i,j)+pref_detrius (j))
            zoop(i,j)=zoop(i,j)+zoop_growth(i,j)*(DFLOAT(nosecs)/86400.0)
!---------------- ZOOP Mortality ----------------------------------------------
            temp_ref=10.0
				temp_const=0.05
				zoop_death(i,j) = mortality(j)*DEXP(temp_const*(temp(i)-temp_ref))*zoop(i,j)
				zoop(i,j)=zoop(i,j)-zoop_death(i,j)*(DFLOAT(nosecs)/86400.0)

!---------------- ZOOP Predation ----------------------------------------------
!		  j=1 copepods and j = 2 cladocerans
      		IF (j.eq.1) THEN
					predation(i,j)=pred1*(zoop(i,j)**2.0)/(pred2+zoop(i,j))
				ELSEIF(j.eq.2) THEN
					predation(i,j)=pred1*(zoop(i,j)**3.0)/((pred2)**2.0+zoop(i,j)**2.0)
				ENDIF
				zoop(i,j)=zoop(i,j)-predation(i,j)*(DFLOAT(nosecs)/86400.0)
!-------------------------------------------------------------------
!	 IF(depth(i).ge.450.0.and.depth(i).le.460.0d0) THEN
!	 	 print*,zoop_death(i,j),zoop_growth(i,j),predation(i,j)
!	ENDIF
!--------------------------------------------------------------------
			ENDDO	  !j or zooplankton loop
		ENDDO  !i or number of layer loop
!gbs ---------------end of zooplankton growth, death and predation -------------
!gbs --------------- Balance of phytoplankton adn nutrients --------------------
		DO i = 1, ns
			DO j = 1, nchl
	!			wqual (i,3) = wqual (i,3)- grazing_algae (i,1)
	!  			death  (i,j) = death  (i,j) - grazing_detrius(i,1)
    !            print*,'gbszoo', i,j,death(i,j)
			ENDDO
		ENDDO
  99	CONTINUE
		RETURN
		END SUBROUTINE zooplankton


      subroutine spinoru(N,p,za,zb)
c---Calculate spinor products
c---extended to deal with negative energies ie with all momenta outgoing
c---Arbitrary conventions of Bern, Dixon, Kosower, Weinzierl,
c---za(i,j)*zb(j,i)=s(i,j)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      double precision p(mxpart,4),rt(mxpart)
      double complex c23(mxpart),f(mxpart)
      integer i,j,N

c---if one of the vectors happens to be zero this routine fails.
      do j=1,N
         za(j,j)=czip
         zb(j,j)=za(j,j)

C-----positive energy case
         if (p(j,4) .gt. 0d0) then
            rt(j)=dsqrt(p(j,4)+p(j,1))
            c23(j)=dcmplx(p(j,3),-p(j,2))
            f(j)=cone
         else
C-----negative energy case
            rt(j)=dsqrt(-p(j,4)-p(j,1))
            c23(j)=dcmplx(-p(j,3),p(j,2))
            f(j)=im
         endif
      enddo
      do i=2,N
         do j=1,i-1
         s(i,j)=two*(p(i,4)*p(j,4)-p(i,1)*p(j,1)
     &              -p(i,2)*p(j,2)-p(i,3)*p(j,3))
         za(i,j)=f(i)*f(j)
     &   *(c23(i)*dcmplx(rt(j)/rt(i))-c23(j)*dcmplx(rt(i)/rt(j)))

         if (abs(s(i,j)).lt.1d-5) then
         zb(i,j)=-(f(i)*f(j))**2*dconjg(za(i,j))
         else
         zb(i,j)=-dcmplx(s(i,j))/za(i,j)
         endif
         za(j,i)=-za(i,j)
         zb(j,i)=-zb(i,j)
         s(j,i)=s(i,j)
         enddo
      enddo

      return
      end


      subroutine crossp(p1,p2,p)
c**************************************************************************
c     input:
c            p1, p2    vectors to cross
c**************************************************************************
      implicit none
      real*8 p1(0:3), p2(0:3), p(0:3)

      p(0)=0d0
      p(1)=p1(2)*p2(3)-p1(3)*p2(2)
      p(2)=p1(3)*p2(1)-p1(1)*p2(3)
      p(3)=p1(1)*p2(2)-p1(2)*p2(1)

      return
      end

      subroutine rotate(p1,p2,n,nn2,ct,st,d)
c**************************************************************************
c     input:
c            p1        vector to be rotated
c            n         vector perpendicular to plane of rotation
c            nn2       squared norm of n to improve numerics
c            ct, st    cos/sin theta of rotation in plane
c            d         direction: 1 there / -1 back
c     output:
c            p2        p1 rotated using defined rotation
c**************************************************************************
      implicit none
      real*8 p1(0:3), p2(0:3), n(0:3), at(0:3), ap(0:3), cr(0:3)
      double precision nn2, ct, st, na, nn
      integer d, i

      if (nn2.eq.0d0) then
         do i=0,3
            p2(i)=p1(i)
         enddo
         return
      endif
      nn=dsqrt(nn2)
      na=(n(1)*p1(1)+n(2)*p1(2)+n(3)*p1(3))/nn2
      do i=1,3
         at(i)=n(i)*na
         ap(i)=p1(i)-at(i)
      enddo
c      write(*,*)'nn2 ',nn2,' ',nn,' ',na
c      write(*,*)'ap ',ap(1),',',ap(2),',',ap(3)
c      write(*,*)'at ',at(1),',',at(2),',',at(3)
      p2(0)=p1(0)
      call crossp(n,ap,cr)
c      write(*,*)'cr ',cr(1),',',cr(2),',',cr(3)
      do i=1,3
         if (d.ge.0) then
            p2(i)=at(i)+ct*ap(i)+st/nn*cr(i)
         else
            p2(i)=at(i)+ct*ap(i)-st/nn*cr(i)
         endif
      enddo

      return
      end

      subroutine constr(p1,p2,n,nn2,ct,st)
c**************************************************************************
c     input:
c            p1, p2    p1 rotated onto p2 defines plane of rotation
c     output:
c            n         vector perpendicular to plane of rotation
c            nn2       squared norm of n to improve numerics
c            ct, st    cos/sin theta of rotation in plane
c**************************************************************************
      implicit none
      real*8 p1(0:3), p2(0:3), n(0:3), tr(0:3)
      double precision nn2, ct, st, mct

      ct=p1(1)*p2(1)+p1(2)*p2(2)+p1(3)*p2(3)
      ct=ct/dsqrt(p1(1)**2+p1(2)**2+p1(3)**2)
      ct=ct/dsqrt(p2(1)**2+p2(2)**2+p2(3)**2)
      mct=ct
c     catch bad numerics
      if (mct-1d0>0d0) mct=0d0
      st=dsqrt(1d0-mct*mct)

      call crossp(p1,p2,n)
      nn2=n(1)**2+n(2)**2+n(3)**2
c     don't rotate if nothing to rotate
      if (nn2.le.1d-34) then
         nn2=0d0
         return
      endif

c     check rotation
c      call rotate(p1(0),tr(0),n(0),nn2,ct,st,1)
c      write(*,*)'p1 (',p1(0),',',p1(1),',',p1(2),',',p1(3),')'
c      write(*,*)'p2 (',p2(0),',',p2(1),',',p2(2),',',p2(3),')'
c      write(*,*)'nn (',n(0),',',n(1),',',n(2),',',n(3),')'
c      write(*,*)'nn (',n(0),',',n(1),',',n(2),',',n(3),')'
c      write(*,*)'nn2 = ',nn2,', ct = ',ct,', st = ',st
c      write(*,*)'tr (',tr(0),',',tr(1),',',tr(2),',',tr(3),')'

      return
      end

      Subroutine mapids(ids,id)
c**************************************************************************
c     input:
c            ids       array of particle ids
c            id        compressed particle id
c**************************************************************************
      implicit none
      include 'nexternal.inc'
      integer i, id, ids(nexternal)

      id=0
      do i=1,nexternal
         if (ids(i).ne.0) then
            id=id+ishft(1,i)
         endif
      enddo
c      write(*,*) 'cluster.f: compressed code is ',id

      return
      end

      subroutine mapid(id,ids)
c**************************************************************************
c     input:
c            id        compressed particle id
c            ids       array of particle ids
c**************************************************************************
      implicit none
      include 'nexternal.inc'
      integer i, icd, id, ids(nexternal)

      icd=id
      do i=1,nexternal
         ids(i)=0
         if (btest(id,i)) then
            ids(i)=1
         endif
c         write(*,*) 'cluster.f: uncompressed code ',i,' is ',ids(i)
      enddo

      return
      end

      integer function combid(i,j)
c**************************************************************************
c     input:
c            i,j       legs to combine
c     output:
c            index of combined leg
c**************************************************************************
      implicit none
      include 'nexternal.inc'
      integer i, j

c      combid=min(i+j,ishft(1,nexternal+1)-2-i-j)
      combid = i+j

      return
      end

      subroutine filprp(iproc,ignum,idij)
c**************************************************************************
c     Include graph ignum in list for propagator idij
c**************************************************************************
      implicit none
      include 'nexternal.inc'
      include 'maxamps.inc'
      include 'cluster.inc'
      include 'message.inc'
      integer ignum, idij, iproc, i

      if(idij.gt.n_max_cl) return
      do i=1,id_cl(iproc,idij,0)
         if (id_cl(iproc,idij,i).eq.ignum) return
      enddo
      id_cl(iproc,idij,0)=id_cl(iproc,idij,0)+1
      id_cl(iproc,idij,id_cl(iproc,idij,0))=ignum
      if(btest(mlevel,5))
     $     write(*,*)'Adding graph ',ignum,' to prop ',idij,' for proc ',iproc
      return
      end

      logical function filgrp(ignum,ipnum,ipids)
c**************************************************************************
c     input:
c            ignum      number of graph to be analysed
c            ipnum      number of level to be analysed,
c                       starting with nexternal
c            ipids      particle number, iforest number,
c                       daughter1, daughter2
c     output:
c            true if no errors
c**************************************************************************
      implicit none
      include 'genps.inc'
      include 'maxconfigs.inc'
      include 'nexternal.inc'
      include 'maxamps.inc'
      include 'cluster.inc'
      include 'coupl.inc'
      include 'message.inc'
      integer ignum, ipnum, ipids(nexternal,4,2:nexternal)
C $B$ IFOREST $B$ !this is a tag for MadWeight
      integer i, iforest(2,-max_branch:-1,lmaxconfigs)
      integer tstrategy(lmaxconfigs)
      common/to_forest/iforest, tstrategy
      integer sprop(maxsproc,-max_branch:-1,lmaxconfigs)
      integer tprid(-max_branch:-1,lmaxconfigs)
      common/to_sprop/sprop,tprid
C $E$ IFOREST $E$ !this is a tag for MadWeight
      INTEGER    n_max_cl_cg
      PARAMETER (n_max_cl_cg=n_max_cl*n_max_cg)
      data resmap/n_max_cl_cg*.false./

      Integer j, k, l, icmp(2), iproc

      double precision ZERO
      parameter (ZERO=0d0)
      double precision prmass(-nexternal:0,lmaxconfigs)
      double precision prwidth(-nexternal:0,lmaxconfigs)
      integer pow(-nexternal:0,lmaxconfigs)
      logical first_time
      save prmass,prwidth,pow
      INTEGER CONFSUB(MAXSPROC,LMAXCONFIGS)
      INCLUDE 'config_subproc_map.inc'
      data first_time /.true./

      integer combid
      logical isjet
      external combid,isjet

      if (first_time) then
         include 'props.inc'
         first_time=.false.
      endif

      if(btest(mlevel,4))
     $     write(*,*) 'graph,level: ',ignum,ipnum

      filgrp=.false.
C   Follow diagram tree down to last clustering
      do i=1,ipnum
         do j=i+1,ipnum
            if(btest(mlevel,4))
     $           write(*,*)'at ids   (',ipids(i,1,ipnum),',',ipids(i,2,ipnum),'), (',
     $           ipids(j,1,ipnum),',',ipids(j,2,ipnum),'), ',i,j
            do k=-nexternal+1,-1
               if ((iforest(1,k,ignum).eq.ipids(i,2,ipnum).and.
     &              iforest(2,k,ignum).eq.ipids(j,2,ipnum)).or.
     &             (iforest(2,k,ignum).eq.ipids(i,2,ipnum).and.
     &              iforest(1,k,ignum).eq.ipids(j,2,ipnum))) then
c                 Add the combined propagator
                  icmp(1)=combid(ipids(i,1,ipnum),ipids(j,1,ipnum))
c                 Add also the same propagator but from the other direction
                  icmp(2)=ishft(1,nexternal)-1-icmp(1)
c     Set pdg code for propagator
                  do l=1,2
                     do iproc=1,maxsproc
                     if(confsub(iproc,ignum).eq.0) cycle
                     if(sprop(iproc,k,ignum).ne.0)then
                        ipdgcl(icmp(l),ignum,iproc)=sprop(iproc,k,ignum)
                     else if(tprid(k,ignum).ne.0)then
                        ipdgcl(icmp(l),ignum,iproc)=tprid(k,ignum)
                     else if(ipnum.eq.3)then
                        ipdgcl(icmp(l),ignum,iproc)=ipdgcl(2,ignum,iproc)
                     else
                        ipdgcl(icmp(l),ignum,iproc)=0
                     endif
                     if(btest(mlevel,4))
     $                    write(*,*) 'add table entry for (',ipids(i,1,ipnum),
     &                    ',',ipids(j,1,ipnum),',',icmp(l),')',
     $                    'proc: ',iproc,
     $                    ', pdg: ',ipdgcl(icmp(l),ignum,iproc)
                     call filprp(iproc,ignum,icmp(l))
c               Insert graph in list of propagators
                     if(prwidth(k,ignum).gt.ZERO) then
                     if(btest(mlevel,4))
     $                       write(*,*)'Adding resonance ',ignum,icmp(l)
                        resmap(icmp(l),ignum)=.true.
                     endif
                  enddo
                  enddo
c     proceed w/ next table, since there is no possibility,
c     to combine the same particle in another way in this graph
                  ipids(i,1,ipnum-1)=icmp(1)
                  ipids(i,2,ipnum-1)=k
                  ipids(i,3,ipnum-1)=i
                  ipids(i,4,ipnum-1)=j
                  ipnum=ipnum-1
                  do l=1,j-1
                    if(l.eq.i) cycle
                    ipids(l,1,ipnum)=ipids(l,1,ipnum+1)
                    ipids(l,2,ipnum)=ipids(l,2,ipnum+1)
                    ipids(l,3,ipnum)=l
                    ipids(l,4,ipnum)=0
                  enddo
                  do l=j,ipnum
                     ipids(l,1,ipnum)=ipids(l+1,1,ipnum+1)
                     ipids(l,2,ipnum)=ipids(l+1,2,ipnum+1)
                     ipids(l,3,ipnum)=l+1
                     ipids(l,4,ipnum)=0
                  enddo
                  if(ipnum.eq.2)then
c                 Done with this diagram
                     return
                  else
                     filgrp=.true.
                     return
                  endif
               endif
            enddo
         enddo
      enddo
      return
      end

      logical function filmap()
c**************************************************************************
c     output:
c            true if no errors
c**************************************************************************
      implicit none
      include 'genps.inc'
      include 'maxconfigs.inc'
      include 'nexternal.inc'
      include 'maxamps.inc'
      include 'cluster.inc'
      include 'message.inc'
C $B$ IFOREST $B$ !this is a tag for MadWeight
      integer mapconfig(0:lmaxconfigs), this_config
      common/to_mconfigs/mapconfig, this_config
C $E$ IFOREST $E$ !this is a tag for MadWeight
      integer i, j, inpids, iproc, ipids(nexternal,4,2:nexternal)
      integer start_config,end_config
      integer idup(nexternal,maxproc,maxsproc)
      integer mothup(2,nexternal)
      integer icolup(2,nexternal,maxflow,maxsproc)
      include 'leshouche.inc'
      integer nqcd(lmaxconfigs)
      include 'config_nqcd.inc'

      logical filgrp
      external filgrp

      start_config=1
      end_config=mapconfig(0)
      do iproc=1,maxsproc
         do i=1,n_max_cl
            id_cl(iproc,i,0)=0
         enddo
      enddo
      do i=start_config,end_config
         if(nqcd(this_config).ne.nqcd(i)) then
            if(btest(mlevel,3))
     $           write(*,*) 'Skipping config ',i,' since nqcd: ',
     $           nqcd(this_config),nqcd(i)
            cycle
         endif
c         write (*,*) ' at graph ',i
         do j=1,nexternal
            ipids(j,1,nexternal)=ishft(1,j-1)
            ipids(j,2,nexternal)=j
            ipids(j,3,nexternal)=0
            ipids(j,4,nexternal)=0
            do iproc=1,maxsproc
               ipdgcl(ipids(j,1,nexternal),i,iproc)=idup(j,1,iproc)
            enddo
         enddo
         inpids=nexternal
         if(btest(mlevel,3))
     $        write(*,*) 'Inserting graph ',i
 10      if (filgrp(i,inpids,ipids)) goto 10
      enddo
      filmap=.true.
      return
      end

      subroutine checkbw(nbw,ibwlist,isbw)
c**************************************************************************
c      Checks if any resonances are on the BW for this configuration
c**************************************************************************
      implicit none
      include 'genps.inc'
      include 'maxconfigs.inc'
      include 'nexternal.inc'
C $B$ NGRAPHS $E$ !this is a tag for MadWeight

c     ibwlist has ijid, propid
      integer nbw,ibwlist(2,nexternal)
      logical isbw(*)

      logical             OnBW(-nexternal:0)     !Set if event is on B.W.
      common/to_BWEvents/ OnBW
      integer            mapconfig(0:lmaxconfigs), this_config
      common/to_mconfigs/mapconfig, this_config
C $B$ IFOREST $B$ !this is a tag for MadWeight
      integer i, iforest(2,-max_branch:-1,lmaxconfigs)
      integer tstrategy(lmaxconfigs)
      common/to_forest/iforest,	tstrategy
C $E$ IFOREST $E$ !this is a tag for MadWeight
C $B$ DECAYBW $E$ !this is a tag for MadWeight

      integer icl(-(nexternal-3):nexternal)

      nbw=0
      do i=1,nexternal
        icl(i)=ishft(1,i-1)
      enddo
      do i=-1,-(nexternal-3),-1
        icl(i)=icl(iforest(1,i,this_config))+
     $     icl(iforest(2,i,this_config))
        isbw(icl(i))=.false.
C $B$ ONBW $B$ !this is a tag for MadWeight
        if(OnBW(i))then
C $E$ ONBW $E$ !this is a tag for MadWeight
          nbw=nbw+1
          ibwlist(1,nbw)=icl(i)
          ibwlist(2,nbw)=i
          isbw(icl(i))=.true.
c          print *,'Added BW for resonance ',i,icl(i),this_config
        endif
      enddo

      end

      logical function findmt(idij,icgs)
c**************************************************************************
c     input:
c            idij, icgs
c     output:
c            true if tree structure identified
c**************************************************************************
      implicit none
      include 'nexternal.inc'
      include 'maxamps.inc'
      include 'cluster.inc'
      include 'message.inc'
      include 'genps.inc'
      include 'run.inc'
      include 'maxconfigs.inc'

      integer idij,icgs(0:n_max_cg)
      logical foundbw
      integer i, ii, j, jj, il, igsbk(0:n_max_cg)

c     IPROC has the present process number
      INTEGER IMIRROR,IPROC
      COMMON/TO_MIRROR/IMIRROR, IPROC
C     ICONFIG has this config number
      INTEGER MAPCONFIG(0:LMAXCONFIGS), ICONFIG
      COMMON/TO_MCONFIGS/MAPCONFIG, ICONFIG

      findmt=.false.
c     if first clustering, set possible graphs
      if (icgs(0).eq.0) then
         ii=0
         do i=1,id_cl(iproc,idij,0)
c        if chcluster, allow only this config
           if(chcluster)then
              if(id_cl(iproc,idij,i).ne.iconfig) cycle
           endif
c        check if we have constraint from onshell resonances
           foundbw=.true.
           do j=1,nbw
             if(resmap(ibwlist(1,j),id_cl(iproc,idij,i)))then
               cycle
             endif
             foundbw=.false.
 10        enddo
           if((nbw.eq.0.or.foundbw))then
              ii=ii+1
              icgs(ii)=id_cl(iproc,idij,i)
           endif
         enddo
         icgs(0)=ii
         if (icgs(0).gt.0)then
           findmt=.true.
         endif
         if (btest(mlevel,5))
     $        write (*,*)'findmt: ',findmt,' IPROC=',IPROC,' icgs(0)=',icgs(0),
     $        ' icgs = ',(icgs(i),i=1,icgs(0))
         return
      else
c     Check for common graphs
         j=1
         ii=0
         do i=1,icgs(0)
            if(j.le.id_cl(iproc,idij,0).and.icgs(i).eq.id_cl(iproc,idij,j))then
               ii=ii+1
               icgs(ii)=id_cl(iproc,idij,j)
               j=j+1
            else if(j.le.id_cl(iproc,idij,0).and.icgs(i).gt.id_cl(iproc,idij,j)) then
               do while(icgs(i).gt.id_cl(iproc,idij,j).and.j.le.id_cl(iproc,idij,0))
                  j=j+1
               enddo
               if(j.le.id_cl(iproc,idij,0).and.icgs(i).eq.id_cl(iproc,idij,j))then
                  ii=ii+1
                  icgs(ii)=id_cl(iproc,idij,j)
               endif
            endif
         enddo
         icgs(0)=ii
         findmt=(icgs(0).gt.0)
         return
      endif
      end

      logical function cluster(p)
c**************************************************************************
c     input:
c            p(0:3,i)           momentum of i'th parton
c     output:
c            true if tree structure identified
c**************************************************************************
      implicit none
      include 'genps.inc'
      include 'run.inc'
      include 'nexternal.inc'
      include 'maxamps.inc'
      include 'cluster.inc'
      include 'message.inc'
      include 'maxconfigs.inc'

      real*8 p(0:3,nexternal), pcmsp(0:3), p1(0:3)
      real*8 pi(0:3), nr(0:3), pz(0:3)
      integer i, j, k, n, idi, idj, idij, icgs(0:n_max_cg)
      integer nleft, iwin, jwin, iwinp, imap(nexternal,2)
      double precision nn2,ct,st
      double precision minpt2ij,pt2ij(n_max_cl),zij(n_max_cl)

      integer mapconfig(0:lmaxconfigs), this_config
      common/to_mconfigs/mapconfig, this_config

      data (pz(i),i=0,3)/1d0,0d0,0d0,1d0/

      integer combid
      logical findmt
      external findmt
      double precision dj, pydj, djb, pyjb, dot, SumDot, zclus
      external dj, pydj, djb, pyjb, dot, SumDot, zclus, combid
      integer next4
      parameter(next4=4*nexternal)
      data icluster/next4*0/

      if (btest(mlevel,1))
     $   write (*,*)'New event'

      cluster=.false.
      clustered=.false.
      do i=0,3
        pcmsp(i)=0
      enddo
c     Check if any resonances are on the BW, store results in to_checkbw
      call checkbw(nbw,ibwlist,isbw)
      if(btest(mlevel,4).and.nbw.gt.0)
     $     write(*,*) 'Found BWs: ',(ibwlist(1,i),i=1,nbw)

c     initialize index map
      do i=1,nexternal
         imap(i,1)=i
         imap(i,2)=ishft(1,i-1)
         mt2ij(i)=0
      enddo
      mt2last=0
      minpt2ij=1.0d37
      do i=1,nexternal
c     initialize momenta
         idi=ishft(1,i-1)
         do j=0,3
            pcl(j,idi)=p(j,i)
         enddo
c     give mass to external particles
         pcl(4,idi)=dot(p(0,i),p(0,i))
c     never combine the two beams
         if (i.gt.2) then
c     fill combine table, first pass, determine all ptij
            do j=1,i-1
               idj=ishft(1,j-1)
               if (btest(mlevel,4))
     $              write (*,*)'i = ',i,'(',idi,'), j = ',j,'(',idj,')'
c     cluster only combinable legs (acc. to diagrams)
               icgs(0)=0
               idij=combid(idi,idj)
               pt2ij(idij)=1.0d37
               if (findmt(idij,icgs)) then
                  if (btest(mlevel,4)) then
                     write(*,*)'diagrams: ',(icgs(k),k=1,icgs(0))
                  endif
                  if (j.ne.1.and.j.ne.2) then
c     final state clustering
                     if(isbw(idij))then
                       pt2ij(idij)=SumDot(pcl(0,idi),pcl(0,idj),1d0)
                       if (btest(mlevel,4))
     $                    write(*,*)'Mother ',idij,' has ptij ',
     $                    sqrt(pt2ij(idij))
                     else
                       if(ktscheme.eq.2)then
                         pt2ij(idij)=pydj(pcl(0,idi),pcl(0,idj))
                       else
                         pt2ij(idij)=dj(pcl(0,idi),pcl(0,idj))
                       endif
                     endif
                     zij(idij)=0d0
                  else
c     initial state clustering, only if hadronic collision
c     check whether 2->(n-1) process w/ cms energy > 0 remains
                     iwinp=imap(3-j,2);
                     if(ickkw.eq.2.or.ktscheme.eq.2)then
                        pt2ij(idij)=pyjb(pcl(0,idi),
     $                    pcl(0,idj),pcl(0,iwinp),zij(idij))
                        zij(idij)=0d0
                     else
                        pt2ij(idij)=djb(pcl(0,idi))
                        zij(idij)=zclus(pcl(0,idi),pcl(0,idj),pcl(0,iwinp))
                     endif
c     prefer clustering when outgoing in direction of incoming
                     if(sign(1d0,pcl(3,idi)).ne.sign(1d0,pcl(3,idj)))
     $                    pt2ij(idij)=pt2ij(idij)*(1d0+1d-6)
                  endif
                  if (btest(mlevel,4)) then
                     write(*,*)'         ',idi,'&',idj,' part ',iwinp,
     &                              ' -> ',idij,' pt2ij = ',pt2ij(idij)
                     if(j.eq.1.or.j.eq.2)then
                       write(*,*)'     cf. djb: ',djb(pcl(0,idi))
                     endif
                  endif
c     Check if smallest pt2 ("winner")
                  if (pt2ij(idij).lt.minpt2ij) then
                     iwin=j
                     jwin=i
                     minpt2ij=pt2ij(idij)
                  endif
               endif
            enddo
         endif
      enddo
c     Take care of special 2 -> 1 case
      if (nexternal.eq.3.and.nincoming.eq.2) then
         n=1
c     Make sure that initial-state particles are daughters
         idacl(n,1)=imap(1,2)
         idacl(n,2)=imap(2,2)
         imocl(n)=imap(3,2)
         pt2ijcl(n)=pcl(4,imocl(n))
         zcl(n)=0.
c        Set info for LH clustering output
         icluster(1,n)=1
         icluster(2,n)=3
         icluster(3,n)=2
         igraphs(0)=1
         igraphs(1)=this_config
         cluster=.true.
         clustered=.true.
         return
      endif
c     initialize graph storage
      igraphs(0)=0
      nleft=nexternal
c     cluster
      do n=1,nexternal-2
c     combine winner
         imocl(n)=imap(iwin,2)+imap(jwin,2)
         idacl(n,1)=imap(iwin,2)
         idacl(n,2)=imap(jwin,2)
         pt2ijcl(n)=minpt2ij
         zcl(n)=zij(imocl(n))
         if (btest(mlevel,2)) then
            write(*,*)'winner ',n,': ',idacl(n,1),'&',idacl(n,2),
     &           ' -> ',minpt2ij,', z = ',zcl(n)
         endif
c        Set info for LH clustering output
         icluster(1,n)=imap(iwin,1)
         icluster(2,n)=imap(jwin,1)
         icluster(3,n)=0
         icluster(4,n)=0
         if (isbw(imocl(n))) then
            do i=1,nbw
               if(ibwlist(1,i).eq.imocl(n))then
                  icluster(4,n)=ibwlist(2,i)
                  exit
               endif
            enddo
         endif
c     Reset igraphs with new mother
         if (.not.findmt(imocl(n),igraphs)) then
            write(*,*) 'cluster.f: Error. Invalid combination.'
            return
         endif
         if (btest(mlevel,4)) then
            write(*,*)'graphs: ',(igraphs(k),k=1,igraphs(0))
         endif
         if (iwin.lt.3) then
c     is clustering
c     Set mt2ij to m^2+pt^2
            mt2ij(n)=djb(pcl(0,idacl(n,2)))
            if (btest(mlevel,1)) then
               write(*,*)'mtij(',n,') for ',idacl(n,2),' is ',sqrt(mt2ij(n)),
     $              ' (cf ',sqrt(pt2ijcl(n)),')'
            endif
            iwinp=imap(3-iwin,2);
c        Set partner info for LH clustering output
            icluster(3,n)=imap(3-iwin,1)
            do i=0,3
               pcl(i,imocl(n))=pcl(i,idacl(n,1))-pcl(i,idacl(n,2))
c            enddo
c     set incoming particle on-shell
c            pcl(0,imocl(n))=sqrt(pcl(1,imocl(n))**2+
c     $         pcl(2,imocl(n))**2+pcl(3,imocl(n))**2)
c            do i=0,3
               pcmsp(i)=-pcl(i,imocl(n))-pcl(i,iwinp)
            enddo
            pcmsp(0)=-pcmsp(0)
            pcl(4,imocl(n))=0
            if(pcl(4,idacl(n,1)).gt.0.or.pcl(4,idacl(n,2)).gt.0.and..not.
     $         (pcl(4,idacl(n,1)).gt.0.and.pcl(4,idacl(n,2)).gt.0))
     $         pcl(4,imocl(n))=max(pcl(4,idacl(n,1)),pcl(4,idacl(n,2)))

c       Don't boost if boost vector too lightlike or last vertex
            if (pcmsp(0)**2-pcmsp(1)**2-pcmsp(2)**2-pcmsp(3)**2.gt.100d0.and.
     $           nleft.gt.4) then
               call boostx(pcl(0,imocl(n)),pcmsp(0),p1(0))
               call constr(p1(0),pz(0),nr(0),nn2,ct,st)
               do j=1,nleft
                  call boostx(pcl(0,imap(j,2)),pcmsp(0),p1(0))
                  call rotate(p1(0),pi(0),nr(0),nn2,ct,st,1)
                  do k=0,3
                     pcl(k,imap(j,2))=pi(k)
                  enddo
               enddo
               call boostx(pcl(0,imocl(n)),pcmsp(0),p1(0))
               call rotate(p1(0),pi(0),nr(0),nn2,ct,st,1)
               do k=0,3
                  pcl(k,imocl(n))=pi(k)
               enddo
            endif
         else
c     fs clustering
           do i=0,3
             pcl(i,imocl(n))=pcl(i,idacl(n,1))+pcl(i,idacl(n,2))
           enddo
           pcl(4,imocl(n))=0
           if(pcl(4,idacl(n,1)).gt.0.or.pcl(4,idacl(n,2)).gt.0.and..not.
     $        (pcl(4,idacl(n,1)).gt.0.and.pcl(4,idacl(n,2)).gt.0))
     $        pcl(4,imocl(n))=max(pcl(4,idacl(n,1)),pcl(4,idacl(n,2)))
           if(isbw(imocl(n)))then
             pcl(4,imocl(n))=pt2ijcl(n)
             if (btest(mlevel,4))
     $          write(*,*) 'Mother ',imocl(n),' has mass**2 ',
     $          pcl(4,imocl(n))
           endif
         endif

         nleft=nleft-1
c     create new imap
         imap(iwin,2)=imocl(n)
         do i=jwin,nleft
            imap(i,1)=imap(i+1,1)
            imap(i,2)=imap(i+1,2)
         enddo
         if (nleft.le.3) then
c           If last clustering is FS, store also average transverse mass
c           of the particles combined (for use if QCD vertex, e.g. tt~ or qq~)
            if(iwin.gt.2)then
               mt2last=sqrt(djb(pcl(0,idacl(n,1)))*djb(pcl(0,idacl(n,2))))
               if (btest(mlevel,3)) then
                  write(*,*)'Set mt2last to ',mt2last
               endif
c         Boost and rotate back to get m_T for final particle
               if (pcmsp(0)**2-pcmsp(1)**2-pcmsp(2)**2-pcmsp(3)**2.gt.100d0) then
                  call rotate(pcl(0,imap(3,2)),p1(0),nr(0),nn2,ct,st,-1)
                  do k=1,3
                     pcmsp(k)=-pcmsp(k)
                  enddo
                  call boostx(p1(0),pcmsp(0),pcl(0,imap(3,2)))
               endif
            endif
c         Make sure that initial-state particle is always among daughters
            idacl(n+1,1)=imap(1,2)
            idacl(n+1,2)=imap(2,2)
            imocl(n+1)=imap(3,2)
c            if(pcl(0,imocl(n)).gt.0d0)then
            pt2ijcl(n+1)=djb(pcl(0,imap(3,2)))
c        Set info for LH clustering output
            icluster(1,n+1)=1
            icluster(2,n+1)=3
            icluster(3,n+1)=2
            icluster(4,n+1)=0
            if (btest(mlevel,3)) then
              write(*,*) 'Last vertex is ',imap(1,2),imap(2,2),imap(3,2)
              write(*,*) '            -> ',pt2ijcl(n+1),sqrt(pt2ijcl(n+1))
            endif
c     If present channel among graphs, use only this channel
c     This is important when we have mixed QED-QCD
            do i=1,igraphs(0)
               if (igraphs(i).eq.this_config) then
                  igraphs(0)=1
                  igraphs(1)=this_config
                  exit
               endif
            enddo
c            if(pt2ijcl(n).gt. pt2ijcl(n+1))then
c              pt2ijcl(n+1)=pt2ijcl(n)
c              if (btest(mlevel,3)) then
c                write(*,*)'Reset scale for vertex ',n+1,' to ',pt2ijcl(n+1)
c              endif
c            endif
            zcl(n+1)=1
c            else
c              pt2ijcl(n+1)=pt2ijcl(n)
c            endif
c           Pick out the found graphs
c            print *,'Clustering succeeded, found graph ',igscl(1)
            cluster=.true.
            clustered=.true.
            return
         endif
c     calculate new ptij
c            write(*,*)'is case'
c     recalculate all in is case due to rotation & boost
         minpt2ij=1.0d37
            do i=1,nleft
               idi=imap(i,2)
c     never combine the two beams
               if (i.gt.2) then
c     determine all ptij
                  do j=1,i-1
                     idj=imap(j,2)
                     if (btest(mlevel,4))
     $                    write (*,*)'i = ',i,'(',idi,'), j = ',j,'(',idj,')'
c     Reset diagram list icgs
                     do k=0,igraphs(0)
                        icgs(k)=igraphs(k)
                     enddo
                     if (btest(mlevel,4))
     $                    write (*,*)'Reset diagrams to: ',(icgs(k),k=1,icgs(0))
c     cluster only combinable legs (acc. to diagrams)
                     idij=combid(idi,idj)
c                     write (*,*) 'RECALC !!! ',idij
                     pt2ij(idij)=1.0d37
                     if (findmt(idij,icgs)) then
                        if (btest(mlevel,4)) then
                           write(*,*)'diagrams: ',(icgs(k),k=1,icgs(0))
                       endif
                        if (j.ne.1.and.j.ne.2) then
c     final state clustering
                           if(isbw(idij))then
                             pt2ij(idij)=SumDot(pcl(0,idi),pcl(0,idj),1d0)
                             if (btest(mlevel,4))
     $                          write(*,*) 'Mother ',idij,' has ptij ',
     $                          sqrt(pt2ij(idij))
                           else
                             if(ktscheme.eq.2)then
                               pt2ij(idij)=pydj(pcl(0,idi),pcl(0,idj))
                             else
                               pt2ij(idij)=dj(pcl(0,idi),pcl(0,idj))
                             endif
                           endif
                           zij(idij)=0d0
                        else
c     initial state clustering, only if hadronic collision
c     check whether 2->(n-1) process w/ cms energy > 0 remains
                          iwinp=imap(3-j,2);
                          if(ickkw.eq.2.or.ktscheme.eq.2)then
                             pt2ij(idij)=pyjb(pcl(0,idi),
     $                            pcl(0,idj),pcl(0,iwinp),zij(idij))
                          else
                             pt2ij(idij)=djb(pcl(0,idi))
                             zij(idij)=zclus(pcl(0,idi),pcl(0,idj),pcl(0,iwinp))
                          endif
c                 prefer clustering when outgoing in direction of incoming
                          if(sign(1d0,pcl(3,idi)).ne.sign(1d0,pcl(3,idj)))
     $                         pt2ij(idij)=pt2ij(idij)*(1d0+1d-6)
                        endif
                        if (btest(mlevel,4)) then
                          write(*,*)'         ',idi,'&',idj,' part ',iwinp,' -> ',idij,
     &                       ' pt2ij = ',pt2ij(idij)
                           if(j.eq.1.or.j.eq.2)then
                             write(*,*)'     cf. djb: ',djb(pcl(0,idi))
                           endif
                        endif
                        if (pt2ij(idij).lt.minpt2ij) then
                           iwin=j
                           jwin=i
                           minpt2ij=pt2ij(idij)
                        endif
                     endif
                  enddo
               endif
            enddo
      enddo

      return
      end