      program tsp_to_insitu
      use MOM_EOS_Wright
      implicit none
c
c     usage:  echo pot.temp saln depth rho_0 | tsp_to_insitu
c
c     input:  temp saln depth rho_0
c     output: temp saln depth pressure rho_0 insitu_wright insitu_25t
c
c             temp      = potential temperature (degC)
c             saln      = Salinity (psu)
c             depth     = Depth    (m)
c             insitu_wright = in-situ density, Wright EOS
c             insitu_25t    = in-situ density, 25-term rational function EOS
c
c     alan j. wallcraft, naval research laboratory, august 2018.
c
      real*8  dens(4),saln,temp,depth,rho_0,pressure,prs_hycom
      integer ios,n,sigtyp,st_old
c
c------------------------------------------------------------------------
      include '../include/stmt_fns_SIGMA2_17term.h'
c------------------------------------------------------------------------
c
      st_old = -1
      do
        read(5,*,iostat=ios) temp,saln,depth,rho_0
        if     (ios.ne.0) then
          exit
        endif
        write(6,'(2a)') '#   p.temp      saln     depth  pressure',
     &                  '     rho_0 den_wrght   den_25t'
        pressure = 9.8 * rho_0 * depth
        call calculate_density_wright(temp,saln,pressure,dens(1))
        prs_hycom = 9806.0 * depth
        dens(2) = sigloc(temp,saln,prs_hycom) + 1000.0d0
        write(6,'(7f10.4)') temp,saln,depth,pressure*1.d-4,
     &                      rho_0,dens(1),dens(2)
      enddo
      end


! $Id: num_rec.f90,v 1.1 2008-07-24 17:31:45 dschanen Exp $
!   From _Numerical Recipes in Fortran 90_
!   (C) 1988-1996 Numerical Recipes Software
SUBROUTINE amebsa( p, y, pb, yb, f_tol, func, iter, temptr )
USE nrtype
USE nrutil, ONLY : assert_eq, imaxloc, iminloc, swap
USE nr, ONLY : ran1
IMPLICIT NONE

INTEGER(I4B), INTENT(INOUT) :: iter
REAL(SP), INTENT(INOUT)     :: yb
REAL(SP), INTENT(IN)        :: f_tol, temptr
REAL(SP), DIMENSION(:), INTENT(INOUT)   :: y, pb
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p

INTERFACE
  FUNCTION func(x)
  USE nrtype
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: x
  REAL(SP) :: func
  END FUNCTION func
END INTERFACE

INTEGER(I4B), PARAMETER :: NMAX=200
INTEGER(I4B) :: ihi,ndim
REAL(SP)     :: yhi
REAL(SP), DIMENSION(size(p,2)) :: psum
REAL(SP), PARAMETER     :: TINY  = 1.0e-10
call amebsa_private

CONTAINS
!BL
  SUBROUTINE amebsa_private
  INTEGER(I4B) :: i,ilo,inhi
  REAL(SP)     :: r_tol,ylo,ynhi,ysave,ytry
  REAL(SP), DIMENSION(size(y)) :: yt,harvest

  ndim    = assert_eq( size( p, 2 ), size( p, 1 )-1,       &
                       size( y )-1, size( pb ), 'amebsa' )
  psum(:) = sum( p(:,:), dim = 1 )

  do
    call ran1( harvest )
    yt(:)   = y(:) - temptr * log( harvest )
    ilo     = iminloc( yt(:) )
    ylo     = yt(ilo)
    ihi     = imaxloc( yt(:) )
    yhi     = yt(ihi)
    yt(ihi) = ylo
    inhi    = imaxloc( yt(:) )
    ynhi    = yt(inhi)
    r_tol    = 2.0_sp * abs( yhi - ylo ) / ( abs( yhi )+abs( ylo ) + TINY )
    if (r_tol < f_tol .or. iter < 0) then
      call swap( y(1), y(ilo) )
      call swap( p(1,:), p(ilo,:) )
      RETURN
    end if
    ytry = amotsa( -1.0_sp )
    iter = iter - 1
    if (ytry <= ylo) then
      ytry = amotsa( 2.0_sp )
      iter = iter - 1
    else if (ytry >= ynhi) then
      ysave = yhi
      ytry  = amotsa( 0.5_sp )
      iter  = iter - 1
      if (ytry >= ysave) then
        p(:,:) = 0.5_sp * ( p(:,:) + spread( p(ilo,:), 1, size(p,1) ) )
        do i=1,ndim+1
          if (i /= ilo) y(i) = func( p(i,:) )
        end do
        iter    = iter - ndim
        psum(:) = sum( p(:,:), dim=1 )
      end if
    end if
  end do
  END SUBROUTINE amebsa_private
!BL
  FUNCTION amotsa(fac)
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: fac
  REAL(SP) :: amotsa
  REAL(SP) :: fac1, fac2, yflu, ytry, harv
  REAL(SP), DIMENSION(size(p,2)) :: ptry
  fac1 = (1.0_sp - fac) / ndim
  fac2 = fac1 - fac
  ptry(:) = psum(:) * fac1 - p(ihi,:) * fac2
  ytry    = func( ptry )
  if (ytry <= yb) then
    pb(:) = ptry(:)
    yb    = ytry
  end if
  call ran1(harv)
  yflu = ytry + temptr*log( harv )
  if (yflu < yhi) then
    y(ihi)   = ytry
    yhi      = yflu
    psum(:)  = psum(:) - p(ihi,:) + ptry(:)
    p(ihi,:) = ptry(:)
  end if
  amotsa = yflu
  END FUNCTION amotsa

END SUBROUTINE amebsa


!!!!             Definition                !!!!
! target "!#" stands for chunk description    !
! target "!!" stands for block description    !
! target "! " stands for sentence description !
!           May God Bless Myself              !

!*******************************************************************************
subroutine calculate_temperature(theta,pressure,base_pressure,temperature,nz)
  use omp_lib
  implicit none
  real(kind=8), intent(in) :: theta(nz), pressure(nz), base_pressure(nz)
  real(kind=8), intent(inout) :: temperature(nz)
  integer, intent(in) :: nz
  integer :: i
  !$OMP DO
    do i=1,nz,1
      temperature(i)=(theta(i)+290)/((1000.0/((pressure(i)+base_pressure(i))/100))**(287.04/1003))
    enddo
  !$OMP END DO
end subroutine calculate_temperature
!*******************************************************************************

!*******************************************************************************
subroutine read_netcdf_3D(file_name,var_name,nx,ny,nz,data_)
  use omp_lib
  use netcdf
  implicit none
  character(len=100), intent(in) :: var_name,file_name
  real(kind=8), intent(inout) :: data_(nx*ny*nz)
  real(kind=8), allocatable, dimension(:,:,:,:) :: trans
  integer, intent(in) :: nx,ny,nz
  integer :: status_, i, j, k, count_, var_id, file_id
  status_=nf90_open(trim(file_name),nf90_nowrite,file_id)
  allocate(trans(nx,ny,nz,1))
  status_=nf90_inq_varid(file_id, trim(var_name), var_id)
  status_=nf90_get_var(file_id, var_id, trans, (/1,1,1,1/), (/nx,ny,nz,1/))
  status_=nf90_close(file_id)
  count_=1
  !$OMP DO
    do i=1,nx,1
      do j=1,ny,1
        !do k=1,nz,1
        data_(count_:count_+nz-1)=trans(i,j,:,1)
        count_=count_+nz
        !enddo
      enddo
    enddo
  !$OMP END DO
  deallocate(trans)
end subroutine read_netcdf_3D
!*******************************************************************************

!*******************************************************************************
subroutine read_netcdf_2D(file_name,var_name,nx,ny,data_)
  use omp_lib
  use netcdf
  implicit none
  character(len=100), intent(in) :: var_name,file_name
  real(kind=8), intent(inout) :: data_(nx*ny)
  real(kind=8), allocatable, dimension(:,:,:) :: trans
  integer, intent(in) :: nx,ny
  integer :: status_, i, j, count_, var_id, file_id
  status_=nf90_open(trim(file_name),nf90_nowrite,file_id)
  allocate(trans(nx,ny,1))
  status_=nf90_inq_varid(file_id, trim(var_name), var_id)
  status_=nf90_get_var(file_id, var_id, trans, (/1,1,1/), (/nx,ny,1/))
  status_=nf90_close(file_id)
  count_=1
  !$OMP DO
    do i=1,nx,1
      do j=1,ny,1
        data_(count_)=trans(i,j,1)
        count_=count_+1
      enddo
    enddo
  !$OMP END DO
  deallocate(trans)
end subroutine read_netcdf_2D
!*******************************************************************************

!*******************************************************************************
!*******************************************************************************
program test_mpi_scatter_bcast
  use mpi
  use netcdf
  use crtm_module

  implicit none
  !! define variables !!
  character (len=100) :: file_name, output_name
  integer :: local_mpi_err_flag, local_mpi_rank, local_mpi_size
  integer :: read_status, file_id, nz, ny, nx, nsoil, var_id
  integer :: i, j, k, count_, singular_size_to_add, normal_size, i_sendcounts, process_i
  real(kind=8) :: ptop
  real(kind=8), allocatable, dimension(:) :: lai, u10, v10, seaice, snowh, &
                                              vegfra, ivegtyp, xland, &
                                              xlat, xlong, coszen, &
                                              smois, stemp, tsk
  real(kind=8), allocatable, dimension(:) :: process_lai, process_u10, process_v10, &
                                              process_seaice, process_snowh, &
                                              process_vegfra, process_ivegtyp, &
                                              process_xland, process_xlat, process_xlong, &
                                              process_coszen, process_smois, process_stemp, &
                                              process_tsk
  real(kind=8), allocatable, dimension(:) :: theta, pressure, base_pressure, &
                                              qvapor, qcloud, qrain, qice, &
                                              qsnow, temperature, tbb_1d
  real(kind=8), allocatable, dimension(:) :: process_theta,process_pressure,true_pressure,&
                                              process_base_pressure,process_temperature,&
                                              process_qvapor,process_qcloud,process_qrain,&
                                              process_qice,process_qsnow,process_qgraupel,&
                                              process_qhail,process_tbb,&
                                              eff_rad_cloud,eff_rad_rain,eff_rad_ice,&
                                              eff_rad_snow,eff_rad_graupel,eff_rad_hail
  real(kind=8), allocatable, dimension(:,:) :: tbb_2d
  !! start mpi !!
  call MPI_INIT(local_mpi_err_flag)
  call MPI_COMM_RANK(MPI_COMM_WORLD,local_mpi_rank,local_mpi_err_flag)
  call MPI_COMM_SIZE(MPI_COMM_WORLD,local_mpi_size,local_mpi_err_flag)

  if (local_mpi_rank == 0) then
    !# acquire file name from namelist#!
    open(155,FILE="./namelist.crtm",FORM="FORMATTED",STATUS="OLD")
    read(155,*) file_name,output_name
    write(*,*) file_name,output_name
    !# reading netcdf variables in a serial mod #!
    ! open netcdf file in reading mod !
    read_status=nf90_open(trim(file_name),nf90_nowrite,file_id)
    ! get netcdf dimensions !
    read_status=nf90_inq_dimid(file_id,"south_north",var_id)
    read_status=nf90_inquire_dimension(file_id,var_id,len=ny)
    read_status=nf90_inq_dimid(file_id,"west_east",var_id)
    read_status=nf90_inquire_dimension(file_id,var_id,len=nx)
    read_status=nf90_inq_dimid(file_id,"bottom_top",var_id)
    read_status=nf90_inquire_dimension(file_id,var_id,len=nz)
    read_status=nf90_inq_dimid(file_id,"soil_layers_stag",var_id)
    read_status=nf90_inquire_dimension(file_id,var_id,len=nsoil)
    read_status=nf90_close(file_id)
    ! get the 3D data !
    allocate(theta(nx*ny*nz))
    call read_netcdf_3D(file_name,"T",nx,ny,nz,theta)
    allocate(pressure(nx*ny*nz))
    call read_netcdf_3D(file_name,"P",nx,ny,nz,pressure)
    allocate(base_pressure(nx*ny*nz))
    call read_netcdf_3D(file_name,"PB",nx,ny,nz,base_pressure)
    allocate(qvapor(nx*ny*nz))
    call read_netcdf_3D(file_name,"QVAPOR",nx,ny,nz,qvapor)
    allocate(qcloud(nx*ny*nz))
    call read_netcdf_3D(file_name,"QCLOUD",nx,ny,nz,qcloud)
    allocate(qrain(nx*ny*nz))
    call read_netcdf_3D(file_name,"QRAIN",nx,ny,nz,qrain)
    allocate(qice(nx*ny*nz))
    call read_netcdf_3D(file_name,"QICE",nx,ny,nz,qice)
    allocate(qsnow(nx*ny*nz))
    call read_netcdf_3D(file_name,"QSNOW",nx,ny,nz,qsnow)
    allocate(temperature(nx*ny*nz))
    ! get the 2D data !
    allocate(lai(nx*ny))
    call read_netcdf_2D(file_name,"LAI",nx,ny,lai)
    allocate(vegfra(nx*ny))
    call read_netcdf_2D(file_name,"VEGFRA",nx,ny,vegfra)
    allocate(ivegtyp(nx*ny))
    call read_netcdf_2D(file_name,"TSK",nx,ny,ivegtyp)
    allocate(u10(nx*ny))
    call read_netcdf_2D(file_name,"U10",nx,ny,u10)
    allocate(v10(nx*ny))
    call read_netcdf_2D(file_name,"V10",nx,ny,v10)
    allocate(seaice(nx*ny))
    call read_netcdf_2D(file_name,"SEAICE",nx,ny,seaice)
    allocate(snowh(nx*ny))
    call read_netcdf_2D(file_name,"SNOWH",nx,ny,snowh)
    allocate(tsk(nx*ny))
    call read_netcdf_2D(file_name,"TSK",nx,ny,tsk)
    allocate(smois(nx*ny*nsoil))
    call read_netcdf_3D(file_name,"SMOIS",nx,ny,nsoil,smois)
    allocate(stemp(nx*ny*nsoil))
    call read_netcdf_3D(file_name,"TSLB",nx,ny,nsoil,stemp)
    allocate(xland(nx*ny))
    call read_netcdf_2D(file_name,"XLAND",nx,ny,xland)
    allocate(xlat(nx*ny))
    call read_netcdf_2D(file_name,"XLAT",nx,ny,xlat)
    allocate(xlong(nx*ny))
    call read_netcdf_2D(file_name,"XLONG",nx,ny,xlong)
    allocate(coszen(nx*ny))
    call read_netcdf_2D(file_name,"COSZEN",nx,ny,coszen)
    allocate(tbb_1d(nx*ny))
    ! get ptop !
    ptop=5000.0
    write(*,*) "SUCCESS reading WRFOUT"
    ! get scatter size !
    i_sendcounts=((nx*ny)/local_mpi_size)*nz
    call MPI_Bcast(i_sendcounts,1,MPI_INTEGER,0,MPI_COMM_WORLD,local_mpi_err_flag)
    call MPI_Bcast(nz,1,MPI_INTEGER,0,MPI_COMM_WORLD,local_mpi_err_flag)
    call MPI_Bcast(nsoil,1,MPI_INTEGER,0,MPI_COMM_WORLD,local_mpi_err_flag)
    call MPI_Bcast(ptop,1,MPI_REAL8,0,MPI_COMM_WORLD,local_mpi_err_flag)
    write(*,*) "SUCCESS Broardcast Const on Processor ",local_mpi_rank
  else
    call MPI_Bcast(i_sendcounts,1,MPI_INTEGER,0,MPI_COMM_WORLD,local_mpi_err_flag)
    call MPI_Bcast(nz,1,MPI_INTEGER,0,MPI_COMM_WORLD,local_mpi_err_flag)
    call MPI_Bcast(nsoil,1,MPI_INTEGER,0,MPI_COMM_WORLD,local_mpi_err_flag)
    call MPI_Bcast(ptop,1,MPI_REAL8,0,MPI_COMM_WORLD,local_mpi_err_flag)
    write(*,*) "SUCCESS Broardcast Const on Processor ",local_mpi_rank
  endif
  ! scatter data gonna trasnmiting !
  allocate(process_theta(i_sendcounts))
  allocate(process_pressure(i_sendcounts))
  allocate(process_base_pressure(i_sendcounts))
  allocate(true_pressure(i_sendcounts))
  allocate(process_qvapor(i_sendcounts))
  allocate(process_qcloud(i_sendcounts))
  allocate(process_qrain(i_sendcounts))
  allocate(process_qice(i_sendcounts))
  allocate(process_qsnow(i_sendcounts))
  allocate(process_qgraupel(i_sendcounts))
  allocate(process_qhail(i_sendcounts))
  allocate(process_tbb(i_sendcounts))
  call MPI_Scatter(theta,i_sendcounts,MPI_REAL8,&
                    process_theta,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(pressure,i_sendcounts,MPI_REAL8,&
                    process_pressure,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(base_pressure,i_sendcounts,MPI_REAL8,&
                    process_base_pressure,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(qvapor,i_sendcounts,MPI_REAL8,&
                    process_qvapor,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(qcloud,i_sendcounts,MPI_REAL8,&
                    process_qcloud,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(qrain,i_sendcounts,MPI_REAL8,&
                    process_qrain,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(qice,i_sendcounts,MPI_REAL8,&
                    process_qice,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(qsnow,i_sendcounts,MPI_REAL8,&
                    process_qsnow,i_sendcounts,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  allocate(process_lai(i_sendcounts/nz))
  allocate(process_vegfra(i_sendcounts/nz))
  allocate(process_ivegtyp(i_sendcounts/nz))
  allocate(process_u10(i_sendcounts/nz))
  allocate(process_v10(i_sendcounts/nz))
  allocate(process_seaice(i_sendcounts/nz))
  allocate(process_snowh(i_sendcounts/nz))
  allocate(process_tsk(i_sendcounts/nz))
  allocate(process_smois((i_sendcounts/nz)*nsoil))
  allocate(process_stemp((i_sendcounts/nz)*nsoil))
  allocate(process_xland(i_sendcounts/nz))
  allocate(process_xlat(i_sendcounts/nz))
  allocate(process_xlong(i_sendcounts/nz))
  allocate(process_coszen(i_sendcounts/nz))
  call MPI_Scatter(lai,i_sendcounts/nz,MPI_REAL8,&
                    process_lai,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(vegfra,i_sendcounts/nz,MPI_REAL8,&
                    process_vegfra,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(ivegtyp,i_sendcounts/nz,MPI_REAL8,&
                    process_ivegtyp,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(u10,i_sendcounts/nz,MPI_REAL8,&
                    process_u10,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(v10,i_sendcounts/nz,MPI_REAL8,&
                    process_v10,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(seaice,i_sendcounts/nz,MPI_REAL8,&
                    process_seaice,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(snowh,i_sendcounts/nz,MPI_REAL8,&
                    process_snowh,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(tsk,i_sendcounts/nz,MPI_REAL8,&
                    process_tsk,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(smois,(i_sendcounts/nz)*nsoil,MPI_REAL8,&
                    process_smois,(i_sendcounts/nz)*nsoil,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(stemp,(i_sendcounts/nz)*nsoil,MPI_REAL8,&
                    process_stemp,(i_sendcounts/nz)*nsoil,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(xland,i_sendcounts/nz,MPI_REAL8,&
                    process_xland,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(xlat,i_sendcounts/nz,MPI_REAL8,&
                    process_xlat,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(xlong,i_sendcounts/nz,MPI_REAL8,&
                    process_xlong,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Scatter(coszen,i_sendcounts/nz,MPI_REAL8,&
                    process_coszen,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  write(*,*) "SUCCESS Scatter Array on Processor ",local_mpi_rank
  ! start calcluate pressure !
  do process_i=1,i_sendcounts,1
    true_pressure(process_i)=process_pressure(process_i)+process_base_pressure(process_i)
    process_theta(process_i)=process_theta(process_i)+290.0
  enddo
  write(*,*) "SUCCESS Calculate Pressure on Processor ",local_mpi_rank

  do process_i=1,i_sendcounts/nz,1
  !do process_i=1,10,1
     ! nlevels,theta, qvapor, pressure, &
     ! qcloud, qsnow, qgraupel, qice, qrain, &
     ! qhail, lai, u10, v10, seaice, &
     ! snowh, vegfrac, tsk, ivegtyp, smois, stemp, &
     ! xland, lat, lon, ptop, coszen, channel, tbb
     !write(*,*) process_theta((process_i-1)*nz+1:process_i*nz)
     !write(*,*) process_qvapor((process_i-1)*nz+1:process_i*nz)
     !write(*,*) true_pressure((process_i-1)*nz+1:process_i*nz)
     !write(*,*) process_qcloud((process_i-1)*nz+1:process_i*nz)
     !write(*,*) process_qsnow((process_i-1)*nz+1:process_i*nz)
     !write(*,*) process_qgraupel((process_i-1)*nz+1:process_i*nz)
     !write(*,*) process_qice((process_i-1)*nz+1:process_i*nz)
     !write(*,*) process_qrain((process_i-1)*nz+1:process_i*nz)
     !write(*,*) process_qhail((process_i-1)*nz+1:process_i*nz)
     call calculate_tbb(nz,&
                          process_theta((process_i-1)*nz+1:process_i*nz),&
                          process_qvapor((process_i-1)*nz+1:process_i*nz),&
                          true_pressure((process_i-1)*nz+1:process_i*nz), &
                          process_qcloud((process_i-1)*nz+1:process_i*nz),&
                          process_qsnow((process_i-1)*nz+1:process_i*nz),&
                          process_qgraupel((process_i-1)*nz+1:process_i*nz),&
                          process_qice((process_i-1)*nz+1:process_i*nz),&
                          process_qrain((process_i-1)*nz+1:process_i*nz),&
                          process_qhail((process_i-1)*nz+1:process_i*nz),&
                          process_lai(process_i),&
                          process_u10(process_i),&
                          process_v10(process_i),&
                          process_seaice(process_i),&
                          process_snowh(process_i),&
                          process_vegfra(process_i),&
                          process_tsk(process_i),&
                          process_ivegtyp(process_i),&
                          process_smois((process_i-1)*nsoil+1),&
                          process_stemp((process_i-1)*nsoil+1),&
                          process_xland(process_i),&
                          process_xlat(process_i),&
                          process_xlong(process_i),&
                          ptop,&
                          process_coszen(process_i),&
                          4,&
                          process_tbb(process_i))
  enddo
  call MPI_Barrier(MPI_COMM_WORLD,local_mpi_err_flag)
  call MPI_Gather(process_tbb,i_sendcounts/nz,MPI_REAL8,&
                    tbb_1d,i_sendcounts/nz,MPI_REAL8,&
                    0,MPI_COMM_WORLD,local_mpi_err_flag)
  if (local_mpi_rank == 0) then
    allocate(tbb_2d(nx,ny))
    count_=1
    do i=1,nx,1
      do j=1,ny,1
        tbb_2d(i,j)=tbb_1d(count_)
        count_=count_+1
      enddo
    enddo
    write(*,*) count_,nx,ny
    open(156,file=trim(output_name),form="unformatted")
    write(156) tbb_2d
    close(156)
  endif
  !! end mpi !!
  call MPI_FINALIZE(local_mpi_err_flag)
end program
!*******************************************************************************
!*******************************************************************************


module cj_det_module

  use amrex_fort_module, only : rt => amrex_real

  use eos_type_module
  use eos_module

  implicit none

contains

  subroutine adiabat(eos_state_fuel, eos_state_ash, q, istatus)

    implicit none

    type(eos_t), intent(in) :: eos_state_fuel
    type(eos_t), intent(inout) :: eos_state_ash
    real(rt), intent(in) :: q
    integer, intent(out) :: istatus

    real(rt), parameter :: tol = 1.e-8_rt
    logical :: converged
    real(rt) :: f, dfdT, dT
    integer :: iter
    integer, parameter :: max_iter = 50

    ! we want to zero e_1 + q - e_2 + 0.5*(p_1 + p_2)*(v_1 - v_2)
    ! where v = 1/rho

    ! we have a rho_2 (the ash input), so we need to find the T that
    ! makes this all work

    ! we assume that we come in with a reasonable guess for T

    converged = .false.

    iter = 0
    do while (.not. converged .and. iter < max_iter)
       call eos(eos_input_rt, eos_state_ash)

       f = eos_state_fuel % e + q - eos_state_ash % e + &
            0.5_rt * (eos_state_fuel % p + eos_state_ash % p) * &
            (1.0_rt/eos_state_fuel % rho - 1.0_rt/eos_state_ash % rho)

       dfdT = -eos_state_ash % dedT + 0.5_rt * eos_state_ash % dpdT * &
            (1.0_rt/eos_state_fuel % rho - 1.0_rt/eos_state_ash % rho)

       dT = -f/dfdT

       if (abs(dT) < tol * eos_state_ash % T) then
          converged = .true.
       endif

       eos_state_ash % T = eos_state_ash % T + dT

       iter = iter + 1

    enddo

    if (.not. converged) then
       istatus = -1
    else
       istatus = 0
    endif

  end subroutine adiabat

  subroutine cj_cond(eos_state_fuel, eos_state_ash, q)

    implicit none

    type(eos_t), intent(in) :: eos_state_fuel
    type(eos_t), intent(inout) :: eos_state_ash
    real(rt), intent(in) :: q

    real(rt), parameter :: tol = 1.e-8_rt
    logical :: converged
    real(rt) :: rho_old, drho
    integer :: iter, istatus
    integer, parameter :: max_iter = 50

    ! iterate, picking the density that corresponds to the CJ point
    call eos(eos_input_rt, eos_state_ash)

    drho = 1.e30_rt

    ! this is the density we find from the tangent point to the
    ! Hugoniot curve
    eos_state_ash % rho = eos_state_fuel % rho * &
         (1.0_rt + (eos_state_ash % p - eos_state_fuel % p) / &
                      (eos_state_ash % gam1 * eos_state_ash % p))

    iter = 0
    converged = .false.
    do while (.not. converged .and. iter < max_iter)

       rho_old = eos_state_ash % rho

       call adiabat(eos_state_fuel, eos_state_ash, q, istatus)

       ! this is the density we find from the tangent point to the
       ! Hugoniot curve
       eos_state_ash % rho = eos_state_fuel % rho * &
            (1.0_rt + (eos_state_ash % p - eos_state_fuel % p) / &
                         (eos_state_ash % gam1 * eos_state_ash % p))

       drho = eos_state_ash % rho - rho_old

       if (abs(drho) < tol * eos_state_ash % rho) then
          converged = .true.
       endif

       iter = iter + 1
    enddo

    if (.not. converged .or. istatus == -1) then
       call amrex_error("CJ did not converge")
    endif

  end subroutine cj_cond

end module cj_det_module


      subroutine class_b(x,p1,p2,r1)
c***************************************************************************
c
c             *  p2 (visible)
c            *
c     *******
c       r1   *
c             *  p1 (missing)
c
c***************************************************************************

c***************************************************************************
      implicit none
      include '../../../SubProcesses/phasespace.inc'
c
c     arguments
c
      integer p1,p2,r1
c
c     local
c
      double precision x(20)
      INTEGER IDUM
      DATA IDUM/0/
      SAVE IDUM
      double precision pboost(0:3), CMS_mom(0:3,max_particles)
      double precision Ptot(0:3),PtotCMS(0:3)
      double precision measureLAB, measureCMS
      double precision jac_loc
      double precision p1z_ti,p1z_E1,jac_factor,dem
      double precision b,c,rho,sqrts
      double precision sol(2),trialpz(2)
      double precision x1s1,x2s1,x1s2,x2s2
      integer index_sol,i,j,k,MG
      real rand
c
c     global
c
      double precision momenta(0:3,-max_branches:2*max_particles)  ! records the momenta of external/intermediate legs     (MG order)
      double precision mvir2(-max_branches:2*max_particles)        ! records the sq invariant masses of intermediate particles (MG order)
      common /to_diagram_kin/ momenta, mvir2
      double precision Etot,pztot,misspx,misspy
      common /to_missingP/Etot,pztot,misspx,misspy
      double precision              S,X1,X2,PSWGT,JAC
      common /PHASESPACE/ S,X1,X2,PSWGT,JAC
      integer matching_type_part(3:max_particles)
      integer inv_matching_type_part(3:max_particles)
      common/madgraph_order_type/matching_type_part,
     & inv_matching_type_part
      integer nexternal, num_inv
      COMMON/to_num_inv/nexternal, num_inv
      integer ISR_mode
      common /to_correct_ISR/ISR_mode

      REAL XRAN1
      EXTERNAL XRAN1
c--------
c Begin code
c--------
      IDUM=0
      sqrts=dsqrt(s)
      if((Etot+dsqrt(misspx**2+misspy**2)).gt.sqrts) then
      jac=-1d0
      return
      endif

c      write(*,*) "mom p2", (momenta(i,p2),i=0,3)
c      write(*,*) "mvir2",r1, mvir2(r1)
c      write(*,*) "mvir2",p1, mvir2(p1)
c      write(*,*) "mvir2",p2, mvir2(p2)
c      write(*,*) "misspx",misspx
c      write(*,*) "misspy",misspy
c      write(*,*) "Etot",Etot
c      write(*,*) "Pztot",Pztot

c     fill p1x, p1y
c
      momenta(1,p1)=misspx
      momenta(2,p1)=misspy
      momenta(0,p1)=-1d0

c
c     p1z=p1z_ti+p1z_E1*E1
c
      p1z_ti=(mvir2(p1)+mvir2(p2)-mvir2(r1)
     & -2d0*momenta(1,p1)*momenta(1,p2)-2d0*momenta(2,p1)*momenta(2,p2))
     & /(2d0*momenta(3,p2))
      p1z_E1=momenta(0,p2)/momenta(3,p2)
c
c     the mass-shell equation reads (1-p1z_ti^2)*E1^2 -2 p1z_ti*p1z_E1*E1-p1z_ti**2-p1x^2-p1y^2 -m1^2
c

      jac_factor=1d0
      index_sol=1
      dem=1d0-p1z_E1**2

      if (dabs(dem).lt.0.0001d0) then
        momenta(0,p1)=-(P1z_ti**2+misspx**2+misspy**2+mvir2(p1))/
     &  (2d0*P1z_ti*P1z_E1)

        if  (momenta(0,p1).le.0d0) then
          jac_loc=-1d0
          jac=-1d0
          return
        endif
      else
        b=-2d0*P1z_ti*P1z_E1/dem
        c=-(P1z_ti**2+misspx**2+misspy**2+mvir2(p1))/dem
        rho=b**2-4d0*c

        if (rho.eq.0d0.and.b.lt.0d0) then   ! max 1 sol
          momenta(0,p1)=-b/2d0
        elseif (rho.gt.b**2)then ! max 1 sol
          momenta(0,p1)=(-b+dsqrt(rho))/2d0
        elseif (rho.gt.0d0.and.dsqrt(rho).lt.(-b)) then   ! max 2 sol
          sol(1)=(-b+dsqrt(rho))/2d0
          sol(2)=(-b-dsqrt(rho))/2d0
          trialpz(1)=p1z_ti+p1z_E1*sol(1)
          trialpz(2)=p1z_ti+p1z_E1*sol(2)
          x1s1=((Etot+sol(1))+(pztot+trialpz(1)))/sqrts
          x2s1=((Etot+sol(1))-(pztot+trialpz(1)))/sqrts
          x1s2=((Etot+sol(2))+(pztot+trialpz(2)))/sqrts
          x2s2=((Etot+sol(2))-(pztot+trialpz(2)))/sqrts

c          write(*,*) 'E 1',sol(1)
c          write(*,*) 'E 2',sol(2)

c          write(*,*) 'x1,x2',x1s1,x2s1
c          write(*,*) 'x1,x2',x1s2,x2s2

      if(dabs(x1s1-0.5d0).lt.0.5d0.and.dabs(x2s1-0.5d0).lt.0.5d0.and. ! analyse bjk fractions
     & dabs(x1s2-0.5d0).lt.0.5d0.and.dabs(x2s2-0.5d0).lt.0.5d0) then

            index_sol=1
c            call ntuple(rand,0.0,1.0,p1)
            rand=xran1(IDUM)
            if (rand.gt.0.5) index_sol=2
c            if (rand.gt.0.5) then
c              jac=-1d0
c              jac_loc=-1d0
c            endif
            momenta(0,p1)=sol(index_sol)
            jac_factor=2d0

      elseif(dabs(x1s1-0.5d0).gt.0.5d0.or.dabs(x2s1-0.5d0).gt.0.5d0)then
      if (dabs(x1s2-0.5d0).lt.0.5d0.and.dabs(x2s2-0.5d0).lt.0.5d0) then
              momenta(0,p1)=sol(2)
          else
            jac_loc=-1d0
            jac=-1d0
            return
          endif

      elseif(dabs(x1s2-0.5d0).gt.0.5d0.or.dabs(x2s2-0.5d0).gt.0.5d0)then
      if (dabs(x1s1-0.5d0).lt.0.5d0.and.dabs(x2s1-0.5d0).lt.0.5d0) then
              momenta(0,p1)=sol(1)
          else
            jac_loc=-1d0
            jac=-1d0
            return
          endif
      endif
        else
        jac_loc=-1d0
        jac=-1d0
        return
      endif
      endif

c      if (index_sol.eq.1) then
c        jac_loc=-1d0
c        jac=-1d0
c        return
c      endif

      momenta(3,p1)=p1z_ti+p1z_E1*momenta(0,p1)
c      write(*,*) 'momenta(3,p1)',momenta(3,p1)
      x1=((Etot+momenta(0,p1))+(pztot+momenta(3,p1)))/sqrts
      x2=((Etot+momenta(0,p1))-(pztot+momenta(3,p1)))/sqrts
      if (dabs(x1-0.5d0).gt.0.5d0.or.dabs(x2-0.5d0).gt.0.5d0) then
        jac_loc=-1d0
        jac=-1d0
        return
      endif

c     fill intermediate momenta
      momenta(0,r1)=momenta(0,p1)+momenta(0,p2)
      momenta(1,r1)=momenta(1,p1)+momenta(1,p2)
      momenta(2,r1)=momenta(2,p1)+momenta(2,p2)
      momenta(3,r1)=momenta(3,p1)+momenta(3,p2)
      misspx=0d0
      misspy=0d0
c
c     jacobian factors
c
c     p1x,p1y,p1z,E1 -> misspx, misspy, m12^2, E1^2
c
      jac_loc=1d0/(4d0*dabs(momenta(3,p2)*momenta(0,p1)
     & -momenta(3,p1)*momenta(0,p2)))
c
c     x1,x2 > Etot,pztot
c
      jac_loc=jac_factor*jac_loc*2d0/s

c
c     Apply the boost correction
c

c     First evaluated the total momentum in the LAB frame
      do j=0,3
      Ptot(j)=0d0
        do k=3,nexternal
          Ptot(j)=Ptot(j)+momenta(j,k)
        enddo
      pboost(j)=Ptot(j)
      enddo

c     Then calculate the momenta in the CMS frame
      pboost(1)=-pboost(1)
      pboost(2)=-pboost(2)
      pboost(3)=0d0
       do j=3,nexternal
c         write(*,*) "p",j,momenta(0,j), momenta(1,j),momenta(2,j),momenta(3,j)
         call boostx(momenta(0,j),pboost,CMS_mom(0,j))
       enddo
       call boostx(Ptot,pboost,PtotCMS)

c     Evaluate the initial momenta in the CMS frame
      x1=(PtotCMS(0)+Ptot(3))/sqrts
      x2=(PtotCMS(0)-Ptot(3))/sqrts

      if (dabs(x1-0.5).gt.0.5d0.or.dabs(x2-0.5).gt.0.5d0) then
        jac=-1d0
c        write(*,*) "Warning: x1 or x2 larger than 1"
        momenta(0,1)=-1
        momenta(0,2)=-1
        return
      endif

      CMS_mom(0,1)=sqrts*x1/2d0
      CMS_mom(1,1)=0d0
      CMS_mom(2,1)=0d0
      CMS_mom(3,1)=sqrts*x1/2d0
      CMS_mom(0,2)=sqrts*x2/2d0
      CMS_mom(1,2)=0d0
      CMS_mom(2,2)=0d0
      CMS_mom(3,2)=-sqrts*x2/2d0

c     Evaluate the initial momenta in the LAB frame
      pboost(1)=Ptot(1)
      pboost(2)=Ptot(2)
      call boostx(CMS_mom(0,1),pboost,momenta(0,1))
      call boostx(CMS_mom(0,2),pboost,momenta(0,2))

c     correction from the measure to translate the weight to the CM frame
c     ONLY if isr = 2

      if (isr_mode.eq.2) then
      measureLAB=1d0
       do j=3,nexternal-num_inv
         MG=inv_matching_type_part(j)
         measureLAB=measureLAB*dsqrt(momenta(1,MG)**2+momenta(2,MG)**2)
       enddo

      measureCMS=1d0
       do j=3,nexternal-num_inv
         MG=inv_matching_type_part(j)
         measureCMS=measureCMS*dsqrt(CMS_mom(1,MG)**2+CMS_mom(2,MG)**2)
       enddo
      jac=jac*measureCMS/measureLAB

      endif
c
c     flux
c
      jac_loc=jac_loc/(2d0*x1*x2*s)
      jac=jac*jac_loc
c      write(*,*) 'jac_factor', jac_factor

      return
      end


      subroutine gelam(aphi,delam,dpelm,elam,fxi,izmax,nazpmx,
     $ pelm,qpit75)
c
c     This subroutine calculates the E-lambda function (elam(i,j)) and
c     its first two ionic strength derivatives (delam(1,i,j) and
c     delam(2,i,j)). Here i, j refers to the charge pair zi, zj or
c     -zi, -zj, where zi and zj are both positive. The E-lambda
c     function and its derivatives are used in Pitzer's equations
c     to represent higher-order electrical interactions. Here izmax
c     is the max norm of the electrical charges of the aqueous species
c     and aphi is the Debye-Huckel A(phi) parameter. The array
c     pelm(i,j) contains a set of "primitive" E-lambda functions
c     corresponding to those in elam(i,j). The arrays dpelm(1,i,j)
c     and dpelm(2,i,j) similarly parallel delam(1,i,j) and delam(2,i,j).
c
c     This subroutine is called by:
c
c       EQLIBG/gcoeff.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       aphi   = the Debye-Huckel A(phi) parameter
c       izmax  = the max norm of the electrical charge numbers of
c                  the aqueous species
c       fxi    = the ionic strength (the 2nd-order electrostatic
c                  moment function I)
c
c     Principal output:
c
c       elam   = array of values of the E-lambda functions
c       delam  = array of values of the ionic strength derivatives
c                  of the E-lambda functions
c
c     Work space:
c
c       pelm   = array of values of primitive E-lambda functions
c       dpelm  = array of values of the ionic strength derivatives
c                  of the primitive E-lambda functions
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nazpmx
c
      integer izmax
c
      logical qpit75
c
      real*8 delam(2,nazpmx,nazpmx),dpelm(2,nazpmx,nazpmx),
     $ elam(nazpmx,nazpmx),pelm(nazpmx,nazpmx)
      real*8 aphi,fxi
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,ijz,iz,jz
c
      real*8 el,elp,elpp,wi,wj
c
c-----------------------------------------------------------------------
c
c     First calculate "primitive" E-lambdas (pelm) and their
c     derivatives (dpelm) for the various charge pairs. These depend
c     only on the product of the electrical charges.
c
      do jz = 1,izmax
        do iz = jz,izmax
          ijz = iz*jz
c
c         Get the primitive E-lambda and its derivatives for
c         this current charge pair.
c
          call elmdd(aphi,el,elp,elpp,fxi,ijz,qpit75)
          pelm(iz,jz) = el
          dpelm(1,iz,jz) = elp
          dpelm(2,iz,jz) = elpp
          if (jz .ne. iz) then
            pelm(jz,iz) = el
            dpelm(1,jz,iz) = elp
            dpelm(2,jz,iz) = elpp
          endif
        enddo
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Now calculate conventional E-lambdas (elam) and their derivatives
c     (delam) for the various charge pairs.
c
      do jz = 1,izmax
        do iz = 1,izmax
          wj = 0.5*iz/jz
          wi = 0.5*jz/iz
          elam(iz,jz) = pelm(iz,jz) - wj*pelm(jz,jz) - wi*pelm(iz,iz)
          delam(1,iz,jz) = dpelm(1,iz,jz) - wj*dpelm(1,jz,jz)
     $    - wi*dpelm(1,iz,iz)
          delam(2,iz,jz) = dpelm(2,iz,jz) - wj*dpelm(2,jz,jz)
     $    - wi*dpelm(2,iz,iz)
        enddo
      enddo
c
c     Set the diagonal elements to zero.
c
      do i = 1,izmax
        elam(i,i) = 0.
        delam(1,i,i) = 0.
        delam(2,i,i) = 0.
      enddo
c
      end


      subroutine qlxpicheck(xpi)
      implicit none
      double precision xpi(13),y13,y24
      logical qlzero
C     Uses the ordering for the routine xpi wanted by FF
C     psq(1) lies between msq(1) and msq(2) and so on
C     xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
C     xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
C     xpi(9-10) = s12,s23
C     xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
C     xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
C     xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
c      y13=abs(m1+m3s-s12)
c      y24=abs(m2+m4s-s23)
      y13=xpi(1)+xpi(3)-xpi(9)
      y24=xpi(2)+xpi(4)-xpi(10)
      if (qlzero(y13) .or. qlzero(y24)) then
      write(6,*) 'Modified Cayley elements y13 or y24=0',y13,y24
      stop
      endif
      end


      double complex function A0phiggggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
C----Expresssion of Eq. (2.14) of hep-ph/0804.4149v3
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4
      A0phiggggmpmp=za(j1,j3)**4
     .             /(za(j1,j2)*za(j2,j3)*za(j3,j4)*za(j4,j1))
      return
      end


! File VersionID:
!   $Id: boundtop.for 176 2010-03-13 11:36:14Z kroes006 $
! ----------------------------------------------------------------------
      subroutine boundtop
! ----------------------------------------------------------------------
!     date               : august 2004 / sept 2005
!     purpose            : determine soil profile top boundary condition
! ----------------------------------------------------------------------
      use variables
      implicit none

! --- local variables

      real*8  emax,ks,theatm,ksurf
      real*8  watcon,hconduc

! ----------------------------------------------------------------------
! --- local variables
      real*8  h0,hcomean,hconode_vsmall,k1Atm,p1,p2,p2Mp,q1,RsRoMp

      data    hconode_vsmall  /1.0d-10/  ! Hydraulic conductivity for complete frozen soils

! ----------------------------------------------------------------------
! --- Initialisation

! --- runon of present day
      if (flDayStart .and. flrunon) runon = runonarr(daycum+1)

      FlRunoff = .false.
      QMpLatSs = 0.0d0

!     S O I L   E V A P O R A T I O N

! --- Calculate hydraulic conductivity corresponding with hAtm
      if (hAtm.lt.0.0d0) Then
         TheAtm = watcon(1,dble(hatm),cofgen(1,1),swsophy,numtab,sptab)
         ksurf  = hconduc (1,TheAtm,cofgen(1,1),swfrost,rfcp(1),
     &                     swsophy,numtab,sptab)
         if(SwMacro.eq.1) then
            ksurf = FrArMtrx(1) * ksurf
         endif
      else

! --- This only occurs if RH is 100% in SWAPS, never used for SWAP
         kSurf = k(1)
      endif
      k1Atm = hcomean(swkmean,kSurf,k(1),dz(1),dz(1))

! --- maximum evaporation rate according to Darcy
      Emax = -k1Atm * ((hatm-h(1))/disnod(1)+1.0d0)

! --- determine reduced soil evaporation rate
      if (swredu .eq. 0) then
        reva = min(peva,max(0.0d0,Emax))
      else
        reva = min(empreva,max(0.0d0,Emax))
      endif

!     H I G H   A T M O S P H E R I C   D E M A N D
!     flux through ground surface based on precipitation - evaporation
!     and remaining ponding of previous timestep
      q0 = (nraidt+nird+melt)*(1.0d0-ArMpSs) + runon - reva
      q1 = - q0 - pondm1/dt

!     check whether the atmospheric demand condition applies
      if (q1 .ge. 0.0d0 .and. q1.gt.Emax) then
         ftoph    = .true.
         hsurf    = hAtm
         kmean(1) = k1Atm
         pond     = 0.0d0
         runots   = 0.0d0
         return
      endif

!     maximum conductivity assuming saturation at ground surface (z=0)
      if(flksatexm)then
         ks = rfcp(1)*ksatexm(1) + (1.0d0-rfcp(1))*hconode_vsmall
      else
         ks = rfcp(1)*ksatfit(1) + (1.0d0-rfcp(1))*hconode_vsmall
      endif
      k1max = hcomean(swkmean,ks,k(1),dz(1),dz(1))
!     check whether application of flux=q1 will yield a pressure head >0
!     at ground surface. If not: flux boundary condition is valid
      h0    = h(1) - disnod(1)*(q1/k1max+1.0d0)
      if (h0.le.1.0d-6) then
         ftoph    = .false.
         kmean(1) = 0.0d0
         hsurf    = 0.0d0
         pond     = 0.0d0
         runots   = 0.0d0
         qtop     = q1
      else                 ! ponding occurs
         ftoph    = .true.
         kmean(1) = k1max
         FlRunoff = .true. ! runoff potential possible

! --- calculate max value of pond without runoff
         p1     = k1max/disnod(1) * dt
         p2     = 1.0d0/(p1+1.0d0)
         h0max  = p2 * ( pondm1 + q0*dt - k1max*dt + p1*h(1) )

! --- in case of macropores, calc. potential overland flow into macrop.: QMpLatSs
         if (SwMacro.eq.1) then
            if (h0max.gt.PndmxMp) then
               RsRoMp  = (h0max + (nraidt+nird+melt)*ArMpSs*dt) / KsMpSs
               p2Mp    = 1.0d0 / (p1 + 1.0d0 + dt/RsRoMp)
               pond    = (h0max - PndmxMp) * p2Mp/p2
               QMpLatSs= pond * dt/RsRoMp
               QMpLatSs= dmin1(QMpLatSs,h0max)
               if (QMpLatSs.lt.1.0d-7) QMpLatSs = 0.0d0
            else
               QMpLatSs = 0.0d0
            endif
         endif
      endif
!
      return
      end

! ----------------------------------------------------------------------
      SUBROUTINE PONDRUNOFF (swdra,swmacro,FlRunoff,disnod,dt,h,H0max,
     &              k1max,pondm1,pondmx,q0,rsro,rsroexp,sttab,wls,swst,
     &              QMpLatSs,hsurf,pond,runots,swpondmx,pondmxtab,t1900)
! ----------------------------------------------------------------------
!     Date               : 4/5/2005
!     Purpose            : determines ponding height and calculates runoff
!     Formal parameters  :
!     Subroutines called : -
!     Functions called   : runoff
!     File usage         : -
! ----------------------------------------------------------------------
      IMPLICIT NONE
      Include 'arrays.fi'

! --- global                                                       In
      integer swdra,swmacro,swpondmx
      real*8  disnod(macp+1),dt,h(macp),pondm1,pondmx,rsro,rsroexp
      real*8  sttab(22,2),wls,swst
      real*8  h0max,k1max,q0                 ! from subroutine BOCOTOP
      real*8  QMpLatSs                       ! from subroutine MACRORATE
      real*8  pondmxtab(2*mairg),t1900
      logical FlRunoff
!                                                                  Out
      real*8  hsurf,pond,runots

! ----------------------------------------------------------------------
! --- local variables
      INTEGER i
      real*8  h0,h0min,p1,p2,runoff,afgen

! ----------------------------------------------------------------------

! --  in case of time dependent ponding: determine pondmx
      if (swpondmx.eq.1) then
         pondmx = afgen (pondmxtab,2*mairg,t1900+dt)
      endif

! --- in case of Macropores:
      if (swmacro.eq.1) then
         if (FlRunoff) then
!   - h0max is reduced with overland flow into Macropores
            q0     = q0 - QMpLatSs/dt
            p1     = k1max/disnod(1) * dt
            p2     = 1.0d0/(p1+1.0d0)
            h0max  = p2 * ( pondm1 + q0*dt - k1max*dt + p1*h(1) )
         else
!   - inflow excess by direct precipitation into macropores is added to ponding
            pond= - QMpLatSs
            return
         endif
      endif
!
! --- check whether h0max, the max value of pond, yields a runoff

!      if(swdra.ne.2 .and. h0max.le.pondmx)then

      if(h0max.le.pondmx)then
         runots   = 0.0d0
         pond     = h0max
         hsurf    = pond
         return
      end if

      runots = runoff(swdra,h0max,pondmx,rsro,rsroexp,wls,swst,sttab,dt)
      if(dabs(runots).lt.1.0d-6)then
!        if no runoff occurs: first estimation of pond is OK
         pond     = h0max
         hsurf    = pond
         return
      else if(dabs(runots).ge.1.0d-6 .and. swdra.ne.2 .and.
     &                                dabs(rsroexp-1.0d0).lt.1.0d-6)then
         p1 = k1max/disnod(1) * dt
         p2 = 1.0d0 / (p1 + 1.0d0 + dt/rsro)

         pond     = p2 * ( pondm1 + q0*dt - k1max*dt + p1*h(1) +
     &                     dt/rsro * pondmx )
         runots = runoff(swdra,pond,pondmx,rsro,rsroexp,wls,
     &                   swst,sttab,dt)
         hsurf    = pond
         return
      else

!        if runoff occurs: find values for pond and runots iteratively

         p1 = k1max/disnod(1) * dt
         p2 = 1.0d0/(p1+1.0d0)

!        estimation of maximum ponding: ignore runoff
         h0max = p2 * ( pondm1 + q0*dt - k1max*dt + p1*h(1) )
         h0min = 0.0d0
         do i=1,30
            pond   = 0.5d0 * (h0max + h0min)
            runots = runoff(swdra,pond,pondmx,rsro,
     &                         rsroexp,wls,swst,sttab,dt)
            h0     = p2 * ( pondm1 +q0*dt -k1max*dt +p1*h(1) -runots)

            if(dabs(pond-h0).lt.1.0d-6)then
               hsurf    = pond
               return
            else
               if(h0.gt.pond)then
                  h0min = pond
               else
                  h0max = pond
               end if
            end if
         end do
      end if

!     if convergence has not been reached: proceed with final value
      pond   = 0.5d0 * (h0max + h0min)
      runots = runoff(swdra,pond,pondmx,rsro,rsroexp,wls,swst,sttab,dt)
      hsurf  = pond

      return
      end


      SUBROUTINE SCALEG (N,MA,A,MB,B,LOW,IGH,CSCALE,CPERM,WK)
CSE
C
CPS       PURPOSE:
C
C             SCALES THE MATRICES A AND B IN THE GENERALIZED
C             EIGENVALUE PROBLEM A*X = (LAMBDA)*B*X SUCH THAT THE
C             MAGNITUDES OF THE ELEMENTS OF THE SUBMATRICES OF A AND B
C             AS DETERMINED BY LOW AND IGH ARE AS CLOSE TO UNITY AS
C             POSSIBLE IN THE LEAST SQUARES SENSE.
C
CPE
CAS         ***  ARGUMENT LIST  ***
C
C  INPUT PARAMETERS:
C
C  N - THE ORDER OF THE MATRICES A AND B;
C
C  MA - THE ROW (FIRST) DIMENSION OF THE ARRAY A AS SPECIFIED
C       IN THE CALLING PROGRAM;
C
C  A - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MA AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX A AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE;
C
C  MB - THE ROW (FIRST) DIMENSION OF THE ARRAY B AS SPECIFIED IN
C       THE CALLING PROGRAM;
C
C  B - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MB AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX B AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE;
C
C  LOW - THE INTEGER SPECIFYING THE BEGINNING INDEX FOR THE ROWS AND
C        COLUMNS OF A AND B TO BE SCALED;
C
C  IGH - THE INTEGER SPECIFYING THE ENDING INDEX FOR THE ROWS AND
C        COLUMNS OF A AND B TO BE SCALED;
C
C  CPERM - AN ARRAY OF ANY DIMENSION THAT MUST BE PROVIDED BY THE
C          USER FOR WORK SPACE. CPERM MUST CONTAIN AT LEAST N
C          LOCATIONS. ONLY LOCATIONS LOW THROUGH IGH ARE REFERENCED;
C
C  WK - AN ARRAY OF ANY DIMENSION THAT MUST BE PROVIDED BY THE
C       USER FOR WORK SPACE. WK MUST CONTAIN AT LEAST 6*N LOCATIONS.
C       ONLY LOCATIONS LOW THROUGH IGH, N+LOW THROUGH N+IGH,...,
C       5*N+LOW THROUGH 5*N+IGH ARE REFERENCED.
C
C  OUTPUT PARAMETERS:
C
C  A - CONTAINS THE SCALED A MATRIX;
C
C  B - CONTAINS THE SCALED B MATRIX;
C
C  CSCALE - THE REAL ARRAY OF DIMENSION AT LEAST N CONTAINING IN
C           ITS LOW THROUGH IGH LOCATIONS THE INTEGER EXPONENTS OF 2
C           USED FOR THE COLUMN SCALING FACTORS. THE OTHER LOCATIONS
C           ARE NOT REFERENCED;
C
C  WK - CONTAINS IN ITS LOW THROUGH IGH LOCATIONS THE INTEGER
C       EXPONENTS OF 2 USED FOR THE ROW SCALING FACTORS.
C
CAE
C  REQUIRED SUBPROGRAMS - NONE
C
C  REQUIRED FUNCTIONS - ABS,SIGN,FLOAT,LOG10
C
C  REFERENCE - R.C. WARD, BALANCING THE GENERALIZED EIGENVALUE
C              PROBLEM, TECHNICAL REPORT ORNL/CSD-47, OAK RIDGE,
C              TENNESSEE, 1979.
C
C              [SAME TITLE] SIAM J. SCI. STAT. COMPUT., VOL 2,
C                           NO 2, JUNE 1981, PP 141-152.
C
C ****
C
      DIMENSION A(MA,N),B(MB,N),CSCALE(N),CPERM(N),WK(N,6)
      DOUBLE PRECISION A,B,CSCALE,CPERM,WK,T,EW,EWC,FI,FJ,TA,
     1                 TB,TC,COR,SUM,BASL,BETA,CMAX,COEF,COEF2,
     2                 COEF5,ALPHA,GAMMA,PGAMMA
C
      IF (LOW .EQ. IGH) GO TO 405
      DO 210 I=LOW,IGH
         WK(I,1) = 0.D0
         CSCALE(I) = 0.D0
         WK(I,3) = 0.D0
         WK(I,4) = 0.D0
         WK(I,5) = 0.D0
         WK(I,6) = 0.D0
         WK(I,2) = 0.D0
         CPERM(I) = 0.D0
  210 CONTINUE
C ****
C     COMPUTE RIGHT SIDE VECTOR IN RESULTING LINEAR EQUATIONS
C ****
      BASL = DLOG10(2.D0)
      DO 240 I=LOW,IGH
         DO 240 J=LOW,IGH
            TB = B(I,J)
            TA = A(I,J)
            IF (TA .EQ. 0.D0) GO TO 220
            TA = DLOG10(DABS(TA)) / BASL
  220       IF (TB .EQ. 0.D0) GO TO 230
            TB = DLOG10(DABS(TB)) / BASL
  230       WK(I,5) = WK(I,5) - TA - TB
            WK(J,6) = WK(J,6) - TA - TB
  240 CONTINUE
C
      NR = IGH-LOW+1
      COEF = 1.D0 / FLOAT(2*NR)
      COEF2 = COEF * COEF
      COEF5 = .5D0 * COEF2
      NRP2 = NR + 2
      BETA = 0.D0
      IT = 1
C ****
C     START GENERALIZED CONJUGATE GRADIENT ITERATION
C ****
  250 CONTINUE
      EW = 0.D0
      EWC = 0.D0
      GAMMA = 0.D0
      DO 260 I=LOW,IGH
         GAMMA = GAMMA + WK(I,5)*WK(I,5) + WK(I,6)*WK(I,6)
         EW = EW + WK(I,5)
         EWC = EWC + WK(I,6)
  260 CONTINUE
      GAMMA = COEF*GAMMA - COEF2*(EW**2 + EWC**2)
     1        - COEF5 * (EW - EWC)**2
      IF (IT .NE. 1) BETA = GAMMA / PGAMMA
      T = COEF5 * (EWC - 3.*EW)
      TC = COEF5 * (EW - 3.*EWC)
      DO 270 I=LOW,IGH
         WK(I,2) = BETA*WK(I,2) + COEF*WK(I,5) + T
         CPERM(I) = BETA*CPERM(I) + COEF*WK(I,6) + TC
  270 CONTINUE
C ****
C     APPLY MATRIX TO VECTOR
C ****
      DO 300 I=LOW,IGH
         KOUNT = 0
         SUM = 0.D0
         DO 290 J=LOW,IGH
            IF (A(I,J) .EQ. 0.D0) GO TO 280
            KOUNT = KOUNT + 1
            SUM = SUM + CPERM(J)
  280       IF (B(I,J) .EQ. 0.D0) GO TO 290
            KOUNT = KOUNT + 1
            SUM = SUM + CPERM(J)
  290    CONTINUE
         WK(I,3) = FLOAT(KOUNT)*WK(I,2) + SUM
  300 CONTINUE
      DO 330 J=LOW,IGH
         KOUNT = 0
         SUM = 0.D0
         DO  320 I=LOW,IGH
            IF (A(I,J) .EQ. 0.D0) GO TO 310
            KOUNT = KOUNT + 1
            SUM = SUM + WK(I,2)
  310       IF (B(I,J) .EQ. 0.D0) GO TO 320
            KOUNT = KOUNT + 1
            SUM = SUM + WK(I,2)
  320    CONTINUE
         WK(J,4) = FLOAT(KOUNT)*CPERM(J) + SUM
  330 CONTINUE
C
      SUM = 0.D0
      DO 340 I=LOW,IGH
         SUM = SUM + WK(I,2)*WK(I,3) + CPERM(I)*WK(I,4)
  340 CONTINUE
C
C     IF GAMMA=0.0 AND SUM=0.0 GO TO END OF ITERATION
      IF(GAMMA.EQ.0.0 .AND. SUM.EQ.0.0) GO TO 370
C
      ALPHA = 0.0
      ALPHA = GAMMA / SUM
C ****
C     DETERMINE CORRECTION TO CURRENT ITERATE
C ****
      CMAX = 0.D0
      DO 350 I=LOW,IGH
         COR = ALPHA * WK(I,2)
         IF (DABS(COR) .GT. CMAX) CMAX = DABS(COR)
         WK(I,1) = WK(I,1) + COR
         COR = ALPHA * CPERM(I)
         IF (DABS(COR) .GT. CMAX) CMAX = DABS(COR)
         CSCALE(I) = CSCALE(I) + COR
  350 CONTINUE
      IF (CMAX .LT. .5D0) GO TO 370
      DO 360 I=LOW,IGH
         WK(I,5) = WK(I,5) - ALPHA * WK(I,3)
         WK(I,6) = WK(I,6) - ALPHA * WK(I,4)
  360 CONTINUE
      PGAMMA = GAMMA
      IT = IT + 1
      IF (IT .LE. NRP2) GO TO 250
C ****
C     END GENERALIZED CONJUGATE GRADIENT ITERATION
C ****
  370 DO 380 I=LOW,IGH
         IR = WK(I,1) + DSIGN(.5D0,WK(I,1))
         WK(I,1) = IR
         JC = CSCALE(I) + DSIGN(.5D0,CSCALE(I))
         CSCALE(I) = JC
  380 CONTINUE
C ****
C     SCALE A AND B
C ****
      DO 400 I=1,IGH
         IR = WK(I,1)
         FI = 2.D0**IR
         IF (I .LT. LOW) FI = 1.D0
         DO 400 J=LOW,N
            JC = CSCALE(J)
            FJ = 2.D0**JC
            IF (J .LE. IGH) GO TO 390
            IF (I .LT. LOW) GO TO 400
            FJ = 1.D0
  390       A(I,J) = A(I,J)*FI*FJ
            B(I,J) = B(I,J)*FI*FJ
  400 CONTINUE
  405 CONTINUE
C ****
C     EXIT SCALEG
C ****
      RETURN
      END


      SUBROUTINE DZY (X,Y,Z,SGR,CGR,XI1,XI2,ETA,ZETA,AR,AO,KR,CBAR,
     1                BETA,FMACH,LSH,IDZDY,DZDYR,DZDYI)
C
C     CALCULATION OF THE DZ AND DY MATRICES USED IN SLENDER BODY FLOW
C
C     X        X- COORDINATE OF THE RECEIVING POINT
C     Y        Y - COORDINATE OF THE RECEIVING POINT
C     Z        Z - COORDINATE OF THE RECEIVING POINT
C     SGR      SINE OF THE RECEIVING POINT DIHEDRAL ANGLE
C     CGR      COSINE OF RECEIVING POINT DIHEDRAL ANGLE
C     XI1
C     XI2
C     ETA
C     ZETA
C     AR       ASPECT RATIO OF THE SENDING BODY
C     A0       RADIUS OF THE SENDING BODY
C     KR       REDUCED FREQUENCY
C     CBAR     REFERENCE CHORD LENGTH
C     BETA     SQRT(1.0-M**2)
C     FMACH    MACH NUMBER
C     IDZDY    FLAG INDICATING WHETHER DZ OF DY IS TO BE
C              CALCULATED.  =0  DZ, OTHERWISE DY
C     DZDYR    REAL PART OF DZ OR DY
C     DZDYI    IMAGINARY PART OF DZ OR DY
C
C
      REAL   KD1PR, KD1PI, KD2PR, KD2PI, KD1MR, KD1MI, KD2MR, KD2MI
      DATA   PI16 / 50.265482 /
C
C
C     THE COMPLEX NUMBERS IN THIS ROUTINE ARE TREATED SEPERATLY AS
C     THE REAL PART,  NAME APPENDED BY AN  -R- ,  AND THE
C     IMAGINARY PART, NAME APPENDED BY AN  -I- .
C
      E   = AO*SQRT(ABS(1.0 - AR**2))/2.0
      X01 = X - XI1
      X02 = X - XI2
C
C     CHECK ON INPUT FLAG,  = 0  DZ ,  = 1  DY
C
      IF (IDZDY .EQ. 1) GO TO 200
C
C     **     **
C     *  D Z  *
C     **     **
C
      SGS = 0.0
      CGS = 1.0
      IF (AR .LT. 1.0)  GO TO 400
C
      Z01 = Z - (ZETA+E)
      Z02 = Z - (ZETA-E)
      Y01 = Y - ETA
      Y02 = Y01
      GO TO 300
C
C     **     **
C     *  D Y  *
C     **     **
C
  200 SGS = -1.0
      IF (LSH .EQ. 1) SGS = 1.0
      CGS =  0.0
      IF (AR .GT. 1.0) GO TO 400
C
      Z01 = Z - ZETA
      Z02 = Z01
      Y01 = Y - (ETA+E)
      Y02 = Y - (ETA-E)
C
C     ****  DZ AR .GE. 1  ****
C     ****  DY AR .LE. 1  ****
C
  300 CONTINUE
      L   = 0
      Z0  = Z - ZETA
      Y0  = Y - ETA
C
      R1SQR = Y01**2 + Z01**2
      R2SQR = Y02**2 + Z02**2
      R1FOR = R1SQR**2
      R2FOR = R2SQR**2
C
      CALL FLLD (X01,X02,Y01,Z01,SGR,CGR,SGS,CGS,KR,CBAR,FMACH,E,L,
     1           KD1PR,KD1PI,KD2PR,KD2PI)
C
      IF (AR .NE. 1.0)  GO TO 320
C
C     IDENTICAL RESULTS FROM FLLD, THEREFORE SKIP SECOND CALL
C
      KD1MR = KD1PR
      KD1MI = KD1PI
      KD2MR = KD2PR
      KD2MI = KD2PI
      GO TO 360
  320 CONTINUE
      CALL FLLD (X01,X02,Y02,Z02,SGR,CGR,SGS,CGS,KR,CBAR,FMACH,E,L,
     1           KD1MR,KD1MI,KD2MR,KD2MI)
  360 CONTINUE
      DZDYR = 0.0
      DZDYI = 0.0
      IF (R1SQR.LE.0.0001. OR .R2SQR.LE.0.0001) GO TO 370
C
C     REAL
C
      DZDYR = ((KD1PR/R1SQR+KD1MR/R2SQR) + (KD2PR/R1FOR+KD2MR/R2FOR))
     1        /PI16*(-1.0)
C
C     IMAGINARY
C
      DZDYI = ((KD1PI/R1SQR+KD1MI/R2SQR) + (KD2PI/R1FOR+KD2MI/R2FOR))
     1        /PI16*(-1.0)
  370 CONTINUE
C
      RETURN
C
C     ****   DZ-AR .LT. 1   ****
C     ****   DY-AR .GT. 1   ****
C
  400 SL1 = 0.0
      TL1 = 0.0
      SL2 = 0.0
      TL2 = 0.0
      CL1 = 1.0
      CL2 = 1.0
      E   = 1.732051*E
      Y0  = Y - ETA
      Z0  = Z - ZETA
C
      CALL TVOR (SL1,CL1,TL1,SL2,CL2,TL2,SGS,CGS,SGR,CGR,X01,X02,
     1           Y0,Z0,E,BETA,CBAR,FMACH,KR,DZDYR,DZDYI)
      RETURN
      END


subroutine trace_bend_refl(xzt,yzt,xst,yst,ips,	tout,xrefl,yrefl)

real xrmin(1000),yrmin(1000)
real t_segm(1000)
integer indexx(100)
real dxtmp(1000),dytmp(1000),xtmp(1000),ytmp(1000)
integer k_around(100)
real t_around(100)

common/ray_param/ds_ini,ds_segm_min,bend_min0,bend_max0

common/ray/ nodes,xray(1000),yray(1000)
common/ray_part/ npart,xpart(1000),ypart(1000),spart(1000),kod_part(1000)
common/shift/ dxpart(1000),dypart(1000)

!bend_min0=0.0001

dxmax_refl=5
dxmin_refl=0.5
nx_refl=5

!*******************************************************
!*******************************************************
!*******************************************************
!*******************************************************
! Preliminary reflected ray, as two line:

if(abs(xst-xzt).lt.0.0001) then
	xrefl0=xst
else
	yzt2 = yyy_surf(xzt)*2 - yzt
	yst2 = yyy_surf(xst)*2 - yst

	!write(*,*)' yzt2=',yzt2,' yst2=',yst2

	aaa1=(yzt-yst2)/(xzt-xst)
	bbb1=(xzt*yst2-xst*yzt)/(xzt-xst)

	aaa2=(yzt2-yst)/(xzt-xst)
	bbb2=(xzt*yst-xst*yzt2)/(xzt-xst)

	xxx = (bbb2-bbb1) / (aaa1-aaa2)
	yyy1 = aaa1 * xxx + bbb1
	yyy2 = aaa2 * xxx + bbb2

	!write(*,*)' xxx=',xxx,' yyy=',yyy1,yyy2
	xrefl0=xxx
end if

yrefl0=yyy_surf(xxx)

dx_refl=dxmax_refl

k_around=0
t_around=0
nk=0
icen=0
tmin=99999

135 continue
index=0
do icur=-nx_refl,nx_refl,1

	xrefl = xrefl0 + (icur+icen) * dx_refl
	yrefl = yyy_surf(xrefl)
	if(nk.ne.0) then
		do ik=1,nk
			if(k_around(ik).eq.icur+icen) goto 134
		end do
	end if

	call streight_line(xzt,yzt,xrefl,yrefl,ips, tout1)
	call streight_line(xrefl,yrefl,xst,yst,ips, tout2)
	tout=tout1+tout2
	nk=nk+1
	k_around(nk)=icur+icen
	t_around(nk)=tout
	if(tout.lt.tmin) then
		index=1
		tmin=tout
		imin=icur+icen
	end if
	!write(*,*)icur+icen,' xrefl=',xrefl,' tout=',tout
134 continue
end do
if(index.eq.1) then
	icen=imin
	xrefl_min = xrefl0 + imin * dx_refl
	!write(*,*)' icen=',icen,' xrefl=',xrefl_min
	goto 135
end if

137 continue
dx_refl=dx_refl/2.
if(dx_refl.lt.dxmin_refl) goto 136
!write(*,*)' dx_refl=',dx_refl

do icase=1,2
	xrefl = xrefl_min + dx_refl*(-1)**icase
	yrefl = yyy_surf(xrefl)
	call streight_line(xzt,yzt,xrefl,yrefl,ips, tout1)
	call streight_line(xrefl,yrefl,xst,yst,ips, tout2)
	tout=tout1+tout2
	!write(*,*)icase,nodes,' xrefl=',xrefl,' tout=',tout
	if(tout.lt.tmin) then
		tmin=tout
		xrefl_min=xrefl
		!write(*,*)' icase=',icase,' xrefl=',xrefl_min,' tmin=',tmin
		exit
	end if
end do
goto 137

136 continue

xrefl = xrefl_min
yrefl = yyy_surf(xrefl)

call streight_line(xzt,yzt,xrefl,yrefl,ips, tout1)

nrefl=nodes

ntmp=nodes
xtmp=xray
ytmp=yray

call streight_line(xrefl,yrefl,xst,yst,ips, tout2)

do i=2,nodes
	ntmp=ntmp+1
	xtmp(ntmp)=xray(i)
	ytmp(ntmp)=yray(i)
end do

nodes=ntmp
xray=xtmp
yray=ytmp

tout=tout1+tout2
xrefl=xray(nrefl)
yrefl=yray(nrefl)
!write(*,*)' 2 lines: xrefl=',xrefl,' yrefl=',yrefl,' tout=',tout

!************************************************************
!************************************************************
!************************************************************
!************************************************************

totdist=0
do i=1,nodes-1
	x1=xray(i)
	y1=yray(i)
	x2=xray(i+1)
	y2=yray(i+1)
	ds=sqrt((x2-x1)**2+(y2-y1)**2)
	totdist=totdist+ds
end do

!write(*,*)' totdist=',totdist,' nodes=',nodes,' tout=',tout

nsegm_max = int_best(totdist / ds_segm_min)

if(nsegm_max.eq.0) then
	return
end if

tmin=tout

do nsegm=1,nsegm_max

!open(22,file='nodes.dat')

	indexx=0
	dpart=1./nsegm
	val_cur0=bend_max0/nsegm
	xtmp=xray
	ytmp=yray

	do iseg=1,nsegm

		part1=(iseg-1)*dpart
		part2=iseg*dpart

		call part_ray(xzt,yzt,xst,yst,part1,part2)

		irfl_cur=0
		do inode=2,npart-1
			if(kod_part(inode).eq.nrefl)irfl_cur=inode
		end do
		!write(*,*)' iseg=',iseg,' irfl_cur=',irfl_cur

!write(22,*) xpart(1),ypart(1)
		ttt=0
		do inode=1,npart-1
			x1=xpart(inode)
			x2=xpart(inode+1)
			xm=(x1+x2)/2.
			y1=ypart(inode)
			y2=ypart(inode+1)
			ym=(y1+y2)/2.
			ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))
			vvv=velocity (xm,ym,ips)
			ttt=ttt+ds/vvv
			!write(*,*)inode,ypart(inode),dypart(inode),' v=',vvv
		end do
		tini=ttt
		!write(*,*)' tini=',tini,' npart=',npart

		dxpart=0
		dypart=0
		dxtmp=0
		dytmp=0
		valtot=0
		tmin=tini
		t_segm(iseg)=tmin
		val_cur=val_cur0

332		continue
		do icase=1,2
			ind=0
			val_bend = (-1)**icase * val_cur

331			continue
			val = val_bend

			sss2=spart(npart)/2.
			sss=0

			if(irfl_cur.ne.0) then
				srefl=spart(irfl_cur)

				d_value = val * (1-abs(srefl-sss2)/sss2)
				!write(*,*)' srefl=',srefl,' sss2=',sss2
				!write(*,*)' val=',val,' d_value=',d_value
				xrefl_n=xpart(irfl_cur)+ d_value
				yrefl_n=yyy_surf(xrefl_n)
				yrefl=yyy_surf(xpart(irfl_cur))
				!write(*,*)' xrefl_n=',xrefl_n,' yrefl_n=',yrefl_n
				dx_refl=d_value
				dy_refl=yrefl_n-ypart(irfl_cur)
				!write(*,*)' dx_refl=',dx_refl,' dy_refl=',dy_refl

				dydx=dy_refl/dx_refl
				do inode=2,npart-1
					sss=spart(inode)
					d_value = val * (1-abs(sss-sss2)/sss2)
					dxpart(inode)=   d_value
					dypart(inode)=   d_value * dydx
					!write(*,*)inode,dxtmp(inode),dytmp(inode)
				end do

			else
				do inode=2,npart-1

					if(kod_part(inode).eq.nrefl)irfl_cur=inode

					x1=xpart(inode-1)
					y1=ypart(inode-1)

					x2=xpart(inode)
					y2=ypart(inode)

					x3=xpart(inode+1)
					y3=ypart(inode+1)

					sss=spart(inode)

					dx=x3-x1
					dy=y3-y1
					ds2=sqrt(dx*dx+dy*dy)

					d_value = val * (1-abs(sss-sss2)/sss2)

					dxpart(inode)= - d_value * dy / ds2
					dypart(inode)=   d_value * dx / ds2
					!write(*,*)inode,d_value,dxtmp(inode),dytmp(inode)

				end do

			end if

			ttt=0
			sss=0
			do inode=1,npart-1
				x1=	xpart(inode)+	dxpart(inode)
				x2=	xpart(inode+1)+	dxpart(inode+1)
				xm=(x1+x2)/2.

				y1= ypart(inode) +	dypart(inode)
				y2=	ypart(inode+1)+	dypart(inode+1)
				ym=(y1+y2)/2.

				ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))

				sss=sss+ds
				vvv=velocity (xm,ym,ips)
				ttt=ttt+ds/vvv
				!write(*,*)inode,' x=',x1,x2,' y=',y1,y2
				!write(*,*)inode,ypart(inode),dypart(inode),' v=',vvv
			end do
			tout=ttt

			!write(*,*)' val_bend=',val_bend,' tout=',tout

			if(tout.lt.tmin) then
				ind=ind+1
				tmin=tout
				valtot=valtot+val_bend
				do ipp=1,npart
					kod=kod_part(ipp)
					if(kod.eq.0) cycle
					xray(kod)=xray(kod)+dxpart(ipp)
					yray(kod)=yray(kod)+dypart(ipp)
					xpart(ipp)=xpart(ipp)+dxpart(ipp)
					ypart(ipp)=ypart(ipp)+dypart(ipp)
				end do
				!write(*,*)' valtot=',valtot,' val_bend=',val_bend,' tmin=',tmin
				call remeshing(nrefl)
				goto 331
			else
				if(ind.ne.0) exit
			end if

		end do

		val_cur = val_cur / 2.
		if(abs(val_cur).gt.bend_min0) goto 332

		t_segm(iseg)=tmin
		xrefl=xray(nrefl)
		yrefl=yray(nrefl)
		yrefl2=yyy_surf(xrefl)
		!write(*,*)' xrefl=',xrefl,' yrefl=',yrefl,yrefl2
		!write(*,*)' valtot=',valtot,' tmin=',tmin

	end do

333	continue
	ttot=0
	do iseg=1,nsegm
		!write(*,*)' indexx(ip)=',indexx(ip)
		ttot=ttot+t_segm(iseg)
	end do

	call remeshing(nrefl)

	!open(11,file='rays_refl.dat')
	!do i=1,nodes
		!write(11,*)xray(i),yray(i)
	!end do
	!close(11)

	!write(*,*)' val_cur0=',val_cur0,' ttot=',ttot

	!open(21,file='ray_iter.bln')
	!write(21,*)nodes
	!do i=1,nodes
		!write(21,*)xray(i),yray(i)
	!end do
	!close(21)
	!pause

end do
tout=ttot
return
end


!***********************************************************

SUBROUTINE waveinit(zwave,zdualwave,myid)

  IMPLICIT integer(i-n)
  IMPLICIT double precision(a-h,o-y)
  IMPLICIT complex*16(z)
  INCLUDE "input.f90"
  DIMENSION zwave(0:L-1,0:L-1,0:L-1,0:1,0:1,0:n_f-1)
  DIMENSION zdualwave(0:L-1,0:L-1,0:L-1,0:1,0:1,0:n_f-1)
  DIMENSION px(0:n_f-1), py(0:n_f-1), pz(0:n_f-1)
  CHARACTER*3 trig(0:n_f-1)
  CHARACTER*2 particletype(0:n_f-1)

  IF (n_f .ne. 2) THEN
     WRITE(*,*)'error '
     WRITE(*,*)' n_f ',n_f
     STOP
  END IF

  DO npart = 0,n_f-1
     DO ni = 0,1; DO ns = 0,1
        DO nz = 0,L-1; DO ny = 0,L-1; DO nx = 0,L-1
           zwave(nx,ny,nz,ns,ni,npart) = 0.D0
        END DO; END DO; END DO
     END DO; END DO
  END DO

  DO npart = 0,1
     px(npart) = 0.D0
     py(npart) = 0.D0
     pz(npart) = 0.D0
     trig(npart) = 'one'
  END DO
  particletype(0) = 'p+'
  particletype(1) = 'n+'

  DO npart = 0, n_f-1
     IF (particletype(npart) .eq. 'p+') THEN
        ns = 0
        ni = 0
     ELSE IF (particletype(npart) .eq. 'p-') THEN
        ns = 1
        ni = 0
     ELSE IF (particletype(npart) .eq. 'n+') THEN
        ns = 0
        ni = 1
     ELSE IF (particletype(npart) .eq. 'n-') THEN
        ns = 1
        ni = 1
     ELSE
        WRITE(*,*)'particletype error',npart,particletype(npart)
        STOP
     END IF
     IF (trig(npart) .eq. 'one') THEN
        DO nz = 0,L-1; DO ny = 0,L-1; DO nx = 0,L-1
           zwave(nx,ny,nz,ns,ni,npart) = 1.D0
        END DO; END DO; END DO
     ELSE IF (trig(npart) .eq. 'cos') THEN
        DO nz = 0,L-1; DO ny = 0,L-1; DO nx = 0,L-1
           zwave(nx,ny,nz,ns,ni,npart) = &
                dcos(nx*px(npart)*2*pi/L &
                + ny*py(npart)*2*pi/L &
                + nz*pz(npart)*2*pi/L)*dsqrt(2.D0)
        END DO; END DO; END DO
     ELSE IF (trig(npart) .eq. 'sin') THEN
        DO nz = 0,L-1; DO ny = 0,L-1; DO nx = 0,L-1
           zwave(nx,ny,nz,ns,ni,npart) = &
                dsin(nx*px(npart)*2*pi/L &
                + ny*py(npart)*2*pi/L &
                + nz*pz(npart)*2*pi/L)*dsqrt(2.D0)
        END DO; END DO; END DO
     ELSE
        WRITE(*,*)'trig function error',npart
        STOP
     END IF

  END DO

  IF (myid .eq. 0) THEN
     DO npart = 0,n_f-1
        WRITE(*,*)''
        WRITE(*,*)npart,' ',particletype(npart),' ',trig(npart)
        WRITE(*,*)int(px(npart)),int(py(npart)),int(pz(npart))
     END DO
     WRITE(*,*)''
  END IF

  DO npart = 0,n_f-1
     DO ni = 0,1; DO ns = 0,1
        DO nz = 0,L-1; DO ny = 0,L-1; DO nx = 0,L-1
           zdualwave(nx,ny,nz,ns,ni,npart) &
                = dconjg(zwave(nx,ny,nz,ns,ni,npart))
        END DO; END DO; END DO
     END DO; END DO
  END DO

END SUBROUTINE waveinit

!***********************************************************


program main
!	use hifuku
	use sisen
	implicit none
	real t0,t1,temp
	integer is,js,sumval,k
	character arg*20
!	real ref
!	real,dimension(imax,jmax) :: REF
	if (iargc().ne.3) stop 'Argument number should be 3 !'
	call getarg(1,arg)
!	open(1,file="kiban50_450F.futm",form='unformatted')
	open(1,file=arg,form='unformatted')
	read(1) DEM
	close(1)
	call getarg(2,arg)
	read(arg,*) is
	call getarg(3,arg)
	read(arg,*) js
!	read(*,*) is,js
!	write(*,*) is,js,DEM(is,js),'m'
	call cpu_time(t0)
	call view(is,js)
	sumval=sum(VAL)
	call cpu_time(temp)
	write(*,*) temp-t0,'sec'
	open(2,file="sisen.img",form='unformatted')
	write(2) VAL
	close(2)
end program main


      DOUBLE PRECISION FUNCTION DCL1(Z)
      DOUBLE COMPLEX Z
C
C     *** PURPOSE:
C
C     DCL1 IS A DOUBLE PRECISION FUNCTION SUBPROGRAM WHICH RETURNS THE
C     L1-TYPE MAGNITUDE OF A COMPLEX NUMBER Z, I.E., THE NUMBER
C     DABS(RE(Z))+DABS(IM(Z))  WHERE RE(Z) AND IM(Z) ARE THE REAL AND
C     IMAGINARY PARTS, RESPECTIVELY, OF Z.
C
C     THIS VERSION DATED MAY 1980.
C     ALAN J. LAUB, UNIVERSITY OF SOUTHERN CALIFORNIA.
C
C     INTERNAL VARIABLES:
C
      DOUBLE COMPLEX ZDUM
C
C     FORTRAN FUNCTIONS CALLED:
C
      DOUBLE PRECISION DABS
C
C     INTERNAL FUNCTIONS:
C
      DOUBLE PRECISION DIMAG,DREAL
      DREAL(ZDUM) = ZDUM
      DIMAG(ZDUM) = (0.0D0,-1.0D0)*ZDUM
C
      DCL1 = DABS(DREAL(Z))+DABS(DIMAG(Z))
      RETURN
      END


! Photovoltaic panels subroutine
! Lubello: oct 2019

subroutine PhotoArrEq(Area,           & ! (I) Photovoltaic panel area               [m^2]
                      fActive,        & ! (I) Area fraction with active solar cells [-] default: 0.95 - 1.00
                      SolIrr,         & ! (I) Solar irradiance                      [W/m^2]
                      etaCell,        & ! (I) Module conversion efficiency          [-] default: 0.20
                      CostSolPhoto,   & ! (I) Cost per kW panels                    [eur/kW]
                      WWel,           & ! (O) AC Energy produced                    [kWh]
                      CapexSolPhoto)    ! (O) Capex Sol Photo                       [eur]

      USE MODparam,  ONLY: timestep

      implicit real(8) (a-h,o-z), integer(i-n)

      real(8), intent(IN   ) :: Area,fActive,SolIrr,etaCell,CostSolPhoto
      real(8), intent(  OUT) :: WWel,CapexSolPhoto

      real(8)                :: etaInvert
      real(8), parameter     :: Ainv = 97.004, Binv = -1.58, Cinv = -0.362

      WWel          = 0.d0
      CapexSolPhoto = 0.d0
      WWelPeak      = Area*fActive*1.d3*etaCell/1.d3 ! [kW] Nominal power
      WWel = Area*fActive*SolIrr*etaCell/1.d3        ! [kW] Power output

      ! Inverter
      if(WWel.ne.0.d0)then
        WWadim    = WWel/WWelPeak
        etaInvert = (Ainv + Binv*WWadim + Cinv/WWadim)/100.d0
        WWel      = WWel*etaInvert
      else
      endif

      WWel = WWel*timestep ! [kWh] Energy produced

      CapexSolPhoto = CostSolPhoto*WWelPeak ! [eur] Capex

      return

end subroutine PhotoArrEq