!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
module allocate_psl_sub

use scf_data
use read_pslfile_sub

integer :: Nr

real(8), allocatable :: rhopp(:,:)
real(8), allocatable :: vpp(:,:,:)
real(8), allocatable :: uppr(:,:,:)
real(8), allocatable :: uVnl(:,:,:)

real(8), allocatable :: rad_psl(:,:)

real(8), allocatable :: ur(:,:)

real(8),allocatable :: rho_core(:,:,:)

real(8),allocatable :: vloctbl(:,:)
real(8),allocatable :: Gx(:),Gy(:),Gz(:)
real(8),allocatable :: dVloc_G(:,:)
real(8),allocatable :: dVloc_G_tmp(:,:)
complex(8),allocatable :: rhoion_G(:),Vion_G(:)
complex(8),allocatable :: rhoion_G_tmp(:)
complex(8),allocatable :: Vion_G_tmp(:)

complex(8),allocatable :: uVpsibox_c(:,:),uVpsibox2_c(:,:)
complex(8),allocatable :: uVpsibox1_j(:,:,:,:,:),uVpsibox2_j(:,:,:,:,:)

integer :: nGzero

contains
!==================================================================================================

subroutine allocate_psl
use scf_data
implicit none
real(8) :: r
integer :: Nr0

select case(iperiodic)
case(0)
  r=sqrt((dble(lg_num(1))*Hgs(1))**2  &
        +(dble(lg_num(2))*Hgs(2))**2  &
        +(dble(lg_num(3))*Hgs(3))**2)
case(3)
  r=sqrt((dble(lg_num(1))*Hgs(1))**2  &
        +(dble(lg_num(2))*Hgs(2))**2  &
        +(dble(lg_num(3))*Hgs(3))**2)+maxval(Rps(:))
end select
Nr0=r/rmin_step+1
if(Nr0<maxval(Mr(:)))then
  Nr=maxval(Mr(:))+1
else
  Nr=Nr0
end if

allocate(Mps_all(1:MI))
allocate(Mps(1:MI))

maxMps=int(4.d0/3.d0*Pi*(rmaxRps+4.d0*maxval(Hgs(:)))**3/Hvol)
Mlmps=(maxval(Mlps)+1)**2

allocate(Jxyz_all(1:3,1:maxMps,1:MI))
allocate(Jxyz_tmp1(1:3,1:maxMps,1:MI))
allocate(Jxyz_tmp2(1:3,1:maxMps,1:MI))
if(iperiodic==3)then
  allocate(Jxxyyzz_tmp1(1:3,1:maxMps,1:MI))
  allocate(Jxxyyzz_tmp2(1:3,1:maxMps,1:MI))
end if
allocate(uV_all(maxMps,Mlmps,MI), uVu(Mlmps,MI))

allocate(rhopp(0:Nr,MKI))
allocate(vpp(0:Nr,0:Nlps,MKI))
allocate(uppr(0:Nr,0:Nlps,MKI))
allocate(uVnl(0:Nr,0:Nlps,MKI))
allocate(rad_psl(0:Nr,MKI))

allocate(ur(maxMps,Nlmps))

allocate(rho_core(mg_sta(1):mg_end(1),mg_sta(2):mg_end(2),mg_sta(3):mg_end(3)))

allocate(Jxyz(3,maxMps,MI))
allocate(uV(maxMps,Mlmps,MI))
allocate(numatom_ps(mg_sta(1):mg_end(1),mg_sta(2):mg_end(2),mg_sta(3):mg_end(3)))

if(iperiodic==3)then
  allocate(vloctbl(Nr,MKI))
  allocate(Gx(lg_num(1)*lg_num(2)*lg_num(3)))
  allocate(Gy(lg_num(1)*lg_num(2)*lg_num(3)))
  allocate(Gz(lg_num(1)*lg_num(2)*lg_num(3)))
  allocate(dVloc_G(lg_num(1)*lg_num(2)*lg_num(3),MKI))
  allocate(dVloc_G_tmp(lg_num(1)*lg_num(2)*lg_num(3),MKI))
  allocate(rhoion_G(lg_num(1)*lg_num(2)*lg_num(3)))
  allocate(rhoion_G_tmp(lg_num(1)*lg_num(2)*lg_num(3)))
  allocate(Vion_G(lg_num(1)*lg_num(2)*lg_num(3)))
  allocate(Vion_G_tmp(lg_num(1)*lg_num(2)*lg_num(3)))
end if

allocate(Jxxyyzz_all(1:3,1:maxMps,1:MI))
allocate(Jxxyyzz(1:3,1:maxMps,1:MI))

if(iflag_ps==1) then
  allocate (uVpsibox_c(1:maxlm,1:MI))
  allocate (uVpsibox2_c(1:maxlm,1:MI))
  uVpsibox_c=0.d0
  uVpsibox2_c=0.d0
  if(iperiodic==3.and.iSCFRT==2)then
    allocate (uVpsibox1_j(4,1:maxlm,1:MI,1:iobnum,k_sta:k_end))
    allocate (uVpsibox2_j(4,1:maxlm,1:MI,1:iobnum,k_sta:k_end))
    uVpsibox1_j=0.d0
    uVpsibox2_j=0.d0
  end if
end if

end subroutine allocate_psl
!==================================================================================================
subroutine deallocate_psl

deallocate(Jxyz_all,Jxyz_tmp1,Jxyz_tmp2)
if(iperiodic==3) deallocate(Jxxyyzz_tmp1,Jxxyyzz_tmp2)
deallocate(Mps_all)
deallocate(Mps)
deallocate(uV_all,uVu)

deallocate(rhopp,vpp,uppr,uVnl)
deallocate(ur)
deallocate(rad_psl)

deallocate(rho_core)

deallocate(Jxyz,uV)
deallocate(numatom_ps)

if(iperiodic==3)then
  deallocate(vloctbl)
  deallocate(Gx,Gy,Gz)
  deallocate(dVloc_G,rhoion_G,Vion_G)
  deallocate(dVloc_G_tmp,rhoion_G_tmp,Vion_G_tmp)
end if
deallocate(Jxxyyzz_all)
deallocate(Jxxyyzz)

if(iflag_ps==1) then
  deallocate (uVpsibox_c,uVpsibox2_c)
  if(iperiodic==3.and.iSCFRT==2) deallocate (uVpsibox1_j,uVpsibox2_j)
end if

end subroutine deallocate_psl
!==================================================================================================
end module allocate_psl_sub


SUBROUTINE specfit_func_sol ( fitvar, nfitvar, ymod, npoints, ctrl, dyda, mdy )

  !
  ! Calculates the Solar spectrum and its derivatives for ELSUNC
  !
  ! NOTE: the variable DYDA as required here is the transpose of that
  !       rquired for the Numerical Recipes
  !

  USE OMSAO_precision_module
  USE OMSAO_parameters_module, ONLY : &
       max_spec_pts, elsunc_parsoob_eval, elsunc_infloop_eval

  USE OMSAO_variables_module,  ONLY : &
       yn_smooth, yn_doas, fitwavs, fitweights, currspec, sol_wav_avg, &
       lobnd, upbnd, num_fitfunc_calls, num_fitfunc_jacobi, max_fitfunc_calls

  IMPLICIT NONE

  INTEGER (KIND=i4),                              INTENT (IN)    :: nfitvar, npoints, mdy
  INTEGER (KIND=i4),                              INTENT (INOUT) :: ctrl
  REAL    (KIND=r8), DIMENSION (nfitvar),         INTENT (IN)    :: fitvar
  REAL    (KIND=r8), DIMENSION (npoints),         INTENT (INOUT) :: ymod
  REAL    (KIND=r8), DIMENSION (npoints,nfitvar), INTENT (INOUT) :: dyda

  REAL    (KIND=r8), DIMENSION (npoints) :: locwvl

  locwvl(1:npoints) = fitwavs(1:npoints)
  SELECT CASE ( ABS ( ctrl ) )
  CASE ( 1 )
     ! -------------------------------------------------
     ! Count the number of calls to the fitting function
     ! and terminate if we exceed the allowed maximum.
     ! -------------------------------------------------
     num_fitfunc_calls = num_fitfunc_calls + 1
     IF ( num_fitfunc_calls > max_fitfunc_calls ) THEN
        ctrl = INT(elsunc_infloop_eval, KIND=i4)
        RETURN
     END IF

     ! ------------------------------------------------
     ! Check for any fitting variables "out of bounds".
     ! ------------------------------------------------
     IF ( ANY(fitvar(1:nfitvar) < lobnd(1:nfitvar)) .OR. &
          ANY(fitvar(1:nfitvar) > upbnd(1:nfitvar)) ) THEN
        ctrl = INT(elsunc_parsoob_eval, KIND=i4)
        RETURN
     END IF
     ! -----------------------------------------------------------------------
     ! Calculate the weighted difference between fitted and measured spectrum.
     ! -----------------------------------------------------------------------
     CALL spectrum_solar ( &
          npoints, nfitvar, yn_smooth, sol_wav_avg, locwvl(1:npoints), ymod(1:npoints), &
          fitvar(1:nfitvar), yn_doas )
     ymod(1:npoints) = ( ymod(1:npoints) - currspec(1:npoints) ) * fitweights(1:npoints)

  CASE ( 2 )
     ! -------------------------------------------------
     ! Count the number of calls to the fitting function
     ! with request for the Jacobian and terminate if we
     ! exceed the allowed maximum (just to be safe!).
     ! -------------------------------------------------
     num_fitfunc_jacobi = num_fitfunc_jacobi + 1
     IF ( num_fitfunc_jacobi > max_fitfunc_calls ) THEN
        ctrl = INT(elsunc_infloop_eval, KIND=i4)
        RETURN
     END IF
     ! ---------------------------------------------------------------------
     ! The following sets up ELSUNC for numerical computation of the fitting
     ! function derivative. It is faster and more flexible than the original
     ! "manual" (AUTODIFF) scheme, and gives better fitting uncertainties.
     ! ---------------------------------------------------------------------
     ctrl = 0; RETURN

  CASE ( 3 )
     ! Calculate the spectrum, without weighting
     CALL spectrum_solar ( &
          npoints, nfitvar, yn_smooth, sol_wav_avg, locwvl(1:npoints), ymod(1:npoints), &
          fitvar(1:nfitvar), yn_doas )

  CASE DEFAULT
     !WRITE (*,'(A,I4)') &
     !     "ERROR in function ELSUNC_SPECFIT_FUNC. Don't know how to handle CTRL = ", ctrl
  END SELECT

  RETURN
END SUBROUTINE specfit_func_sol

SUBROUTINE specfit_func ( fitvar, nfitvar, ymod, npoints, ctrl, dyda, mdy )

  !
  !     Calculates the spectrum and its derivatives for ELSUNC
  !
  ! NOTE: the variable DYDA as required here is the transpose of that
  !       rquired for the Numerical Recipes
  !

  USE OMSAO_precision_module
  USE OMSAO_parameters_module, ONLY : &
       max_spec_pts, elsunc_parsoob_eval, elsunc_infloop_eval
  USE OMSAO_variables_module, ONLY : &
       database, yn_doas, yn_smooth, rad_wav_avg, fitwavs, fitweights, currspec, &
       lobnd, upbnd, num_fitfunc_calls, num_fitfunc_jacobi, max_fitfunc_calls
  USE OMSAO_radiance_ref_module, ONLY: yn_reference_fit

  IMPLICIT NONE

  INTEGER (KIND=i4),                              INTENT (IN)    :: nfitvar, npoints, mdy
  INTEGER (KIND=i4),                              INTENT (INOUT) :: ctrl
  REAL    (KIND=r8), DIMENSION (nfitvar),         INTENT (INOUT) :: fitvar
  REAL    (KIND=r8), DIMENSION (npoints),         INTENT (INOUT) :: ymod
  REAL    (KIND=r8), DIMENSION (npoints,nfitvar), INTENT (INOUT) :: dyda

  REAL    (KIND=r8), DIMENSION (npoints)       :: locwvl

  locwvl(1:npoints) = fitwavs(1:npoints)

  SELECT CASE ( ABS ( ctrl ) )
  CASE ( 1 )
     ! -------------------------------------------------
     ! Count the number of calls to the fitting function
     ! and terminate if we exceed the allowed maximum.
     ! -------------------------------------------------
     num_fitfunc_calls = num_fitfunc_calls + 1
     IF ( num_fitfunc_calls > max_fitfunc_calls ) THEN
        ctrl = INT(elsunc_infloop_eval, KIND=i4)
        RETURN
     END IF
     ! -------------------------------------------------------------
     ! Check whether any of the fitting variables are out of bounds.
     ! If so, indicate uncomputability and return. "Uncomputability"
     ! is indicated by setting  CTRL to < -10.
     ! (NOTE that this is slightly different from the description in
     ! the ELSUNC fitting module).
     ! -------------------------------------------------------------
     IF ( ANY(fitvar(1:nfitvar) < lobnd(1:nfitvar)) .OR. &
          ANY(fitvar(1:nfitvar) > upbnd(1:nfitvar)) ) THEN
        ! DON'T USE THIS! ctrl = INT(elsunc_parsoob_eval, KIND=i4)
        ctrl = -1
        RETURN
     END IF

     ! -----------------------------------------------------------------------
     ! Calculate the weighted difference between fitted and measured spectrum.
     ! -----------------------------------------------------------------------
     CALL spectrum_earthshine ( &
          npoints, nfitvar, yn_smooth, rad_wav_avg, locwvl(1:npoints), ymod(1:npoints), &
          fitvar(1:nfitvar), database, yn_doas )
     !IF ( .NOT. yn_reference_fit ) THEN
     !   WRITE (99,'(3I6)') num_fitfunc_calls, nfitvar, npoints
     !   WRITE (99,'(1P100(E15.5:))') fitvar(1:nfitvar)
     !   DO i = 1, npoints
     !      WRITE (99,'(0PF12.4, 1P3E15.5)') locwvl(i), currspec(i), ymod(i), fitweights(i)
     !   END DO
     !END IF

     ymod(1:npoints) = ( ymod(1:npoints) - currspec(1:npoints) ) * fitweights(1:npoints)

  CASE ( 2 )
     ! -------------------------------------------------
     ! Count the number of calls to the fitting function
     ! with request for the Jacobian and terminate if we
     ! exceed the allowed maximum (just to be safe!).
     ! -------------------------------------------------
     num_fitfunc_jacobi = num_fitfunc_jacobi + 1
     IF ( num_fitfunc_jacobi > max_fitfunc_calls ) THEN
        ctrl = INT(elsunc_infloop_eval, KIND=i4)
        RETURN
     END IF
     ! ---------------------------------------------------------------------
     ! The following sets up ELSUNC for numerical computation of the fitting
     ! function derivative. It is faster and more flexible than the original
     ! "manual" (AUTODIFF) scheme, and gives better fitting uncertainties.
     ! ---------------------------------------------------------------------
     ctrl = 0; RETURN

  CASE ( 3 )
     ! Calculate the spectrum, without weighting
     CALL spectrum_earthshine ( &
          npoints, nfitvar, yn_smooth, rad_wav_avg, locwvl(1:npoints), ymod(1:npoints), &
          fitvar(1:nfitvar), database, yn_doas )

  CASE DEFAULT
     !WRITE (*,'(A,I4)') &
     !     "ERROR in function ELSUNC_SPECFIT_FUNC. Don't know how to handle CTRL = ", ctrl
  END SELECT

  RETURN
END SUBROUTINE specfit_func

SUBROUTINE specfit_func_o3exp ( fitvar, nfitvar, ymod, npoints, ctrl, dyda, mdy )

  !
  !     Calculates the spectrum and its derivatives for ELSUNC
  !
  ! NOTE: the variable DYDA as required here is the transpose of that
  !       rquired for the Numerical Recipes
  !

  USE OMSAO_precision_module
  USE OMSAO_parameters_module, ONLY : &
       max_spec_pts, elsunc_parsoob_eval, elsunc_infloop_eval
  USE OMSAO_variables_module, ONLY : &
       database, yn_doas, yn_smooth, rad_wav_avg, fitwavs, fitweights, currspec, &
       lobnd, upbnd, num_fitfunc_calls, num_fitfunc_jacobi, max_fitfunc_calls
  USE OMSAO_radiance_ref_module, ONLY: yn_reference_fit

  IMPLICIT NONE

  INTEGER (KIND=i4),                              INTENT (IN)    :: nfitvar, npoints, mdy
  INTEGER (KIND=i4),                              INTENT (INOUT) :: ctrl
  REAL    (KIND=r8), DIMENSION (nfitvar),         INTENT (INOUT) :: fitvar
  REAL    (KIND=r8), DIMENSION (npoints),         INTENT (INOUT) :: ymod
  REAL    (KIND=r8), DIMENSION (npoints,nfitvar), INTENT (INOUT) :: dyda

  REAL    (KIND=r8), DIMENSION (npoints)       :: locwvl

  locwvl(1:npoints) = fitwavs(1:npoints)

  SELECT CASE ( ABS ( ctrl ) )
  CASE ( 1 )
     ! -------------------------------------------------
     ! Count the number of calls to the fitting function
     ! and terminate if we exceed the allowed maximum.
     ! -------------------------------------------------
     num_fitfunc_calls = num_fitfunc_calls + 1
     IF ( num_fitfunc_calls > max_fitfunc_calls ) THEN
        ctrl = INT(elsunc_infloop_eval, KIND=i4)
        RETURN
     END IF
     ! -------------------------------------------------------------
     ! Check whether any of the fitting variables are out of bounds.
     ! If so, indicate uncomputability and return. "Uncomputability"
     ! is indicated by setting  CTRL to < -10.
     ! (NOTE that this is slightly different from the description in
     ! the ELSUNC fitting module).
     ! -------------------------------------------------------------
     IF ( ANY(fitvar(1:nfitvar) < lobnd(1:nfitvar)) .OR. &
          ANY(fitvar(1:nfitvar) > upbnd(1:nfitvar)) ) THEN
        ! DON'T USE THIS! ctrl = INT(elsunc_parsoob_eval, KIND=i4)
        ctrl = -1
        RETURN
     END IF

     ! -----------------------------------------------------------------------
     ! Calculate the weighted difference between fitted and measured spectrum.
     ! -----------------------------------------------------------------------
     CALL spectrum_earthshine_o3exp ( &
          npoints, nfitvar, yn_smooth, rad_wav_avg, locwvl(1:npoints), ymod(1:npoints), &
          fitvar(1:nfitvar), database, yn_doas )

     !WRITE (*,'(1P100(E12.4:))') fitvar(1:nfitvar)
     !IF ( .NOT. yn_reference_fit ) THEN
     !   WRITE (99,'(3I6)') num_fitfunc_calls, nfitvar, npoints
     !   WRITE (99,'(1P100(E15.5:))') fitvar(1:nfitvar)
     !   DO i = 1, npoints
     !      WRITE (99,'(0PF12.4, 1P3E15.5)') locwvl(i), currspec(i), ymod(i), fitweights(i)
     !   END DO
     !END IF

     ymod(1:npoints) = ( ymod(1:npoints) - currspec(1:npoints) ) * fitweights(1:npoints)
  CASE ( 2 )
     ! -------------------------------------------------
     ! Count the number of calls to the fitting function
     ! with request for the Jacobian and terminate if we
     ! exceed the allowed maximum (just to be safe!).
     ! -------------------------------------------------
     num_fitfunc_jacobi = num_fitfunc_jacobi + 1
     IF ( num_fitfunc_jacobi > max_fitfunc_calls ) THEN
        ctrl = INT(elsunc_infloop_eval, KIND=i4)
        RETURN
     END IF
     ! ---------------------------------------------------------------------
     ! The following sets up ELSUNC for numerical computation of the fitting
     ! function derivative. It is faster and more flexible than the original
     ! "manual" (AUTODIFF) scheme, and gives better fitting uncertainties.
     ! ---------------------------------------------------------------------
     ctrl = 0; RETURN

  CASE ( 3 )
     ! Calculate the spectrum, without weighting
     CALL spectrum_earthshine_o3exp ( &
          npoints, nfitvar, yn_smooth, rad_wav_avg, locwvl(1:npoints), ymod(1:npoints), &
          fitvar(1:nfitvar), database, yn_doas )

  CASE DEFAULT
     !WRITE (*,'(A,I4)') &
     !     "ERROR in function ELSUNC_SPECFIT_FUNC. Don't know how to handle CTRL = ", ctrl
  END SELECT

  RETURN
END SUBROUTINE specfit_func_o3exp

SUBROUTINE cubic_func ( x, afunc, ma )

  ! ***************************************************
  !
  !   Computes a third-order polynomial. Used in LFIT
  !
  ! ***************************************************

  USE OMSAO_precision_module

  IMPLICIT NONE

  ! ===============
  ! Input variables
  ! ===============
  INTEGER (KIND=i4), INTENT (IN) :: ma
  REAL    (KIND=r8), INTENT (IN) :: x

  ! ================
  ! Output variables
  ! ================
  REAL (KIND=r8), DIMENSION (ma), INTENT (OUT) :: afunc

  ! ===============
  ! Local variables
  ! ===============
  INTEGER (KIND=i4) :: i

  afunc(1) = 1.0_r8
  DO i = 2, ma
     afunc(i) = afunc(i-1) * x
  END DO

  RETURN
END SUBROUTINE cubic_func

SUBROUTINE cubic_specfit ( a, na, y, m, ctrl, dyda, mdy )

  USE OMSAO_precision_module
  USE OMSAO_parameters_module, ONLY : max_spec_pts
  USE OMSAO_variables_module, ONLY : cubic_x, cubic_y, cubic_w

  IMPLICIT NONE

  ! Input parameters
  ! ================
  INTEGER (KIND=i4),                  INTENT (IN)  :: na, m, mdy
  REAL    (KIND=r8), DIMENSION (na),  INTENT (IN)  :: a

  ! Modified parameters
  ! ===================
  INTEGER (KIND=i4), INTENT (INOUT) :: ctrl

  ! Output parameters
  ! =================
  REAL (KIND=r8), DIMENSION (m),    INTENT (OUT)  :: y
  REAL (KIND=r8), DIMENSION (m,na), INTENT (OUT)  :: dyda

  ! Local variables
  ! ===============
  REAL (KIND=r8), DIMENSION (m) :: x, y0

  x  = cubic_x(1:m)
  y0 = a(1) + a(2)*x + a(3)*x*x + a(4)*x*x*x

  SELECT CASE ( ABS(ctrl) )
  CASE ( 1 )
     y  = ( y0 - cubic_y(1:m) ) / cubic_w(1:m)
  CASE ( 2 )
     dyda = 0.0_r8
     dyda(1:m,1) = 1.0_r8
     dyda(1:m,2) = x(1:m)
     dyda(1:m,3) = x(1:m)*x(1:m)
     dyda(1:m,4) = x(1:m)*x(1:m)*x(1:m)
  CASE ( 3 )
     ! This CASE is included to get the complete fitted spectrum
     y  = y0
  CASE DEFAULT
     !WRITE (*, '(A,I3)') "Don't know how to handle CTRL = ", ctrl
  END SELECT

  RETURN
END SUBROUTINE cubic_specfit


#include "../defines.inc"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!These subroutines allow for a Monte Carlo simulation of
!a polymer chain to be performed
!Cases for parallel tempering (replica exchange) and without are included
!Without parallel tempering, nSTEPS are performed.
!With parallel tempering, nSTEP are performed between nREPLICAexchange iterations
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!wlcsim subroutine for performing monte carlo simulation
subroutine wlcsim_brad(wlc_p)
! values from wlcsim_data
use params, only: wlc_eelasREPLICAS, wlc_id, wlc_R, wlc_Wrs, wlc_nodeNUMBER&
    , wlc_LKs, wlc_Wr, wlc_nLKs
  use params
  use mersenne_twister
  use energies, only:energyOf, bend_, stretch_, shear_, twist_
#if MPI_VERSION
  use mpi
#endif

  implicit none

  !Structures for simulation
  type(wlcsim_params) :: wlc_p

  !MPI status variables
#if MPI_VERSION
  integer (kind = 4)  status(MPI_STATUS_SIZE)
#endif

  integer (kind = 4) error
  !Integers for commuinication among replicas
  integer rep
  integer dest
  integer source
  integer LK
  real(dp) Wr
  real(dp) eelas(4)
  integer repSTART,repEND
  !Counting variables
  integer repinD

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !Run simulation
  !Cases:
  !parallel tempering on
  !parallel tempering off
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !If parallel tempering is on
  if (WLC_P__PT_TWIST) then

#if MPI_VERSION
     !Cases:
     !Head node (id = 0)
     !Worker node (id /= 0)

     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     !Head node
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     if (wlc_id.eq.0) then

        !During replica exchange, replicas alternate between switching with
        !replica above and replica below. Initially, set the replica looking above
        !to the be first one
        repSTART = 1
        repEND = wlc_nLKs - 1

        !Begin replica exchange loop
        do repinD = 1,WLC_P__NREPLICAEXCHANGEPERSAVEPOINT

           !Send out Lk to the worker nodes to begin their simulations
           do rep = 1,wlc_nLKs
              LK = wlc_LKs(rep)
              dest = wlc_nodeNUMBER(rep)
              call MPI_Send (LK,1, MPI_integer, dest,   0, &
                   MPI_COMM_WORLD,error )
           enddo

           !LK, Wr, and EELAS from the worker nodes to perform
           !replica exchange

           do rep = 1,wlc_nLKs
              LK = wlc_LKs(rep)
              source = wlc_nodeNUMBER(rep)
              call MPI_Recv(Wr,1, MPI_doUBLE_PRECISION, source, 0, &
                   MPI_COMM_WORLD,status,error )
              call MPI_Recv(eelas,4, MPI_doUBLE_PRECISION, source, 0, &
                   MPI_COMM_WORLD,status,error )
              wlc_Wrs(rep) = Wr
              wlc_eelasREPLICAS(rep,:) = eelas
           enddo

           !peform replica exchange
           call replicaEXCHANGE_brad(wlc_p)

        enddo

     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     !Worker nodes
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     else
        !Begin replica exchange loop
        do repinD = 1,WLC_P__NREPLICAEXCHANGEPERSAVEPOINT
           !Receive LK from head node to begin simulation
           source = 0
           call MPI_Recv(LK,1, MPI_integer, source,   0, &
                MPI_COMM_WORLD,status,error )
           wlc_p%LK = LK

           !Run a monte carlo simulation for NSTEPS
           call MCsim(wlc_p,WLC_P__STEPSPEREXCHANGE)

           !Recalculate structural quantities and energies
           call writhe(wlc_R,WLC_P__NB, wlc_Wr)
           call energy_elas(eelas,wlc_p)
           energyOf(bend_)%E    =eelas(1)
           energyOf(shear_)%E   =eelas(2)
           energyOf(stretch_)%E =eelas(3)
           energyOf(twist_)%E   =eelas(4)

           !Communicate with the head node for replica exchange

           !Send back writhe and elastic energy back to the head node
           call MPI_SEND(wlc_Wr,1, MPI_doUBLE_PRECISION, source, 0, &
                MPI_COMM_WORLD,error )
           call MPI_SEND(eelas,4, MPI_doUBLE_PRECISION, source, 0, &
                MPI_COMM_WORLD,error )

           !Receive new LKs from the head node after replica exchange
           call MPI_Recv(LK,1, MPI_integer, source,   0, &
                MPI_COMM_WORLD,status,error )
           wlc_p%LK = LK

        enddo
     endif

#endif
  !No parallel tempering
  else
     !Run a MC simulation for nstepsPerExchange

     call MCsim(wlc_p,WLC_P__STEPSPEREXCHANGE)

     !Recalculate structural quantities and energies
     call writhe(wlc_R,WLC_P__NB, wlc_Wr)
     call energy_elas(eelas,wlc_p)
     energyOf(bend_)%E    =eelas(1)
     energyOf(shear_)%E   =eelas(2)
     energyOf(stretch_)%E =eelas(3)
     energyOf(twist_)%E   =eelas(4)

  end if
end subroutine wlcsim_brad

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Replica exchange subroutine
!after performing a monte carlo simulation
!this subroutine loops over pairs of replicas
!with adjacent linking numbers and tests for
!exchange of their linking numbers

#if MPI_VERSION
subroutine replicaEXCHANGE_brad(wlc_p)
! values from wlcsim_data
use params, only: wlc_replicaSTART, wlc_eelasREPLICAS, wlc_Wrs, wlc_rand_stat, wlc_nTRIALdown&
    , wlc_replicaEND, wlc_LKs, wlc_nTRIALup, wlc_nodeNUMBER, wlc_nSWAPdown, wlc_nLKs&
    , wlc_nSWAPup
  use params
  use mersenne_twister
  use mpi

  implicit none

  !Global structures for wlc params and data
  type(wlcsim_params) :: wlc_p

  !Variables for replica exchange
  integer rep             !replica index
  real(dp) deEXCHANGE     !change in energy for exchange for linking number
  real(dp) urand(1)       !random number for exchange
  real(dp) prob               !probability of exchange
  integer tempLK
  integer dest
  integer (kind = 4) error
  integer LK
  !Loop over every other replica and check for it to exchange with the one above it
  !For the replica exchange, each replica keeps its polymer conformation, and exchanges
  !linking number

  do rep = wlc_replicaSTART, wlc_replicaEND,2

     !Update number of trial exchanges
     wlc_nTRIALup(rep) = wlc_nTRIALup(rep) + 1
     wlc_nTRIALdown(rep + 1) = wlc_nTRIALdown(rep + 1) + 1

     deEXCHANGE = 0.0_dp

     !Include energy from original twist energy of each replica
     deEXCHANGE = -wlc_eelasREPLICAS(rep,4) - wlc_eelasREPLICAS(rep + 1,4)

     !Add change in twist energy due to rep taking LK from above
     deEXCHANGE = deEXCHANGE +((2.0_dp*pi*(wlc_LKs(rep + 1)-wlc_Wrs(rep)))**2.0_dp)*WLC_P__LT/(2.0_dp*WLC_P__L)

     !Add change in twist energy due to rep + 1 takign LK from below
     deEXCHANGE = deEXCHANGE +((2.0_dp*pi*(wlc_LKs(rep)-wlc_Wrs(rep + 1)))**2.0_dp)*WLC_P__LT/(2.0_dp*WLC_P__L)

     !Generate a random number and test for exchange
     call random_number(urand,wlc_rand_stat)
     prob = exp(-deEXCHANGE)

     !Exchange linking numbers according to Metropolis-Hastings criterion
     !This means that the node number associated with each LK is swapped
     if (urand(1).le.prob) then

        tempLK = wlc_nodeNUMBER(rep)
        wlc_nodeNUMBER (rep) = wlc_nodeNUMBER (rep + 1)
        wlc_nodeNUMBER(rep + 1) = tempLK

        !update number of swaps
        wlc_nSWAPup(rep) = wlc_nSWAPup(rep) + 1
        wlc_nSWAPdown(rep + 1) = wlc_nSWAPdown(rep + 1) + 1

     endif
  enddo

  !Alternatve value of replica start and replica end
  if (wlc_replicaSTART.eq.1) then
     wlc_replicaSTART = 2
  else
     wlc_replicaSTART = 1
  endif

  if (wlc_replicaEND.eq.wlc_nLKs-1) then
     wlc_replicaEND = wlc_nLKs-2
  else
     wlc_replicaEND = wlc_nLKs -1
  endif

  !Tell nodes their new LKs

  do rep = 1,wlc_nLKs
     LK = wlc_LKs(rep)
     dest = wlc_nodeNUMBER(rep)
     call MPI_Send (LK,1, MPI_integer, dest,   0, &
          MPI_COMM_WORLD,error )
  enddo

end subroutine replicaEXCHANGE_brad

#endif


      SUBROUTINE PHO_INIT(Linp,Lout,Irej)
C*
C***********************************************************************
C
C     main subroutine to configure and manage PHOJET calculations
C
C     input:  LINP       input unit to read from
C                        -1 to skip reading of input file
C             LOUT       output unit to write to
C
C     output: IREJ       0  success
C                        1  failure
C
C***********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION a , aeb , dum , e1 , e2 , ee , ee1 , ee2 , ep ,
     &                 parnew , phi , PHO_PMASS , plab ,
     &                 pl_lam_1 , pl_lam_2 , pmass1 , pmass2 , pvir
      DOUBLE PRECISION pvirt2 , rho , scale2 , sigx , sigy , sigz ,
     &                 sig_gg , sig_tot , theta , xsub , x_1 , x_2 ,
     &                 ypsi
      INTEGER i , icut , id , idebf , idebn , idlev , idpdg , idum ,
     &        iext , ifl1 , ifl2 , impro , ion , ip , ipar , Irej ,
     &        iset , itmp , ival , kc
      INTEGER kk , Linp , Lout , na , nev , nz
      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  current beam selection
      INCLUDE 'inc/pobeam'
C  general process information
      INCLUDE 'inc/poprcs'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INCLUDE 'inc/pohdfl'
C  integration precision for hard cross sections (obsolete)
      INCLUDE 'inc/pogaup'
C  some hadron information, will be deleted in future versions
      INCLUDE 'inc/pohdrn'
C  obsolete cut-off information
      INCLUDE 'inc/pocut1'
C  photon flux kinematics and cuts
      INCLUDE 'inc/pofcut'
C  cut probability distribution
#ifndef FOR_CORSIKA
      INCLUDE 'inc/poprob'
#else
      INCLUDE 'inc/poprob50'
#endif
C  event weights and generated cross section
      INCLUDE 'inc/powght'
C  names of hard scattering processes
      INCLUDE 'inc/pohpro'
C  hard cross sections and MC selection weights
      INCLUDE 'inc/pohrcs'

      INCLUDE 'inc/pydat1'

      INCLUDE 'inc/pydat2'

      INCLUDE 'inc/pydat3'

Cf2py intent(out) irej

      INTEGER PYCOMP
      EXTERNAL PYCOMP, PHO_PMASS

      DIMENSION itmp(0:11)
      CHARACTER*10 cname
C     CHARACTER*70 NUMBER,FILENA
      CHARACTER*70 number
C15   FORMAT(A12)

C  define input/output units
      IF ( Linp.GE.0 ) THEN
         LPRi = 10
         CALL DT_RNDMST(22,54,76,92)
         LI = Linp
#ifndef FOR_FLUKA
Cinitialize random number generator in standalone (-2) mode
      ELSE IF ( Linp.EQ.-2 ) THEN
         CALL DT_RNDMST(22,54,76,92)
        ! CALL DT_RNDMTE(1)
         LPRi = 10
#endif
      ELSE
         LPRi = Irej
         LI = 5
      END IF

      LO = Lout
      Irej = 0

      IF ( LPRi.GT.4 ) WRITE (LO,*)
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            ' ==================================================='
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            '                                                    '
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            '   ----        PHOJET  19.1.2       ----   '
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            '                                                    '
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            ' ==================================================='
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &                         '     Authors: Ralph Engel         (KIT)'
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &                        '              Anatoli Fedynitch   (ICRR)'
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &                '              Johannes Ranft      (Siegen Univ.)'
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &                        '              Stefan Roesler      (CERN)'
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            ' ---------------------------------------------------'
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &                    '   bug reports, support and updates on:'
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &                    '     https://github.com/afedynitch/dpmjet'
      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            ' ==================================================='
      IF ( LPRi.GT.4 ) WRITE (LO,*) '   Date: 2019/07/09'
      IF ( LPRi.GT.4 ) WRITE (LO,*) '   Revision: 19.1.2'

      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &                         '   Code with interface to PYTHIA 6.4.27'

      IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            ' ==================================================='
      IF ( LPRi.GT.4 ) WRITE (LO,*)

C  standard initializations
      CALL PHO_DATINI
      CALL PHO_PARDAT
      IPRoce = 0
      dum = PHO_PMASS(0,-1)

C  multiparticle mapping tables (default selection)
      CALL PHO_INITPMAP(-1,0,0,0)

C  initialize standard PDFs
C  proton
      CALL PHO_SETPDF(2212,idum,2,1,0,0,-1)
      CALL PHO_SETPDF(-2212,idum,2,1,0,0,-1)
C  neutron
      CALL PHO_SETPDF(2112,idum,2,1,0,0,-1)
      CALL PHO_SETPDF(-2112,idum,2,1,0,0,-1)
C  lambda
      CALL PHO_SETPDF(3122,idum,2,1,0,0,-1)
      CALL PHO_SETPDF(-3122,idum,2,1,0,0,-1)
C  lambda
      CALL PHO_SETPDF(3122,idum,2,1,0,0,-1)
      CALL PHO_SETPDF(-3122,idum,2,1,0,0,-1)
C  sigmamp
      CALL PHO_SETPDF(3112,idum,2,1,0,0,-1)
      CALL PHO_SETPDF(-3112,idum,2,1,0,0,-1)
C  photon
      CALL PHO_SETPDF(22,idum,5,3,0,0,-1)
C  pomeron
      CALL PHO_SETPDF(990,idum,4,0,0,0,-1)
C  pions
      CALL PHO_SETPDF(211,idum,5,2,0,0,-1)
      CALL PHO_SETPDF(-211,idum,5,2,0,0,-1)
      CALL PHO_SETPDF(111,idum,5,2,0,0,-1)
C  kaons
      CALL PHO_SETPDF(321,idum,5,2,0,0,-1)
      CALL PHO_SETPDF(-321,idum,5,2,0,0,-1)
      CALL PHO_SETPDF(311,idum,5,2,0,0,-1)
      CALL PHO_SETPDF(-311,idum,5,2,0,0,-1)
      CALL PHO_SETPDF(130,idum,5,2,0,0,-1)
      CALL PHO_SETPDF(310,idum,5,2,0,0,-1)

C  nothing to be done
      IF ( Linp.LT.0 ) RETURN

C  main loop to read input cards
 100  READ (Linp,99010,END=200) cname , number

99010 FORMAT (A10,A69)
      IF ( cname.NE.'ENDINPUT  ' ) THEN
         IF ( cname.EQ.'STOP      ' ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'STOP'
            STOP
         ELSE IF ( cname.EQ.'COMMENT   ' ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A10,A69)') 'COMMENT   ' ,
     &           number
         ELSE IF ( cname(1:1).EQ.'*' ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A10,A69)') cname , number
         ELSE IF ( cname.EQ.'PTCUT     ' ) THEN
            READ (number,*) PARmdl(36) , PARmdl(37) , PARmdl(38) ,
     &                      PARmdl(39)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'PTCUT     ' , PARmdl(36) ,
     &           PARmdl(37) , PARmdl(38) , PARmdl(39)
         ELSE IF ( cname.EQ.'PROCESS   ' ) THEN
            READ (number,*) (IPRon(kk,1),kk=1,8)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'PROCESS   ' ,
     &           (IPRon(kk,1),kk=1,8)
         ELSE IF ( cname.EQ.'DIFF-PROC ' ) THEN
            READ (number,*) (itmp(kk),kk=0,11)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'DIFF-PROC ' ,
     &           (itmp(kk),kk=0,8)
            DO kk = 1 , 8
               IPRon(kk,itmp(0)) = itmp(kk)
            END DO
         ELSE IF ( cname.EQ.'SUBPROCESS' ) THEN
            READ (number,*) impro , ip , ion
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'SUBPROCESS' , impro , ip ,
     &           ion
            MH_pro_on(impro,ip,IDXmpar) = ion
         ELSE IF ( cname.EQ.'PARTICLE1 ' ) THEN
            READ (number,*) idpdg , pvir
            IHFls(1) = 1
            XPSub = 1.D0
            CALL PHO_SETPAR(1,idpdg,0,pvir)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'PARTICLE1  ' , idpdg , pvir
         ELSE IF ( cname.EQ.'PARTICLE2 ' ) THEN
            READ (number,*) idpdg , pvir
            IHFls(2) = 1
            XTSub = 1.D0
            CALL PHO_SETPAR(2,idpdg,0,pvir)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'PARTICLE2  ' , idpdg , pvir
         ELSE IF ( cname.EQ.'REMNANT1  ' ) THEN
            READ (number,*) idpdg , ifl1 , ifl2 , ival , xsub
            IHFls(1) = ival
            IHFld(1,1) = ifl1
            IHFld(1,2) = ifl2
            XPSub = xsub
            pvir = 0.D0
            CALL PHO_SETPAR(1,idpdg,-1,pvir)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'REMNANT1   ' , idpdg , ifl1 ,
     &           ifl2 , ival , xsub
         ELSE IF ( cname.EQ.'REMNANT2  ' ) THEN
            READ (number,*) idpdg , ifl1 , ifl2 , ival , xsub
            IHFls(2) = ival
            IHFld(2,1) = ifl1
            IHFld(2,2) = ifl2
            XTSub = xsub
            pvir = 0.D0
            CALL PHO_SETPAR(2,idpdg,-1,pvir)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'REMNANT2   ' , idpdg , ifl1 ,
     &           ifl2 , ival , xsub
         ELSE IF ( cname.EQ.'PDF       ' ) THEN
            READ (number,*) idpdg , ipar , iset , iext
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'PDF        ' , idpdg , ipar ,
     &           iset , iext
            CALL PHO_SETPDF(idpdg,idum,ipar,iset,iext,0,-1)
         ELSE IF ( cname.EQ.'SETMODEL  ' ) THEN
            READ (number,*) i , ival
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'SETMODEL   ' , i , ival
            CALL PHO_SETMDL(i,ival,1)
         ELSE IF ( cname.EQ.'SETPARAM  ' ) THEN
            READ (number,*) i , parnew
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'SETPARAM   ' , i , parnew
            PARmdl(i) = parnew
         ELSE IF ( cname.EQ.'DEBUG     ' ) THEN
            READ (number,*) idebf , idebn , idlev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'DEBUG      ' , idebf ,
     &           idebn , idlev
            CALL PHO_TRACE(idebf,idebn,idlev)
         ELSE IF ( cname.EQ.'TRACE     ' ) THEN
            READ (number,*) idebf , idlev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'TRACE      ' , idebf , idlev
            IDEb(idebf) = idlev
         ELSE IF ( cname.EQ.'SETICUT   ' ) THEN
            READ (number,*) i , icut
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'SETICUT    ' , i , icut
            ISWcut(i) = icut
         ELSE IF ( cname.EQ.'SETFCUT   ' ) THEN
            READ (number,*) i , parnew
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'SETFCUT    ' , i , parnew
            HSWcut(i) = parnew
         ELSE IF ( cname.EQ.'LUND-MSTU ' ) THEN
            READ (number,*) i , ival
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'LUND-MSTU  ' , i , ival
            MSTu(i) = ival
         ELSE IF ( cname.EQ.'LUND-MSTJ ' ) THEN
            READ (number,*) i , ival
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'LUND-MSTJ  ' , i , ival
            MSTj(i) = ival
         ELSE IF ( cname.EQ.'LUND-PARJ ' ) THEN
            READ (number,*) i , ee
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'LUND-PARJ  ' , i , ee
            PARj(i) = REAL(ee)
         ELSE IF ( cname.EQ.'LUND-PARU ' ) THEN
            READ (number,*) i , ee
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'LUND-PARU  ' , i , ee
            PARu(i) = REAL(ee)
         ELSE IF ( cname.EQ.'LUND-DECAY' ) THEN
            READ (number,*) id , ion
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'LUND-DECAY ' , id , ion

            kc = PYCOMP(id)

            MDCy(kc,1) = ion
         ELSE IF ( cname.EQ.'PSOFTMIN  ' ) THEN
            READ (number,*) PSOmin
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'PSOFTMIN   ' , PSOmin
         ELSE IF ( cname.EQ.'INTPREC   ' ) THEN
            READ (number,*) NGAup1 , NGAup2 , NGAuet , NGAuin , NGAuso
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'INTPREC    ' , NGAup1 ,
     &           NGAup2 , NGAuet , NGAuin , NGAuso

C  PDF test utility
         ELSE IF ( cname.EQ.'PDFTEST   ' ) THEN
            READ (number,*) idpdg , scale2 , pvirt2
            pvirt2 = ABS(pvirt2)
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'PDFTEST   ' , idpdg , ' ' ,
     &           scale2 , ' ' , pvirt2
            CALL PHO_PDFTST(idpdg,scale2,pvirt2)

C  mass cut on gamma-gamma or gamma-hadron system
         ELSE IF ( cname.EQ.'ECMS-CUT  ' ) THEN
            READ (number,*) ECMin , ECMax
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'ECMS-CUT  ' , ECMin , ECMax

C  beam lepton (anti-)tagging system
         ELSE IF ( cname.EQ.'TAG-METHOD' ) THEN
            READ (number,*) ITAg1 , ITAg2
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'TAG-METHOD' , ITAg1 , ITAg2
         ELSE IF ( cname.EQ.'E-TAG1    ' ) THEN
            READ (number,*) EEMin1 , YMIn1 , YMAx1 , Q2Min1 , Q2Max1 ,
     &                      THMin1 , THMax1
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'E-TAG1    ' , EEMin1 ,
     &           YMIn1 , YMAx1 , Q2Min1 , Q2Max1 , THMin1 , THMax1
         ELSE IF ( cname.EQ.'E-TAG2    ' ) THEN
            READ (number,*) EEMin2 , YMIn2 , YMAx2 , Q2Min2 , Q2Max2 ,
     &                      THMin2 , THMax2
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'E-TAG2    ' , EEMin2 ,
     &           YMIn2 , YMAx2 , Q2Min2 , Q2Max2 , THMin2 , THMax2

C  sampling of gamma-p events in ep (HERA)
         ELSE IF ( (cname.EQ.'WW-HERA   ') .OR. (cname.EQ.'GP-HERA   ')
     &             ) THEN
            READ (number,*) ee1 , ee2 , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'GP-HERA   ' , ee1 , ee2 , nev
            IF ( YMAx2.LT.0.D0 ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,*)
     &               ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
            ELSE
               CALL PHO_GPHERA(nev,ee1,ee2)
               KEVent = 0
            END IF

C  sampling of gamma-gamma events in e+e- (LEP)
         ELSE IF ( (cname.EQ.'GG-EPEM   ') .OR. (cname.EQ.'WW-EPEM   ')
     &             ) THEN
            READ (number,*) ee1 , ee2 , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'GG-EPEM   ' , ee1 , ee2 , nev
            IF ( (YMAx1.LT.0.D0) .OR. (YMAx2.LT.0.D0) ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,*)
     &               ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
            ELSE
               CALL PHO_GGEPEM(-1,ee1,ee2)
               CALL PHO_GGEPEM(nev,ee1,ee2)
               CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
               KEVent = 0
            END IF

C  sampling of gamma-gamma in heavy-ion collisions
         ELSE IF ( cname.EQ.'GG-HION-F ' ) THEN
            READ (number,*) ee , na , nz , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'GG-HION-F ' , ee , na , nz ,
     &           nev
            IF ( (YMAx1.LT.0.D0) .OR. (YMAx2.LT.0.D0) ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,*)
     &               ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
            ELSE
               CALL PHO_GGHIOF(nev,ee,na,nz)
               KEVent = 0
            END IF
         ELSE IF ( cname.EQ.'GG-HION-G ' ) THEN
            READ (number,*) ee , na , nz , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'GG-HION-G ' , ee , na , nz ,
     &           nev
            IF ( (YMAx1.LT.0.D0) .OR. (YMAx2.LT.0.D0) ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,*)
     &               ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
            ELSE
               CALL PHO_GGHIOG(nev,ee,na,nz)
               KEVent = 0
            END IF

C  sampling of gamma-hadron events in heavy ion collisions
         ELSE IF ( cname.EQ.'GH-HION-F ' ) THEN
            READ (number,*) ee , na , nz , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'GH-HION-F ' , ee , na , nz ,
     &           nev
            IF ( (YMAx1.LT.0.D0) .OR. (YMAx2.LT.0.D0) ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,*)
     &               ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
            ELSE
               CALL PHO_GHHIOF(nev,ee,na,nz)
               KEVent = 0
            END IF

C  sampling of hadron-gamma events in hadron - heavy ion collisions
         ELSE IF ( cname.EQ.'HG-HIAS-F ' ) THEN
            READ (number,*) ep , ee , na , nz , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'HG-HIAS-F ' , ep , ee , na ,
     &           nz , nev
            IF ( YMAx2.LT.0.D0 ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,*)
     &               ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
            ELSE
               CALL PHO_GHHIAS(nev,ep,ee,na,nz)
               KEVent = 0
            END IF

C  sampling of photoproduction events e+e-, backscattered laser
         ELSE IF ( cname.EQ.'BLASER    ' ) THEN
            READ (number,*) ee1 , ee2 , pl_lam_1 , pl_lam_2 , x_1 ,
     &                      x_2 , rho , a , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'BLASER    ' , ee1 , ee2 ,
     &           pl_lam_1 , pl_lam_2 , x_1 , x_2 , rho , a , nev
            CALL PHO_GGBLSR(nev,ee1,ee2,pl_lam_1,pl_lam_2,x_1,x_2,rho,a)
            KEVent = 0

C  sampling of photoproduction events beamstrahlung
         ELSE IF ( cname.EQ.'BEAMST    ' ) THEN
            READ (number,*) ee1 , ypsi , sigx , sigy , sigz , aeb , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'BEAMST    ' , ee1 , ypsi ,
     &           sigx , sigy , sigz , aeb , nev
            IF ( YMAx1.LT.0.D0 ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,*)
     &               ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
            ELSE
               CALL PHO_GGBEAM(nev,ee1,ypsi,sigx,sigy,sigz,aeb)
               KEVent = 0
            END IF

C  fixed-energy events in LAB system of particle 2
         ELSE IF ( cname.EQ.'EVENT-LAB ' ) THEN
            READ (number,*) plab , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'EVENT-LAB ' , plab , nev
            CALL PHO_FIXLAB(plab,nev)
            KEVent = 0

C  fixed-energy events in CM system
         ELSE IF ( cname.EQ.'EVENT-CMS ' ) THEN
            READ (number,*) ECM , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'EVENT-CMS ' , ECM , nev
            pmass1 = PHO_PMASS(IFPab(1),0) - SQRT(PVIrt(1))
            pmass2 = PHO_PMASS(IFPab(2),0) - SQRT(PVIrt(2))
            CALL PHO_PECMS(1,pmass1,pmass2,ECM,PCM,ee)
            e1 = ee
            e2 = ECM - ee
            theta = 0.D0
            phi = 0.D0
            CALL PHO_FIXCOL(e1,e2,theta,phi,nev)
            KEVent = 0

C  fixed-energy events for collider setup with crossing angle
         ELSE IF ( cname.EQ.'EVENT-COLL' ) THEN
            READ (number,*) e1 , e2 , theta , phi , nev
            IF ( LPRi.GT.4 ) WRITE (LO,*) 'EVENT-COLL' , e1 , e2 ,
     &           theta , phi , nev
            CALL PHO_FIXCOL(e1,e2,theta,phi,nev)
            KEVent = 0

C  unknown data card
         ELSE
            IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            'PHO_INIT: unknown data card: ' , cname , number
         END IF

         GOTO 100
      END IF
 200  IF ( LPRi.GT.4 ) WRITE (LO,*) ' RETURN'

      END SUBROUTINE


MODULE icethd_do
  USE dom_oce
  USE phycst
  USE sbc_oce, ONLY: sss_m
  USE sbc_ice, ONLY: utau_ice, vtau_ice
  USE ice1D
  USE ice
  USE icetab
  USE icectl
  USE icethd_ent
  USE icevar
  USE icethd_sal
  USE in_out_manager
  USE lib_mpp
  USE lib_fortran
  USE lbclnk
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: ice_thd_do
  PUBLIC :: ice_thd_do_init
  REAL(KIND = wp) :: rn_hinew
  LOGICAL :: ln_frazil
  REAL(KIND = wp) :: rn_maxfraz
  REAL(KIND = wp) :: rn_vfraz
  REAL(KIND = wp) :: rn_Cfraz
  CONTAINS
  SUBROUTINE ice_thd_do
    INTEGER :: ji, jj, jk, jl
    INTEGER :: iter
    REAL(KIND = wp) :: ztmelts, zfrazb, zweight, zde
    REAL(KIND = wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf
    REAL(KIND = wp) :: ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd, zhicrit
    REAL(KIND = wp) :: zQm
    REAL(KIND = wp) :: zEi
    REAL(KIND = wp) :: zEw
    REAL(KIND = wp) :: zfmdt
    REAL(KIND = wp) :: zv_newfra
    INTEGER, DIMENSION(jpij) :: jcat
    REAL(KIND = wp), DIMENSION(jpij) :: zswinew
    REAL(KIND = wp), DIMENSION(jpij) :: zv_newice
    REAL(KIND = wp), DIMENSION(jpij) :: za_newice
    REAL(KIND = wp), DIMENSION(jpij) :: zh_newice
    REAL(KIND = wp), DIMENSION(jpij) :: ze_newice
    REAL(KIND = wp), DIMENSION(jpij) :: zs_newice
    REAL(KIND = wp), DIMENSION(jpij) :: zo_newice
    REAL(KIND = wp), DIMENSION(jpij) :: zdv_res
    REAL(KIND = wp), DIMENSION(jpij) :: zda_res
    REAL(KIND = wp), DIMENSION(jpij) :: zv_frazb
    REAL(KIND = wp), DIMENSION(jpij) :: zvrel_1d
    REAL(KIND = wp), DIMENSION(jpij, jpl) :: zv_b
    REAL(KIND = wp), DIMENSION(jpij, jpl) :: za_b
    REAL(KIND = wp), DIMENSION(jpij, nlay_i, jpl) :: ze_i_2d
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zvrel
    REAL(KIND = wp) :: zcai = 1.4E-3_wp
    IF (ln_icediachk) CALL ice_cons_hsm(0, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
    CALL ice_var_agg(1)
    CALL ice_var_glo2eqv
    !$ACC KERNELS
    zvrel(:, :) = 0._wp
    !$ACC END KERNELS
    WHERE (qlead(:, :) < 0._wp)
      ht_i_new(:, :) = rn_hinew
    ELSEWHERE
      ht_i_new(:, :) = 0._wp
    END WHERE
    IF (ln_frazil) THEN
      !$ACC KERNELS
      ht_i_new(:, :) = 0._wp
      zhicrit = 0.04
      ztwogp = 2. * rau0 / (grav * 0.3 * (rau0 - rhoi))
      zsqcd = 1.0 / SQRT(1.3 * zcai)
      zgamafr = 0.03
      !$ACC END KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          IF (qlead(ji, jj) < 0._wp .AND. tau_icebfr(ji, jj) == 0._wp) THEN
            ztaux = (utau_ice(ji - 1, jj) * umask(ji - 1, jj, 1) + utau_ice(ji, jj) * umask(ji, jj, 1)) * 0.5_wp
            ztauy = (vtau_ice(ji, jj - 1) * vmask(ji, jj - 1, 1) + vtau_ice(ji, jj) * vmask(ji, jj, 1)) * 0.5_wp
            ztenagm = SQRT(SQRT(ztaux * ztaux + ztauy * ztauy))
            rswitch = MAX(0._wp, SIGN(1._wp, ztenagm - epsi10))
            zvfrx = rswitch * zgamafr * zsqcd * ztaux / MAX(ztenagm, epsi10)
            zvfry = rswitch * zgamafr * zsqcd * ztauy / MAX(ztenagm, epsi10)
            zvgx = (u_ice(ji - 1, jj) * umask(ji - 1, jj, 1) + u_ice(ji, jj) * umask(ji, jj, 1)) * 0.5_wp
            zvgy = (v_ice(ji, jj - 1) * vmask(ji, jj - 1, 1) + v_ice(ji, jj) * vmask(ji, jj, 1)) * 0.5_wp
            rswitch = MAX(0._wp, SIGN(1._wp, at_i(ji, jj) - epsi10))
            zvrel2 = MAX((zvfrx - zvgx) * (zvfrx - zvgx) + (zvfry - zvgy) * (zvfry - zvgy), 0.15 * 0.15) * rswitch
            zvrel(ji, jj) = SQRT(zvrel2)
            ht_i_new(ji, jj) = zhicrit + (zhicrit + 0.1) / ((zhicrit + 0.1) * (zhicrit + 0.1) - zhicrit * zhicrit) * ztwogp * zvrel2
            iter = 1
            DO WHILE (iter < 20)
              zf = (ht_i_new(ji, jj) - zhicrit) * (ht_i_new(ji, jj) * ht_i_new(ji, jj) - zhicrit * zhicrit) - ht_i_new(ji, jj) * zhicrit * ztwogp * zvrel2
              zfp = (ht_i_new(ji, jj) - zhicrit) * (3.0 * ht_i_new(ji, jj) + zhicrit) - zhicrit * ztwogp * zvrel2
              ht_i_new(ji, jj) = ht_i_new(ji, jj) - zf / MAX(zfp, epsi20)
              iter = iter + 1
            END DO
          END IF
        END DO
      END DO
      CALL lbc_lnk_multi(zvrel, 'T', 1., ht_i_new, 'T', 1.)
    END IF
    npti = 0
    nptidx(:) = 0
    !$ACC KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        IF (qlead(ji, jj) < 0._wp .AND. tau_icebfr(ji, jj) == 0._wp) THEN
          npti = npti + 1
          nptidx(npti) = (jj - 1) * jpi + ji
        END IF
      END DO
    END DO
    !$ACC END KERNELS
    IF (npti > 0) THEN
      CALL tab_2d_1d(npti, nptidx(1 : npti), at_i_1d(1 : npti), at_i)
      CALL tab_3d_2d(npti, nptidx(1 : npti), a_i_2d(1 : npti, 1 : jpl), a_i(:, :, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), v_i_2d(1 : npti, 1 : jpl), v_i(:, :, :))
      CALL tab_3d_2d(npti, nptidx(1 : npti), sv_i_2d(1 : npti, 1 : jpl), sv_i(:, :, :))
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          CALL tab_2d_1d(npti, nptidx(1 : npti), ze_i_2d(1 : npti, jk, jl), e_i(:, :, jk, jl))
        END DO
      END DO
      CALL tab_2d_1d(npti, nptidx(1 : npti), qlead_1d(1 : npti), qlead)
      CALL tab_2d_1d(npti, nptidx(1 : npti), t_bo_1d(1 : npti), t_bo)
      CALL tab_2d_1d(npti, nptidx(1 : npti), sfx_opw_1d(1 : npti), sfx_opw)
      CALL tab_2d_1d(npti, nptidx(1 : npti), wfx_opw_1d(1 : npti), wfx_opw)
      CALL tab_2d_1d(npti, nptidx(1 : npti), zh_newice(1 : npti), ht_i_new)
      CALL tab_2d_1d(npti, nptidx(1 : npti), zvrel_1d(1 : npti), zvrel)
      CALL tab_2d_1d(npti, nptidx(1 : npti), hfx_thd_1d(1 : npti), hfx_thd)
      CALL tab_2d_1d(npti, nptidx(1 : npti), hfx_opw_1d(1 : npti), hfx_opw)
      CALL tab_2d_1d(npti, nptidx(1 : npti), rn_amax_1d(1 : npti), rn_amax_2d)
      CALL tab_2d_1d(npti, nptidx(1 : npti), sss_1d(1 : npti), sss_m)
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          WHERE (v_i_2d(1 : npti, jl) > 0._wp)
            ze_i_2d(1 : npti, jk, jl) = ze_i_2d(1 : npti, jk, jl) / v_i_2d(1 : npti, jl) * REAL(nlay_i)
          ELSEWHERE
            ze_i_2d(1 : npti, jk, jl) = 0._wp
          END WHERE
        END DO
      END DO
      !$ACC KERNELS
      zv_b(1 : npti, :) = v_i_2d(1 : npti, :)
      za_b(1 : npti, :) = a_i_2d(1 : npti, :)
      !$ACC END KERNELS
      SELECT CASE (nn_icesal)
      CASE (1)
        zs_newice(1 : npti) = rn_icesal
      CASE (2)
        !$ACC KERNELS
        DO ji = 1, npti
          zs_newice(ji) = MIN(4.606 + 0.91 / zh_newice(ji), rn_simax, 0.5 * sss_1d(ji))
        END DO
        !$ACC END KERNELS
      CASE (3)
        zs_newice(1 : npti) = 2.3
      END SELECT
      !$ACC KERNELS
      DO ji = 1, npti
        ztmelts = - rTmlt * zs_newice(ji)
        ze_newice(ji) = rhoi * (rcpi * (ztmelts - (t_bo_1d(ji) - rt0)) + rLfus * (1.0 - ztmelts / MIN(t_bo_1d(ji) - rt0, - epsi10)) - rcp * ztmelts)
      END DO
      !$ACC END KERNELS
      zo_newice(1 : npti) = 0._wp
      !$ACC KERNELS
      DO ji = 1, npti
        zEi = - ze_newice(ji) * r1_rhoi
        zEw = rcp * (t_bo_1d(ji) - rt0)
        zdE = zEi - zEw
        zfmdt = - qlead_1d(ji) / zdE
        zv_newice(ji) = - zfmdt * r1_rhoi
        zQm = zfmdt * zEw
        hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * zEw * r1_rdtice
        hfx_opw_1d(ji) = hfx_opw_1d(ji) - zfmdt * zdE * r1_rdtice
        wfx_opw_1d(ji) = wfx_opw_1d(ji) - zv_newice(ji) * rhoi * r1_rdtice
        sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoi * zs_newice(ji) * r1_rdtice
      END DO
      !$ACC END KERNELS
      zv_frazb(1 : npti) = 0._wp
      IF (ln_frazil) THEN
        DO ji = 1, npti
          rswitch = 1._wp - MAX(0._wp, SIGN(1._wp, - at_i_1d(ji)))
          zfrazb = rswitch * (TANH(rn_Cfraz * (zvrel_1d(ji) - rn_vfraz)) + 1.0) * 0.5 * rn_maxfraz
          zv_frazb(ji) = zfrazb * zv_newice(ji)
          zv_newice(ji) = (1.0 - zfrazb) * zv_newice(ji)
        END DO
      END IF
      !$ACC KERNELS
      DO ji = 1, npti
        za_newice(ji) = zv_newice(ji) / zh_newice(ji)
      END DO
      DO ji = 1, npti
        IF (za_newice(ji) > (rn_amax_1d(ji) - at_i_1d(ji))) THEN
          zda_res(ji) = za_newice(ji) - (rn_amax_1d(ji) - at_i_1d(ji))
          zdv_res(ji) = zda_res(ji) * zh_newice(ji)
          za_newice(ji) = za_newice(ji) - zda_res(ji)
          zv_newice(ji) = zv_newice(ji) - zdv_res(ji)
        ELSE
          zda_res(ji) = 0._wp
          zdv_res(ji) = 0._wp
        END IF
      END DO
      DO jl = 1, jpl
        DO ji = 1, npti
          IF (zh_newice(ji) > hi_max(jl - 1) .AND. zh_newice(ji) <= hi_max(jl)) THEN
            a_i_2d(ji, jl) = a_i_2d(ji, jl) + za_newice(ji)
            v_i_2d(ji, jl) = v_i_2d(ji, jl) + zv_newice(ji)
            jcat(ji) = jl
          END IF
        END DO
      END DO
      !$ACC END KERNELS
      at_i_1d(1 : npti) = SUM(a_i_2d(1 : npti, :), dim = 2)
      !$ACC KERNELS
      DO ji = 1, npti
        jl = jcat(ji)
        zswinew(ji) = MAX(0._wp, SIGN(1._wp, - za_b(ji, jl)))
      END DO
      DO jk = 1, nlay_i
        DO ji = 1, npti
          jl = jcat(ji)
          rswitch = MAX(0._wp, SIGN(1._wp, v_i_2d(ji, jl) - epsi20))
          ze_i_2d(ji, jk, jl) = zswinew(ji) * ze_newice(ji) + (1.0 - zswinew(ji)) * (ze_newice(ji) * zv_newice(ji) + ze_i_2d(ji, jk, jl) * zv_b(ji, jl)) * rswitch / MAX(v_i_2d(ji, jl), epsi20)
        END DO
      END DO
      !$ACC END KERNELS
      DO jl = 1, jpl
        !$ACC KERNELS
        h_i_old(1 : npti, 0 : nlay_i + 1) = 0._wp
        eh_i_old(1 : npti, 0 : nlay_i + 1) = 0._wp
        DO jk = 1, nlay_i
          DO ji = 1, npti
            h_i_old(ji, jk) = v_i_2d(ji, jl) * r1_nlay_i
            eh_i_old(ji, jk) = ze_i_2d(ji, jk, jl) * h_i_old(ji, jk)
          END DO
        END DO
        DO ji = 1, npti
          rswitch = MAX(0._wp, SIGN(1._wp, at_i_1d(ji) - epsi20))
          zv_newfra = rswitch * (zdv_res(ji) + zv_frazb(ji)) * a_i_2d(ji, jl) / MAX(at_i_1d(ji), epsi20)
          a_i_2d(ji, jl) = rswitch * a_i_2d(ji, jl)
          v_i_2d(ji, jl) = v_i_2d(ji, jl) + zv_newfra
          h_i_old(ji, nlay_i + 1) = zv_newfra
          eh_i_old(ji, nlay_i + 1) = ze_newice(ji) * zv_newfra
        END DO
        !$ACC END KERNELS
        CALL ice_thd_ent(ze_i_2d(1 : npti, :, jl))
      END DO
      !$ACC KERNELS
      DO jl = 1, jpl
        DO ji = 1, npti
          sv_i_2d(ji, jl) = sv_i_2d(ji, jl) + zs_newice(ji) * (v_i_2d(ji, jl) - zv_b(ji, jl))
        END DO
      END DO
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          ze_i_2d(1 : npti, jk, jl) = ze_i_2d(1 : npti, jk, jl) * v_i_2d(1 : npti, jl) * r1_nlay_i
        END DO
      END DO
      !$ACC END KERNELS
      CALL tab_2d_3d(npti, nptidx(1 : npti), a_i_2d(1 : npti, 1 : jpl), a_i(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), v_i_2d(1 : npti, 1 : jpl), v_i(:, :, :))
      CALL tab_2d_3d(npti, nptidx(1 : npti), sv_i_2d(1 : npti, 1 : jpl), sv_i(:, :, :))
      DO jl = 1, jpl
        DO jk = 1, nlay_i
          CALL tab_1d_2d(npti, nptidx(1 : npti), ze_i_2d(1 : npti, jk, jl), e_i(:, :, jk, jl))
        END DO
      END DO
      CALL tab_1d_2d(npti, nptidx(1 : npti), sfx_opw_1d(1 : npti), sfx_opw)
      CALL tab_1d_2d(npti, nptidx(1 : npti), wfx_opw_1d(1 : npti), wfx_opw)
      CALL tab_1d_2d(npti, nptidx(1 : npti), hfx_thd_1d(1 : npti), hfx_thd)
      CALL tab_1d_2d(npti, nptidx(1 : npti), hfx_opw_1d(1 : npti), hfx_opw)
    END IF
    IF (ln_icediachk) CALL ice_cons_hsm(1, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
  END SUBROUTINE ice_thd_do
  SUBROUTINE ice_thd_do_init
    INTEGER :: ios
    NAMELIST /namthd_do/ rn_hinew, ln_frazil, rn_maxfraz, rn_vfraz, rn_Cfraz
    REWIND(UNIT = numnam_ice_ref)
    READ(numnam_ice_ref, namthd_do, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namthd_do in reference namelist', lwp)
    REWIND(UNIT = numnam_ice_cfg)
    READ(numnam_ice_cfg, namthd_do, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namthd_do in configuration namelist', lwp)
    IF (lwm) WRITE(numoni, namthd_do)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'ice_thd_do_init: Ice growth in open water'
      WRITE(numout, FMT = *) '~~~~~~~~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namthd_do:'
      WRITE(numout, FMT = *) '      ice thickness for lateral accretion                       rn_hinew   = ', rn_hinew
      WRITE(numout, FMT = *) '      Frazil ice thickness as a function of wind or not         ln_frazil  = ', ln_frazil
      WRITE(numout, FMT = *) '      Maximum proportion of frazil ice collecting at bottom     rn_maxfraz = ', rn_maxfraz
      WRITE(numout, FMT = *) '      Threshold relative drift speed for collection of frazil   rn_vfraz   = ', rn_vfraz
      WRITE(numout, FMT = *) '      Squeezing coefficient for collection of frazil            rn_Cfraz   = ', rn_Cfraz
    END IF
    IF (rn_hinew < rn_himin) CALL ctl_stop('ice_thd_do_init : rn_hinew should be >= rn_himin')
  END SUBROUTINE ice_thd_do_init
END MODULE icethd_do