!>  \file sfc_nst.f
!!  This file contains the GFS NSST model.

!> This module contains the CCPP-compliant GFS near-surface sea temperature scheme.
      module sfc_nst

      contains

! \brief This subroutine is empty since there are no procedures that need to be done to initialize the GFS NSST code.
!! This subroutine is empty since there are no procedures that need to be done to initialize the GFS NSST code.
!!
!! \section arg_table_sfc_nst_init  Argument Table
!!
      subroutine sfc_nst_init
      end subroutine sfc_nst_init

! \brief This subroutine is empty since there are no procedures that need to be done to finalize the GFS NSST code.
!! This subroutine is empty since there are no procedures that need to be done to finalize the GFS NSST code.
!! \section arg_table_sfc_nst_finalize  Argument Table
!!
      subroutine sfc_nst_finalize
      end subroutine sfc_nst_finalize

!>\defgroup gfs_nst_main GFS sfc_nst Main
!> \brief This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile.
!! \section arg_table_sfc_nst_run Argument Table
!! | local_name     | standard_name                                                                | long_name                                                   | units         | rank | type      |    kind   | intent | optional |
!! |----------------|------------------------------------------------------------------------------|-------------------------------------------------------------|---------------|------|-----------|-----------|--------|----------|
!! | im             | horizontal_loop_extent                                                       | horizontal loop extent                                      | count         |    0 | integer   |           | in     | F        |
!! | ps             | surface_air_pressure                                                         | surface pressure                                            | Pa            |    1 | real      | kind_phys | in     | F        |
!! | u1             | x_wind_at_lowest_model_layer                                                 | x component of surface layer wind                           | m s-1         |    1 | real      | kind_phys | in     | F        |
!! | v1             | y_wind_at_lowest_model_layer                                                 | y component of surface layer wind                           | m s-1         |    1 | real      | kind_phys | in     | F        |
!! | t1             | air_temperature_at_lowest_model_layer                                        | surface layer mean temperature                              | K             |    1 | real      | kind_phys | in     | F        |
!! | q1             | water_vapor_specific_humidity_at_lowest_model_layer                          | surface layer mean specific humidity                        | kg kg-1       |    1 | real      | kind_phys | in     | F        |
!! | tref           | sea_surface_reference_temperature                                            | reference/foundation temperature                            | K             |    1 | real      | kind_phys | in     | F        |
!! | cm             | surface_drag_coefficient_for_momentum_in_air                                 | surface exchange coeff for momentum                         | none          |    1 | real      | kind_phys | in     | F        |
!! | ch             | surface_drag_coefficient_for_heat_and_moisture_in_air                        | surface exchange coeff heat & moisture                      | none          |    1 | real      | kind_phys | in     | F        |
!! | prsl1          | air_pressure_at_lowest_model_layer                                           | surface layer mean pressure                                 | Pa            |    1 | real      | kind_phys | in     | F        |
!! | prslki         | ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer | Exner function ratio bt midlayer and interface at 1st layer | ratio         |    1 | real      | kind_phys | in     | F        |
!! | islimsk        | sea_land_ice_mask                                                            | landmask: sea/land/ice=0/1/2                                | flag          |    1 | integer   |           | in     | F        |
!! | xlon           | longitude                                                                    | longitude                                                   | radians       |    1 | real      | kind_phys | in     | F        |
!! | sinlat         | sine_of_latitude                                                             | sine of latitude                                            | none          |    1 | real      | kind_phys | in     | F        |
!! | stress         | surface_wind_stress                                                          | wind stress                                                 | m2 s-2        |    1 | real      | kind_phys | in     | F        |
!! | sfcemis        | surface_longwave_emissivity                                                  | surface longwave emissivity                                 | frac          |    1 | real      | kind_phys | in     | F        |
!! | dlwflx         | surface_downwelling_longwave_flux_absorbed_by_ground                         | total sky sfc downward lw flux absorbed by the ocean        | W m-2         |    1 | real      | kind_phys | in     | F        |
!! | sfcnsw         | surface_net_downwelling_shortwave_flux                                       | total sky sfc net sw flx into ocean                         | W m-2         |    1 | real      | kind_phys | in     | F        |
!! | rain           | nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep       | nonnegative precipitation amount on dyn time step           | m             |    1 | real      | kind_phys | in     | F        |
!! | timestep       | time_step_for_dynamics                                                       | timestep interval                                           | s             |    0 | real      | kind_phys | in     | F        |
!! | kdt            | index_of_time_step                                                           | current time step index                                     | index         |    0 | integer   |           | in     | F        |
!! | solhr          | forecast_hour                                                                | fcst hour at the end of prev time step                      | h             |    0 | real      | kind_phys | in     | F        |
!! | xcosz          | instantaneous_cosine_of_zenith_angle                                         | cosine of solar zenith angle                                | none          |    1 | real      | kind_phys | in     | F        |
!! | ddvel          | surface_wind_enhancement_due_to_convection                                   | wind enhancement due to convection                          | m s-1         |    1 | real      | kind_phys | in     | F        |
!! | flag_iter      | flag_for_iteration                                                           | flag for iteration                                          | flag          |    1 | logical   |           | in     | F        |
!! | flag_guess     | flag_for_guess_run                                                           | flag for guess run                                          | flag          |    1 | logical   |           | in     | F        |
!! | nstf_name1     | flag_for_nsstm_run                                                           | NSSTM flag: off/uncoupled/coupled=0/1/2                     | flag          |    0 | integer   |           | in     | F        |
!! | nstf_name4     | vertical_temperature_average_range_lower_bound                               | zsea1                                                       | mm            |    0 | integer   |           | in     | F        |
!! | nstf_name5     | vertical_temperature_average_range_upper_bound                               | zsea2                                                       | mm            |    0 | integer   |           | in     | F        |
!! | lprnt          | flag_print                                                                   | flag for printing diagnostics to output                     | flag          |    0 | logical   |           | in     | F        |
!! | ipr            | horizontal_index_of_printed_column                                           | horizontal index of printed column                          | index         |    0 | integer   |           | in     | F        |
!! | tskin          | surface_skin_temperature_for_nsst                                            | ocean surface skin temperature                              | K             |    1 | real      | kind_phys | inout  | F        |
!! | tsurf          | surface_skin_temperature_after_iteration                                     | ocean surface skin temperature for guess run                | K             |    1 | real      | kind_phys | inout  | F        |
!! | xt             | diurnal_thermocline_layer_heat_content                                       | heat content in diurnal thermocline layer                   | K m           |    1 | real      | kind_phys | inout  | F        |
!! | xs             | sea_water_salinity                                                           | salinity  content in diurnal thermocline layer              | ppt m         |    1 | real      | kind_phys | inout  | F        |
!! | xu             | diurnal_thermocline_layer_x_current                                          | u-current content in diurnal thermocline layer              | m2 s-1        |    1 | real      | kind_phys | inout  | F        |
!! | xv             | diurnal_thermocline_layer_y_current                                          | v-current content in diurnal thermocline layer              | m2 s-1        |    1 | real      | kind_phys | inout  | F        |
!! | xz             | diurnal_thermocline_layer_thickness                                          | diurnal thermocline layer thickness                         | m             |    1 | real      | kind_phys | inout  | F        |
!! | zm             | ocean_mixed_layer_thickness                                                  | mixed layer thickness                                       | m             |    1 | real      | kind_phys | inout  | F        |
!! | xtts           | sensitivity_of_dtl_heat_content_to_surface_temperature                       | d(xt)/d(ts)                                                 | m             |    1 | real      | kind_phys | inout  | F        |
!! | xzts           | sensitivity_of_dtl_thickness_to_surface_temperature                          | d(xz)/d(ts)                                                 | m K-1         |    1 | real      | kind_phys | inout  | F        |
!! | dt_cool        | sub-layer_cooling_amount                                                     | sub-layer cooling amount                                    | K             |    1 | real      | kind_phys | inout  | F        |
!! | z_c            | sub-layer_cooling_thickness                                                  | sub-layer cooling thickness                                 | m             |    1 | real      | kind_phys | inout  | F        |
!! | c_0            | coefficient_c_0                                                              | coefficient1 to calculate d(tz)/d(ts)                       | none          |    1 | real      | kind_phys | inout  | F        |
!! | c_d            | coefficient_c_d                                                              | coefficient2 to calculate d(tz)/d(ts)                       | none          |    1 | real      | kind_phys | inout  | F        |
!! | w_0            | coefficient_w_0                                                              | coefficient3 to calculate d(tz)/d(ts)                       | none          |    1 | real      | kind_phys | inout  | F        |
!! | w_d            | coefficient_w_d                                                              | coefficient4 to calculate d(tz)/d(ts)                       | none          |    1 | real      | kind_phys | inout  | F        |
!! | d_conv         | free_convection_layer_thickness                                              | thickness of free convection layer                          | m             |    1 | real      | kind_phys | inout  | F        |
!! | ifd            | index_of_dtlm_start                                                          | index to start dtlm run or not                              | index         |    1 | real      | kind_phys | inout  | F        |
!! | qrain          | sensible_heat_flux_due_to_rainfall                                           | sensible heat flux due to rainfall                          | W             |    1 | real      | kind_phys | inout  | F        |
!! | qsurf          | surface_specific_humidity                                                    | surface air saturation specific humidity                    | kg kg-1       |    1 | real      | kind_phys | inout  | F        |
!! | gflux          | upward_heat_flux_in_soil                                                     | soil heat flux                                              | W m-2         |    1 | real      | kind_phys | inout  | F        |
!! | cmm            | surface_drag_wind_speed_for_momentum_in_air                                  | surf mom exch coef time mean surf wind                      | m s-1         |    1 | real      | kind_phys | inout  | F        |
!! | chh            | surface_drag_mass_flux_for_heat_and_moisture_in_air                          | surf h&m exch coef time surf wind & density                 | kg m-2 s-1    |    1 | real      | kind_phys | inout  | F        |
!! | evap           | kinematic_surface_upward_latent_heat_flux                                    | kinematic from latent heat flux                             | kg kg-1 m s-1 |    1 | real      | kind_phys | inout  | F        |
!! | hflx           | kinematic_surface_upward_sensible_heat_flux                                  | kinematic sensible heat flux                                | K m s-1       |    1 | real      | kind_phys | inout  | F        |
!! | ep             | surface_upward_potential_latent_heat_flux                                    | potential evaporation                                       | W m-2         |    1 | real      | kind_phys | inout  | F        |
!! | errmsg         | ccpp_error_message                                                           | error message for error handling in CCPP                    | none          |    0 | character | len=*     | out    | F        |
!! | errflg         | ccpp_error_flag                                                              | error flag for error handling in CCPP                       | flag          |    0 | integer   |           | out    | F        |
!!
!! \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm
!> @{
      subroutine sfc_nst_run                                            &
     &     ( im, ps, u1, v1, t1, q1, tref, cm, ch,                      &
     &       prsl1, prslki, islimsk, xlon, sinlat, stress,              &
     &       sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, &
     &       ddvel, flag_iter, flag_guess, nstf_name1, nstf_name4,      &
     &       nstf_name5, lprnt, ipr,                                    &  ! inputs from here and above
     &       tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, &
     &       z_c,   c_0,   c_d,   w_0, w_d, d_conv, ifd, qrain,         &  ! in/outs from here and above
     &       qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg     &  ! outputs
     &      )

! ===================================================================== !
!  description:                                                         !
!                                                                       !
!                                                                       !
!  usage:                                                               !
!                                                                       !
!    call sfc_nst                                                       !
!       inputs:                                                         !
!          ( im, ps, u1, v1, t1, q1, tref, cm, ch,                      !
!            prsl1, prslki, islimsk, xlon, sinlat, stress,              !
!            sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz,  !
!            ddvel, flag_iter, flag_guess, nstf_name1, nstf_name4,      !
!            nstf_name5, lprnt, ipr,                                    !
!       input/outputs:                                                  !
!            tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, !
!            z_c, c_0,   c_d,   w_0, w_d, d_conv, ifd, qrain,           !
!  --   outputs:
!            qsurf, gflux, cmm, chh, evap, hflx, ep                     !
!           )
!                                                                       !
!                                                                       !
!  subprogram/functions called: w3movdat, iw3jdn, fpvs, density,        !
!       rhocoef, cool_skin, warm_layer, jacobi_temp.                    !
!                                                                       !
!  program history log:                                                 !
!         2007  -- xu li       createad original code                   !
!         2008  -- s. moorthi  adapted to the parallel version          !
!    may  2009  -- y.-t. hou   modified to include input lw surface     !
!                     emissivity from radiation. also replaced the      !
!                     often comfusing combined sw and lw suface         !
!                     flux with separate sfc net sw flux (defined       !
!                     as dn-up) and lw flux. added a program doc block. !
!    sep  2009 --  s. moorthi removed rcl and additional reformatting   !
!                     and optimization + made pa as input pressure unit.!
!         2009  -- xu li       recreatead the code                      !
!    feb  2010  -- s. moorthi added some changes made to the previous   !
!                  version                                              !
!    Jul  2016  -- X. Li, modify the diurnal warming event reset        !
!                                                                       !
!                                                                       !
!  ====================  definition of variables  ====================  !
!                                                                       !
!  inputs:                                                       size   !
!     im       - integer, horiz dimension                          1    !
!     ps       - real, surface pressure (pa)                       im   !
!     u1, v1   - real, u/v component of surface layer wind (m/s)   im   !
!     t1       - real, surface layer mean temperature ( k )        im   !
!     q1       - real, surface layer mean specific humidity        im   !
!     tref     - real, reference/foundation temperature ( k )      im   !
!     cm       - real, surface exchange coeff for momentum (m/s)   im   !
!     ch       - real, surface exchange coeff heat & moisture(m/s) im   !
!     prsl1    - real, surface layer mean pressure (pa)            im   !
!     prslki   - real,                                             im   !
!     islimsk  - integer, sea/land/ice mask (=0/1/2)               im   !
!     xlon     - real, longitude         (radians)                 im   !
!     sinlat   - real, sin of latitude                             im   !
!     stress   - real, wind stress       (n/m**2)                  im   !
!     sfcemis  - real, sfc lw emissivity (fraction)                im   !
!     dlwflx   - real, total sky sfc downward lw flux (w/m**2)     im   !
!     sfcnsw   - real, total sky sfc netsw flx into ocean (w/m**2) im   !
! DH*
! The actual unit of rain passed in is m ! see below line 438, qrain(i) = ...
! where 1000*rain in the nominator converts m to kg m^2; there is still a
! time unit 's' missing. Need to double-check what is going on.
! *DH
!     rain     - real, rainfall rate     (kg/m**2/s)               im   !
!     timestep - real, timestep interval (second)                  1    !
!     kdt      - integer, time step counter                        1    !
!     solhr    - real, fcst hour at the end of prev time step      1    !
!     xcosz    - real, consine of solar zenith angle               1    !
!     ddvel    - real, wind enhancement due to convection (m/s)    im   !
!     flag_iter- logical, execution or not                         im   !
!                when iter = 1, flag_iter = .true. for all grids   im   !
!                when iter = 2, flag_iter = .true. when wind < 2   im   !
!                for both land and ocean (when nstf_name1 > 0)     im   !
!     flag_guess-logical, .true.=  guess step to get CD et al      im   !
!                when iter = 1, flag_guess = .true. when wind < 2  im   !
!                when iter = 2, flag_guess = .false. for all grids im   !
!     nstf_name - integers , NSST related flag parameters          1    !
!                nstf_name1 : 0 = NSSTM off                        1    !
!                             1 = NSSTM on but uncoupled           1    !
!                             2 = NSSTM on and coupled             1    !
!                nstf_name4 : zsea1 in mm                          1    !
!                nstf_name5 : zsea2 in mm                          1    !
!     lprnt    - logical, control flag for check print out         1    !
!     ipr      - integer, grid index for check print out           1    !
!                                                                       !
!  input/outputs:
! li added for oceanic components
!     tskin    - real, ocean surface skin temperature ( k )        im   !
!     tsurf    - real, the same as tskin ( k ) but for guess run   im   !
!     xt       - real, heat content in dtl                         im   !
!     xs       - real, salinity  content in dtl                    im   !
!     xu       - real, u-current content in dtl                    im   !
!     xv       - real, v-current content in dtl                    im   !
!     xz       - real, dtl thickness                               im   !
!     zm       - real, mxl thickness                               im   !
!     xtts     - real, d(xt)/d(ts)                                 im   !
!     xzts     - real, d(xz)/d(ts)                                 im   !
!     dt_cool  - real, sub-layer cooling amount                    im   !
!     d_conv   - real, thickness of free convection layer (fcl)    im   !
!     z_c      - sub-layer cooling thickness                       im   !
!     c_0      - coefficient1 to calculate d(tz)/d(ts)             im   !
!     c_d      - coefficient2 to calculate d(tz)/d(ts)             im   !
!     w_0      - coefficient3 to calculate d(tz)/d(ts)             im   !
!     w_d      - coefficient4 to calculate d(tz)/d(ts)             im   !
!     ifd      - real, index to start dtlm run or not              im   !
!     qrain    - real, sensible heat flux due to rainfall (watts)  im   !

!  outputs:                                                             !

!     qsurf    - real, surface air saturation specific humidity    im   !
!     gflux    - real, soil heat flux (w/m**2)                     im   !
!     cmm      - real,                                             im   !
!     chh      - real,                                             im   !
!     evap     - real, evaperation from latent heat flux           im   !
!     hflx     - real, sensible heat flux                          im   !
!     ep       - real, potential evaporation                       im   !
!                                                                       !
! ===================================================================== !
      use machine , only : kind_phys
      use funcphys, only : fpvs
      use physcons, hvap => con_hvap                                    &
     &,             cp => con_cp, hfus => con_hfus, jcal => con_jcal    &
     &,             eps => con_eps, epsm1 => con_epsm1                  &
     &,             rvrdm1 => con_fvirt, rd => con_rd                   &
     &,             rhw0 => con_rhw0,sbc => con_sbc,pi => con_pi
      use date_def, only: idate
      use module_nst_water_prop, only: get_dtzm_point
      use module_nst_parameters, only : t0k,cp_w,omg_m,omg_sh,          &
     &    sigma_r,solar_time_6am,ri_c,z_w_max,delz,wd_max,              &
     &    rad2deg,const_rot,tau_min,tw_max,sst_max
      use module_nst_water_prop, only: solar_time_from_julian,          &
     &                                 density,rhocoef,compjd,grv       &
     &,                                sw_ps_9b
      use nst_module, only : cool_skin,dtm_1p,cal_w,cal_ttop,           &
     &                       convdepth,dtm_1p_fca,dtm_1p_tla,           &
     &                       dtm_1p_mwa,dtm_1p_mda,dtm_1p_mta,          &
     &                       dtl_reset
!
      implicit none
!
!  ---  constant parameters:
      real (kind=kind_phys), parameter :: cpinv=1.0/cp, hvapi=1.0/hvap
      real (kind=kind_phys), parameter :: f24   = 24.0     ! hours/day
      real (kind=kind_phys), parameter :: f1440 = 1440.0   ! minutes/day
      real (kind=kind_phys), parameter :: czmin = 0.0001   ! cos(89.994)

!  ---  inputs:
      integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4,      &
     &       nstf_name5
      real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1,   &
     &       t1, q1, tref, cm, ch, prsl1, prslki, xlon,xcosz,           &
     &       sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, ddvel
      integer, intent(in), dimension(im):: islimsk
      real (kind=kind_phys), intent(in) :: timestep
      real (kind=kind_phys), intent(in) :: solhr

      logical, intent(in) :: flag_iter(im), flag_guess(im), lprnt

!  ---  input/outputs:
! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation
      real (kind=kind_phys), dimension(im), intent(inout) :: tskin,     &
     &      tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool,         &
     &      z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain

!  ---  outputs:
      real (kind=kind_phys), dimension(im), intent(inout) ::            &
     &       qsurf, gflux, cmm, chh, evap, hflx, ep

      character(len=*), intent(out) :: errmsg
      integer,          intent(out) :: errflg

!
!     locals
!
      integer :: k,i
!
      real (kind=kind_phys), dimension(im) ::  q0, qss, rch,
     &                     rho_a, theta1, tv1, wind, wndmag

      real(kind=kind_phys) elocp,tem
!
!    nstm related prognostic fields
!
      logical flag(im)
      real (kind=kind_phys), dimension(im) ::
     &   xt_old, xs_old, xu_old, xv_old, xz_old,zm_old,xtts_old,
     &   xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old

      real(kind=kind_phys) ulwflx(im), nswsfc(im)
!     real(kind=kind_phys) rig(im),
!    &                     ulwflx(im),dlwflx(im),
!    &                     slrad(im),nswsfc(im)
      real(kind=kind_phys) alpha,beta,rho_w,f_nsol,sss,sep,
     &                     cosa,sina,taux,tauy,grav,dz,t0,ttop0,ttop

      real(kind=kind_phys) le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich
      real(kind=kind_phys) rnl_ts,hs_ts,hl_ts,rf_ts,q_ts
      real(kind=kind_phys) fw,q_warm
      real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz
      real(kind=kind_phys) zsea1,zsea2,soltim

!  external functions called: iw3jdn
      integer :: iw3jdn
!======================================================================================================
cc
      parameter (elocp=hvap/cp)

      ! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0

      sss = 34.0             ! temporarily, when sea surface salinity data is not ready
!
! flag for open water and where the iteration is on
!
      do i = 1, im
         flag(i) = islimsk(i) == 0 .and. flag_iter(i)
      enddo
!
!  save nst-related prognostic fields for guess run
!
      do i=1, im
        if((islimsk(i) == 0) .and. flag_guess(i)) then
          xt_old(i)      = xt(i)
          xs_old(i)      = xs(i)
          xu_old(i)      = xu(i)
          xv_old(i)      = xv(i)
          xz_old(i)      = xz(i)
          zm_old(i)      = zm(i)
          xtts_old(i)    = xtts(i)
          xzts_old(i)    = xzts(i)
          ifd_old(i)     = ifd(i)
          tskin_old(i)   = tskin(i)
          dt_cool_old(i) = dt_cool(i)
          z_c_old(i)     = z_c(i)
        endif
      enddo

!  --- ...  initialize variables. all units are m.k.s. unless specified.
!           ps is in pascals, wind is wind speed, theta1 is surface air
!           estimated from level 1 temperature, rho_a is air density and
!           qss is saturation specific humidity at the water surface
!!
      do i = 1, im
        if ( flag(i) ) then

          nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward)
          wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i))
          wind(i)   = wndmag(i) + max( 0.0, min( ddvel(i), 30.0 ) )
          wind(i)   = max( wind(i), 1.0 )

          q0(i)     = max(q1(i), 1.0e-8)
          theta1(i) = t1(i) * prslki(i)
          tv1(i)    = t1(i) * (1.0 + rvrdm1*q0(i))
          rho_a(i)  = prsl1(i) / (rd*tv1(i))
          qss(i)    = fpvs(tsurf(i))                          ! pa
          qss(i)    = eps*qss(i) / (ps(i) + epsm1*qss(i))     ! pa
!
          evap(i)    = 0.0
          hflx(i)    = 0.0
          gflux(i)   = 0.0
          ep(i)      = 0.0

!  --- ...  rcp = rho cp ch v

          rch(i)     = rho_a(i) * cp * ch(i) * wind(i)
          cmm(i)     = cm (i)   * wind(i)
          chh(i)     = rho_a(i) * ch(i) * wind(i)

!> - Calculate latent and sensible heat flux over open water with tskin.
!           at previous time step
          evap(i)    = elocp * rch(i) * (qss(i) - q0(i))
          qsurf(i)   = qss(i)
          hflx(i)    = rch(i) * (tsurf(i) - theta1(i))

!     if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=',
!    & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i)
!    &,' tsurf=',tsurf(i)
        endif
      enddo

! run nst model: dtm + slm
!
      zsea1 = 0.001*real(nstf_name4)
      zsea2 = 0.001*real(nstf_name5)

!> - Call module_nst_water_prop::density() to compute sea water density.
!> - Call module_nst_water_prop::rhocoef() to compute thermal expansion
!! coefficient (\a alpha) and saline contraction coefficient (\a beta).
      do i = 1, im
        if ( flag(i) ) then
          tsea      = tsurf(i)
          t12       = tsea*tsea
          ulwflx(i) = sfcemis(i) * sbc * t12 * t12
          alon      = xlon(i)*rad2deg
          grav      = grv(sinlat(i))
          soltim  = mod(alon/15.0 + solhr, 24.0)*3600.0
          call density(tsea,sss,rho_w)                     ! sea water density
          call rhocoef(tsea,sss,rho_w,alpha,beta)          ! alpha & beta
!
!> - Calculate sensible heat flux (\a qrain) due to rainfall.
!
          le       = (2.501-.00237*tsea)*1e6
          dwat     = 2.11e-5*(t1(i)/t0k)**1.94               ! water vapor diffusivity
          dtmp     = (1.+3.309e-3*(t1(i)-t0k)-1.44e-6*(t1(i)-t0k)*
     &              (t1(i)-t0k))*0.02411/(rho_a(i)*cp)       ! heat diffusivity
          wetc     = 622.0*le*qss(i)/(rd*t1(i)*t1(i))
          alfac    = 1/(1+(wetc*le*dwat)/(cp*dtmp))          ! wet bulb factor
          qrain(i) =  (1000.*rain(i)/rho_w)*alfac*cp_w*
     &                (tsea-t1(i)+(1000.*qss(i)-1000.*q0(i))*le/cp)

!> - Calculate input non solar heat flux as upward = positive to models here

          f_nsol   = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i)
     &             + omg_sh*qrain(i)

!     if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=',
!    &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i)
!    &,' omg_sh=',omg_sh,' qrain=',qrain(i)

          sep      = sss*(evap(i)/le-rain(i))/rho_w
          ustar_a  = sqrt(stress(i)/rho_a(i))          ! air friction velocity
!
!  sensitivities of heat flux components to ts
!
          rnl_ts = 4.0*sfcemis(i)*sbc*tsea*tsea*tsea     ! d(rnl)/d(ts)
          hs_ts  = rch(i)
          hl_ts  = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12)
          rf_ts  = (1000.*rain(i)/rho_w)*alfac*cp_w*(1.0+rch(i)*hl_ts)
          q_ts   = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts
!
!> - Call cool_skin(), which is the sub-layer cooling parameterization
!! (Fairfall et al. (1996) \cite fairall_et_al_1996).
! & calculate c_0, c_d
!
          call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta
     &,                  rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le
     &,                  dt_cool(i),z_c(i),c_0(i),c_d(i))

          tem  = 1.0 / wndmag(i)
          cosa = u1(i)*tem
          sina = v1(i)*tem
          taux = max(stress(i),tau_min)*cosa
          tauy = max(stress(i),tau_min)*sina
          fc   = const_rot*sinlat(i)
!
!  Run DTM-1p system.
!
          if ( (soltim > solar_time_6am .and. ifd(i) == 0.0) ) then
          else
            ifd(i) = 1.0
!
!     calculate fcl thickness with current forcing and previous time's profile
!
!     if (lprnt .and. i == ipr) print *,' beg xz=',xz(i)

!> - Call convdepth() to calculate depth for convective adjustments.
            if ( f_nsol > 0.0 .and. xt(i) > 0.0 ) then
              call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w
     &,                      alpha,beta,xt(i),xs(i),xz(i),d_conv(i))
            else
              d_conv(i) = 0.0
            endif

!     if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i)
!
!    determine rich: wind speed dependent (right now)
!
!           if ( wind(i) < 1.0 ) then
!             rich = 0.25 + 0.03*wind(i)
!           elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then
!             rich = 0.25 + 0.1*wind(i)
!           elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then
!             rich = 0.25 + 0.6*wind(i)
!           elseif ( wind(i) >= 6.0 ) then
!             rich = 0.25 + min(0.8*wind(i),0.50)
!           endif

            rich = ri_c

!> - Call the diurnal thermocline layer model dtm_1p().
            call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i),
     &                  f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon,
     &                  sinlat(i),soltim,grav,le,d_conv(i),
     &                  xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))

!     if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i)

!  apply mda
            if ( xt(i) > 0.0 ) then
!>  - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply
!!  minimum depth adjustment (mda).
              call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i))
              if ( xz(i) >= z_w_max ) then
!>   - If \a dtl thickness >= module_nst_parameters::z_w_max, call dtl_reset()
!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max.
                call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i),
     &                                                       xzts(i))

!     if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max='
!    &,z_w_max
              endif

!  apply fca
              if ( d_conv(i) > 0.0 ) then
!>  - If thickness of free convection layer > 0.0, call dtm_1p_fca()
!! to apply free convection adjustment.
!>   - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset()
!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max().
                call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i))
                if ( xz(i) >= z_w_max ) then
                  call dtl_reset
     &              (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
                endif
              endif

!     if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i)

!  apply tla
              dz = min(xz(i),max(d_conv(i),delz))
!
!>  - Call sw_ps_9b() to compute the fraction of the solar radiation
!! absorbed by the depth \a delz (Paulson and Simpson (1981) \cite paulson_and_simpson_1981).
!! And calculate the total heat absorbed in warm layer.
              call sw_ps_9b(delz,fw)
              q_warm = fw*nswsfc(i)-f_nsol    !total heat absorbed in warm layer

!>  - Call cal_ttop() to calculate the diurnal warming amount at the top layer with
!! thickness of \a dz.
              if ( q_warm > 0.0 ) then
                call cal_ttop(kdt,timestep,q_warm,rho_w,dz,
     &                        xt(i),xz(i),ttop0)

!     if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=',
!    &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i),
!    &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i),
!    &' xz=',xz(i),' qrain=',qrain(i)

                ttop = ((xt(i)+xt(i))/xz(i))*(1.0-dz/((xz(i)+xz(i))))

!     if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i)
!    &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz
!    &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0

!>  - Call dtm_1p_tla() to apply top layer adjustment.
                if ( ttop > ttop0 ) then
                  call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i))

!     if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=',
!    &z_w_max
                  if ( xz(i) >= z_w_max ) then
                    call dtl_reset
     &                   (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
                  endif
                endif
              endif           ! if ( q_warm > 0.0 ) then

!     if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i)

!  apply mwa
!>  - Call dt_1p_mwa() to apply maximum warming adjustment.
              t0 = (xt(i)+xt(i))/xz(i)
              if ( t0 > tw_max ) then
                call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i))
                if ( xz(i) >= z_w_max ) then
                  call dtl_reset
     &                 (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
                endif
              endif

!     if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i)

!  apply mta
!>  - Call dtm_1p_mta() to apply maximum temperature adjustment.
       sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i)

              if ( sstc > sst_max ) then
                dta = sstc - sst_max
                call  dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i))
!               write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i),
!    &          sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i)
               if ( xz(i) >= z_w_max ) then
                  call dtl_reset
     &                 (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
                endif
              endif
!
            endif             ! if ( xt(i) > 0.0 ) then
!           reset dtl at midnight and when solar zenith angle > 89.994 degree
            if ( abs(soltim) < 2.0*timestep ) then
              call dtl_reset
     &           (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i))
            endif

          endif             ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day

!     if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i)

!     update tsurf  (when flag(i) .eqv. .true. )
!>  - Call get_dtzm_point() to computes \a dtz and \a tsurf.
          call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i),
     &                        zsea1,zsea2,dtz)
          tsurf(i) = max(271.2, tref(i) + dtz )

      if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=',
     &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i)

!>  - Call cal_w() to calculate \a w_0 and \a w_d.
          if ( xt(i) > 0.0 ) then
            call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i))
          else
            w_0(i) = 0.0
            w_d(i) = 0.0
          endif

!         if ( xt(i) > 0.0 ) then
!           rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i))
!    &             /(2.0*(xu(i)*xu(i)+xv(i)*xv(i)))
!         else
!           rig(i) = 0.25
!         endif

!         qrain(i) = rig(i)
          zm(i) = wind(i)

        endif
      enddo

! restore nst-related prognostic fields for guess run
      do i=1, im
        if((islimsk(i) == 0) ) then
          if(flag_guess(i)) then    ! when it is guess of
            xt(i)      = xt_old(i)
            xs(i)      = xs_old(i)
            xu(i)      = xu_old(i)
            xv(i)      = xv_old(i)
            xz(i)      = xz_old(i)
            zm(i)      = zm_old(i)
            xtts(i)    = xtts_old(i)
            xzts(i)    = xzts_old(i)
            ifd(i)     = ifd_old(i)
            tskin(i)   = tskin_old(i)
            dt_cool(i) = dt_cool_old(i)
            z_c(i)     = z_c_old(i)
          else
!
!         update tskin when coupled and not guess run
!         (all other NSST variables have been updated in this case)
!
            if ( nstf_name1 > 1 ) then
              tskin(i) = tsurf(i)
            endif               ! if ( nstf_name1 > 1  then
          endif                 ! if(flag_guess(i)) then
        endif                   ! if((islimsk(i).eq. 0.) ) then
      enddo

!     if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i)

      if ( nstf_name1 > 1 ) then
!> - Calculate latent and sensible heat flux over open water with updated tskin
!!      for the grids of open water and the iteration is on.
        do i = 1, im
          if ( flag(i) ) then
            qss(i)   = fpvs( tskin(i) )
            qss(i)   = eps*qss(i) / (ps(i) + epsm1*qss(i))
            qsurf(i) = qss(i)
            evap(i)  = elocp*rch(i) * (qss(i) - q0(i))
            hflx(i)  = rch(i) * (tskin(i) - theta1(i))
          endif
        enddo
      endif                   ! if ( nstf_name1 > 1 ) then

!
      do i=1,im
        if ( flag(i) ) then
          tem     = 1.0 / rho_a(i)
          hflx(i) = hflx(i) * tem * cpinv
          evap(i) = evap(i) * tem * hvapi
        endif
      enddo
!
!     if (lprnt) print *,' tskin=',tskin(ipr)

      return
      end subroutine sfc_nst_run
!> @}
      end module sfc_nst

!> This module contains the CCPP-compliant GFS near-surface sea temperature pre
!! interstitial codes.
      module sfc_nst_pre

      contains

! \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre
!!
!! The NSST scheme is one of the three schemes used to represent the
!! surface in the GFS physics suite. The other two are the Noah land
!! surface model and the sice simplified ice model.
!!
!! \section arg_table_sfc_nst_init  Argument Table
!!
      subroutine sfc_nst_pre_init
      end subroutine sfc_nst_pre_init

!! \section arg_table_sfc_nst_finalize  Argument Table
!!
      subroutine sfc_nst_pre_finalize
      end subroutine sfc_nst_pre_finalize

!! \section arg_table_sfc_nst_pre_run Argument Table
!! | local_name     | standard_name                                          | long_name                                      | units | rank | type      |    kind   | intent | optional |
!! |----------------|--------------------------------------------------------|----------------------------------------------- |-------|------|-----------|-----------|--------|----------|
!! | im             | horizontal_loop_extent                                 | horizontal loop extent                         | count |    0 | integer   |           | in     | F        |
!! | islimsk        | sea_land_ice_mask                                      | landmask: sea/land/ice=0/1/2                   | flag  |    1 | integer   |           | in     | F        |
!! | oro            | orography                                              | orography                                      | m     |    1 | real      | kind_phys | in     | F        |
!! | oro_uf         | orography_unfiltered                                   | unfiltered orographyo                          | m     |    1 | real      | kind_phys | in     | F        |
!! | tsfc           | surface_skin_temperature                               | surface skin temperature                       | K     |    1 | real      | kind_phys | in     | F        |
!! | tsurf          | surface_skin_temperature_after_iteration               | ocean surface skin temperature for guess run   | K     |    1 | real      | kind_phys | inout  | F        |
!! | tskin          | surface_skin_temperature_for_nsst                      | ocean surface skin temperature                 | K     |    1 | real      | kind_phys | out    | F        |
!! | errmsg         | ccpp_error_message                                     | error message for error handling in CCPP       | none  |    0 | character | len=*     | out    | F        |
!! | errflg         | ccpp_error_flag                                        | error flag for error handling in CCPP          | flag  |    0 | integer   |           | out    | F        |
!!
!> \section NSST_general_pre_algorithm General Algorithm
!! @{
      subroutine sfc_nst_pre_run                                        &
     &    (im, islimsk, oro, oro_uf, tsfc, tsurf, tskin, errmsg, errflg)

      use machine , only : kind_phys
      use physcons, only: rlapse

      implicit none

!  ---  inputs:
      integer, intent(in) :: im
      integer, dimension(im), intent(in) :: islimsk
      real (kind=kind_phys), dimension(im), intent(in) :: oro, oro_uf
      real (kind=kind_phys), dimension(im), intent(in) :: tsfc

!  ---  input/outputs:
      real (kind=kind_phys), dimension(im), intent(inout) :: tsurf

!  ---  outputs:
      real (kind=kind_phys), dimension(im), intent(out) :: tskin

      character(len=*), intent(out) :: errmsg
      integer,          intent(out) :: errflg

!  ---  locals
      integer :: i
      real(kind=kind_phys) :: tem

      ! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0

      ! Initialize intent(out) variables
      tskin = 0.0

      do i = 1, im
        if ( islimsk(i) == 0 ) then
          tem      = (oro(i)-oro_uf(i)) * rlapse
          tskin(i) = tsfc(i)  + tem
          tsurf(i) = tsurf(i) + tem
        endif
      enddo

      return
      end subroutine sfc_nst_pre_run
!! @}
      end module sfc_nst_pre

!> This module contains the CCPP-compliant GFS near-surface sea temperature post
!! interstitial codes.
      module sfc_nst_post

      contains

! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post
!! \brief Brief description of the parameterization
!!
!! \section arg_table_sfc_nst_post_init  Argument Table
!!
      subroutine sfc_nst_post_init
      end subroutine sfc_nst_post_init

! \brief Brief description of the subroutine
!!
!! \section arg_table_sfc_nst_post_finalize  Argument Table
!!
      subroutine sfc_nst_post_finalize
      end subroutine sfc_nst_post_finalize

!> \brief Brief description of the subroutine
!!
!! \section arg_table_sfc_nst_post_run Argument Table
!! | local_name     | standard_name                                          | long_name                                      | units   | rank | type      |    kind   | intent | optional |
!! |----------------|--------------------------------------------------------|----------------------------------------------- |---------|------|-----------|-----------|--------|----------|
!! | im             | horizontal_loop_extent                                 | horizontal loop extent                         | count   |    0 | integer   |           | in     | F        |
!! | islimsk        | sea_land_ice_mask                                      | landmask: sea/land/ice=0/1/2                   | flag    |    1 | integer   |           | in     | F        |
!! | oro            | orography                                              | orography                                      | m       |    1 | real      | kind_phys | in     | F        |
!! | oro_uf         | orography_unfiltered                                   | unfiltered orography                           | m       |    1 | real      | kind_phys | in     | F        |
!! | nstf_name1     | flag_for_nsstm_run                                     | NSSTM flag: off/uncoupled/coupled=0/1/2        | flag    |    0 | integer   |           | in     | F        |
!! | nstf_name4     | vertical_temperature_average_range_lower_bound         | zsea1                                          | mm      |    0 | integer   |           | in     | F        |
!! | nstf_name5     | vertical_temperature_average_range_upper_bound         | zsea2                                          | mm      |    0 | integer   |           | in     | F        |
!! | xt             | diurnal_thermocline_layer_heat_content                 | heat content in diurnal thermocline layer      | K m     |    1 | real      | kind_phys | in     | F        |
!! | xz             | diurnal_thermocline_layer_thickness                    | diurnal thermocline layer thickness            | m       |    1 | real      | kind_phys | in     | F        |
!! | dt_cool        | sub-layer_cooling_amount                               | sub-layer cooling amount                       | K       |    1 | real      | kind_phys | in     | F        |
!! | z_c            | sub-layer_cooling_thickness                            | sub-layer cooling thickness                    | m       |    1 | real      | kind_phys | in     | F        |
!! | rslimsk        | sea_land_ice_mask_real                                 | landmask: sea/land/ice=0/1/2                   | flag    |    1 | real      | kind_phys | in     | F        |
!! | tref           | sea_surface_reference_temperature                      | reference/foundation temperature               | K       |    1 | real      | kind_phys | in     | F        |
!! | xlon           | longitude                                              | longitude                                      | radians |    1 | real      | kind_phys | in     | F        |
!! | tsurf          | surface_skin_temperature_after_iteration               | ocean surface skin temperature for guess run   | K       |    1 | real      | kind_phys | inout  | F        |
!! | dtzm           | mean_change_over_depth_in_sea_water_temperature        | mean of dT(z)  (zsea1 to zsea2)                | K       |    1 | real      | kind_phys | out    | F        |
!! | tsfc           | surface_skin_temperature                               | surface skin temperature                       | K       |    1 | real      | kind_phys | inout  | F        |
!! | errmsg         | ccpp_error_message                                     | error message for error handling in CCPP       | none    |    0 | character | len=*     | out    | F        |
!! | errflg         | ccpp_error_flag                                        | error flag for error handling in CCPP          | flag    |    0 | integer   |           | out    | F        |
!!
! \section NSST_general_post_algorithm General Algorithm
!
! \section NSST_detailed_post_algorithm Detailed Algorithm
! @{
      subroutine sfc_nst_post_run                                       &
     &     ( im, islimsk, oro, oro_uf, nstf_name1, nstf_name4,          &
     &       nstf_name5, xt, xz, dt_cool, z_c, rslimsk, tref, xlon,     &
     &       tsurf, dtzm, tsfc, errmsg, errflg                          &
     &     )

      use machine , only : kind_phys
      use physcons, only: rlapse
      use module_nst_water_prop, only: get_dtzm_2d

      implicit none

!  ---  inputs:
      integer, intent(in) :: im
      integer, dimension(im), intent(in) :: islimsk
      real (kind=kind_phys), dimension(im), intent(in) :: oro, oro_uf
      integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5
      real (kind=kind_phys), dimension(im), intent(in) :: xt, xz,       &
     &      dt_cool, z_c, rslimsk, tref, xlon

!  ---  input/outputs:
      real (kind=kind_phys), dimension(im), intent(inout) :: tsurf

!  ---  outputs:
      real (kind=kind_phys), dimension(size(xlon,1)), intent(out) ::    &
     &      dtzm
      real (kind=kind_phys), dimension(im), intent(inout) :: tsfc

      character(len=*), intent(out) :: errmsg
      integer,          intent(out) :: errflg

!  ---  locals
      integer :: i
      real(kind=kind_phys) :: zsea1, zsea2

      ! Initialize CCPP error handling variables
      errmsg = ''
      errflg = 0

!     if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr),
!    &     ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr),
!    &     ' kdt=',kdt

      do i = 1, im
        if ( islimsk(i) == 0 ) then
          tsurf(i) = tsurf(i) - (oro(i)-oro_uf(i)) * rlapse
        endif
      enddo

!  --- ...  run nsst model  ... ---

      dtzm = 0.0
      if (nstf_name1 > 1) then
        zsea1 = 0.001*real(nstf_name4)
        zsea2 = 0.001*real(nstf_name5)
        call get_dtzm_2d (xt, xz, dt_cool,                              &
     &                    z_c, rslimsk, zsea1, zsea2,                   &
     &                    im, 1, dtzm)
        do i = 1, im
          if ( islimsk(i) == 0 ) then
            tsfc(i) = max(271.2,tref(i) + dtzm(i)) -                    &
     &                    (oro(i)-oro_uf(i))*rlapse
          endif
        enddo
      endif

!     if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr),   &
!    &    ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt

      return
      end subroutine sfc_nst_post_run

      end module sfc_nst_post


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
!     1. Redistributions of source code must retain the above copyright notice,
!        this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright notice,
!        this list of conditions and the following disclaimer in the documentation
!        and/or other materials provided with the distribution.
!     3. Neither the name of the NEMO project nor the names of its contributors
!        may be used to endorse or promote products derived from this software
!        without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!---------------------------------------------------------------------------------
!
! Description:
!    To be added...
!
SUBMODULE (tools_mesh) rd_gmsh_implementation
    USE type_table, ONLY : table
    USE class_connectivity
    IMPLICIT NONE

CONTAINS

    MODULE PROCEDURE rd_gmsh_mesh
        USE class_psblas
        USE class_cell
        !USE class_connectivity
        USE class_face
        USE class_vertex
        IMPLICIT NONE

        ! --- Local variables ---
        !
        ! Parameters
        LOGICAL, PARAMETER :: debug = .FALSE.
        INTEGER, PARAMETER :: mesh = 10
        !
        ! Local copies of V2F_, V2C_, F2C_ objects (connectivity class)
        TYPE(table) :: v2f_, v2c_, f2c_
        !
        ! Vertex-related variables
        INTEGER :: nverts
        LOGICAL, ALLOCATABLE :: on_boundary(:)
        REAL(psb_dpk_), ALLOCATABLE :: xv(:), yv(:), zv(:)
        !
        ! face-related variables
        INTEGER :: nfaces
        INTEGER, ALLOCATABLE :: fnv(:), imaster(:), islave(:), iflag(:)
        INTEGER, ALLOCATABLE :: facenv(:), facemaster(:), faceslave(:), faceflag(:)
        !
        ! cell-related variables
        INTEGER :: ncells
        INTEGER, ALLOCATABLE :: cellnv(:), cellnf(:), cellgroup(:)
        CHARACTER(len=3), ALLOCATABLE :: cellgeo(:)
        !
        ! Group-related variables
        INTEGER :: ngroups
        TYPE(table) :: c2g_
        !
        ! BC-related variables
        INTEGER :: nbcfaces
        TYPE(table) :: f2b
        !
        ! Work variables
        LOGICAL :: found
        INTEGER :: i, i1, i2, info, j, j1, j2, k, l, m, n
        INTEGER :: ib, ic, ig
        INTEGER :: IF, if1, if2
        INTEGER :: iv, iv1, iv2, iv3, iv4, iv5, iv6, iv7, iv8, cellid
        INTEGER, ALLOCATABLE :: perm(:), pinv(:), nvs(:), nbcf(:), bcfp_(:), &
                                      faceid_(:,:), faceid(:), ftype(:), facev(:,:), cellv(:,:), gcells(:)
        INTEGER, ALLOCATABLE :: aux(:,:), buf(:), work(:), pftags(:,:), pctags(:,:), facebc(:)
        TYPE(table) :: f2v, dmy
        INTEGER :: status

        CHARACTER(LEN=32) :: pname
        CHARACTER(LEN=80) :: adummy
        REAL(psb_dpk_) :: vers
        INTEGER :: filetype, dsize, nnames, pdim, pid, itemp, i3, i4, &
                      dim_entt, tag_entt, nv_in_entt, edim, etag, etype, ibc, icell, ielem, &
                      ientt, iface, igroup, inv, ncmax, ncmin, nelems, nentts, npt, nv, nvmax, &
                      nvmin, tag, ibc_temp, vi(4), vj(4), jf
        REAL(psb_dpk_) :: xn, yn, zn, xx, yx, zx
        ! ------------------------------------------------------------------

        WRITE(*,*) 'Importing mesh in .MSH format on P0'
        WRITE(6,*) "Reading mesh from ", TRIM(ADJUSTL(mesh_file))

        ! Opens file *.msh
        OPEN(unit=mesh,file=ADJUSTL(mesh_file),status='old',iostat=status)
        IF(status /=0 ) THEN
            WRITE(*,050) ADJUSTL(mesh_file)
            CALL abort_psblas
        ENDIF

        READ (mesh,'()') !! $MeshFormat statement

        READ (mesh, *) vers, filetype, dsize !! Version, filetype (0=ASCII,1=binary), datasize

        ! Abort of mesh file version is less than 4.1 or if filetype is not ASCII
        IF (vers < 4.0 .OR. filetype /= 0) THEN
          WRITE(*, 100)
          CALL abort_psblas
        END IF

        DO i = 1,2
          READ (mesh, '()') ! Read section footer and header
        END DO

        ! Read all the named physical entities (materials [3D] and BCs [2D])
        ! and count the number of BCs and volumes
        nbc = 0
        ngroups = 0
        ncd = 0
        READ (mesh, '(I2)') nnames

        DO i = 1, nnames
          READ (mesh, *) pdim, pid, pname
          IF (pdim == 2) THEN
            ncd =2
            nbc = nbc + 1
          END IF
          IF (pdim == 3) THEN
            ncd = 3
            ngroups = ngroups + 1
          END IF
        END DO

        IF (ncd < 2) THEN
          WRITE(6,*) "Mesh is less than 2 dimensions"
          CALL abort_psblas
        END IF

        DO i = 1,2
          READ (mesh, '()') ! Read section footer and header
        END DO

        ! Read the entities section. This matches the numerical entities to the physical entities.
        ! The numerical entities correspond to the vertices, lines, faces, volumes that were
        ! constructed to create the geometry.
        READ (mesh, *) i1, i2, i3, i4
        DO i = 1, (i1+i2)
          READ (mesh, '()')
          ! We ignore the nodes and the lines.
        END DO
        ALLOCATE(pftags(i3, 2), pctags(i4, 2), stat=info)
        pftags = 0
        pctags = 0
        IF(info /= 0) THEN
          WRITE (*,100)
          CALL abort_psblas
        END IF
        DO i = 1, i3
          READ(mesh, *) ientt, xn, yn, zn, xx, yx, zx, npt, tag, adummy
          IF (npt == 1) THEN
            ! key-value store (ientt, tag) for the geometric and physical entity tags
            pftags(i, 1) = ientt
            pftags(i, 2) = tag
          END IF
        END DO
        DO i = 1, i4
          READ(mesh, *) ientt, xn, yn, zn, xx, yx, zx, npt, tag, adummy
          IF (npt == 1) THEN
            ! key-value store (ientt, tag) for the geometric and physical entity tags
            pctags(i, 1) = ientt
            pctags(i, 2) = tag - nbc
          END IF
        END DO

        DO i = 1,2
          READ (mesh, '()') ! Read section footer and header
        END DO

        ! Read the nodes information and their coordinates
        READ (mesh, *) nentts, nverts, nvmin, nvmax
        IF (nverts /= nvmax) THEN
          WRITE (*,100)
          write (*, *) "Node numbering is not continuous"
          CALL abort_psblas
        END IF
        ALLOCATE (xv(nverts), yv(nverts), zv(nverts),stat=info)
        IF(info /= 0) THEN
            WRITE (*,100)
            CALL abort_psblas
        END IF
        DO ientt = 1, nentts
          READ (mesh, *) dim_entt, tag_entt, itemp, nv_in_entt
          ALLOCATE (nvs(nv_in_entt))
          DO inv = 1, nv_in_entt
            READ (mesh, *) nvs(inv)
          END DO
          DO inv = 1, nv_in_entt
            nv = nvs(inv)
            READ (mesh, *) xv(nv), yv(nv), zv(nv)
          END DO
          DEALLOCATE (nvs)
        END DO

        DO i = 1,2
          READ (mesh, '()') ! Read section footer and header
        END DO

        ! Read the cells information
        READ (mesh, *) nentts, ncells, ncmin, ncmax
        IF (ncells /= ncmax) THEN
          WRITE (*,100)
          write (*, *) "Cell and face numbering is not continuous"
          CALL abort_psblas
        END IF
        ALLOCATE (nbcf(nbc), bcfp_(nbc), faceid_(nbc, ncells), faceid(ncells), &
                    facev(ncells,4), facebc(ncells), ftype(ncells), cellgroup(ncells), &
                    cellnv(ncells), cellnf(ncells), cellgeo(ncells), cellv(ncells, 8), &
                    gcells(ngroups), stat=info)
        IF(info /= 0) THEN
            WRITE (*,100)
            CALL abort_psblas
        END IF
        icell = 0
        iface = 0
        nbcf = 0
        gcells = 0
        bcfp_(:) = 0
        DO ientt = 1, nentts
          READ(mesh, *) edim, etag, etype, nelems
          IF (edim == 2) THEN
            ibc_temp = MINLOC(pftags(:,1), DIM=1, MASK=(pftags(:,1) == etag))
            ! Above call should be replaced by FINDLOC when gfortran 9.0 bugs are resolved
            ibc = pftags(ibc_temp, 2)
            nbcf(ibc) = nbcf(ibc) + nelems
            DO ielem = 1, nelems
              bcfp_(ibc) = bcfp_(ibc) + 1
              READ (mesh, *) faceid_(ibc, bcfp_(ibc)), vi
              iface = faceid_(ibc, bcfp_(ibc))
              facev(iface,:) = vi
              facebc(iface) = ibc
              ftype(iface) = etype
            END DO
          ELSE
            igroup = MINLOC(pctags(:,1), DIM=1, MASK=(pctags(:,1) == etag))
            ! Above call should be replaced by FINDLOC when gfortran 9.0 bugs are resolved
            ig = pctags(igroup, 2)
            gcells(ig) = gcells(ig) + nelems
            DO ielem = 1, nelems
              icell = icell + 1
              READ (mesh, *) cellid, cellv(icell,:)
              cellgroup(icell) = ig
              SELECT CASE(etype)
              CASE (5)
                cellnv(icell) = 8
                cellnf(icell) = 6
                cellgeo(icell) = 'hex'
              CASE default
                WRITE(*,*) 'WARNING! Unsupported celltype: ', etype, ' IGNORING'
                CONTINUE
              END SELECT
            END DO
          END IF
        END DO

        CLOSE(mesh)

        i = 1
        DO ibc = 1, nbc
          DO if = 1, bcfp_(ibc)
            faceid(i) = faceid_(ibc, if)
            i = i + 1
          END DO
        END DO

        nfaces = iface
        ncells = icell
        ALLOCATE(work(ncells*8))
        CALL v2c_%alloc_table(nel=ncells)

        i1 = 1; i2 = 0; v2c_%lookup(1) = 1
        DO ic = 1, ncells
            i2 = i1 + cellnv(ic) - 1
            work(i1:i2) = cellv(ic,1:cellnv(ic))
            i1 = i2 + 1
            v2c_%lookup(ic+1) = i1
        END DO
        CALL v2c_%alloc_table(ntab=i2)

        v2c_%tab = work(1:i2)
        DEALLOCATE(work)

        ! Reads groups definition.
        CALL c2g_%alloc_table(nel=ngroups,ntab=ncells)

        i1 = 1
        DO ig = 1, ngroups
          c2g_%lookup(ig) = i1
          i2 = i1 + gcells(ig) - 1
          DO ic = i1, i2
            c2g_%tab(ic) = ic
          END DO
          i1 = i2 + 1
          c2g_%lookup(ig+1) = i1
        END DO

        ! Creates face-cell connectivity
        !
        ! Estimation of elements number for f2c_%tab and v2f_%tab
        nfaces = 0; n = 0
        DO ic = 1, ncells
            j = cellnf(ic)
            nfaces = nfaces + j

            SELECT CASE(cellgeo(ic))
            CASE('qua')
                k = 8
            CASE('tri')
                k = 6
            CASE('hex')
                k = 24
            CASE('pri')
                k = 18
            CASE('tet')
                k = 12
            CASE('pyr')
                k = 16
            END SELECT
            n = n + k
        END DO

        ! Allocation of face-related connectivity tables
        CALL f2c_%alloc_table(nel=ncells,ntab=nfaces)
        CALL v2f_%alloc_table(nel=nfaces,ntab=n)

        ! Allocation of temporary face-related arrays
        ALLOCATE(iflag(nfaces), fnv(nfaces),  &
            &   imaster(nfaces), islave(nfaces), stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        i1 = 1; i2 = 0; f2c_%lookup(1) = 1
        j1 = 1; j2 = 0; v2f_%lookup(1) = 1
        DO ic = 1, ncells
            i2 = i1 + cellnf(ic) - 1

            iv  = v2c_%lookup(ic) - 1
            iv1 = v2c_%tab(iv+1)
            iv2 = v2c_%tab(iv+2)
            iv3 = v2c_%tab(iv+3)
            IF(cellnv(ic) > 3) iv4 = v2c_%tab(iv+4) ! quad, tet
            IF(cellnv(ic) > 4) iv5 = v2c_%tab(iv+5) ! pyr
            IF(cellnv(ic) > 5) iv6 = v2c_%tab(iv+6) ! pri
            IF(cellnv(ic) > 7) THEN                ! hex
                iv7 = v2c_%tab(iv+7)
                iv8 = v2c_%tab(iv+8)
            END IF

            DO IF = i1, i2
                f2c_%tab(IF) = IF
                iflag(IF) =0
                imaster(IF) = ic
                islave(IF) = 0 ! Further defined
            END DO

            SELECT CASE(cellgeo(ic))
            CASE('qua')
                j2 = j1 + 8 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv2, iv2,iv3, iv3,iv4, iv4,iv1 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+2), (j1+4), (j1+6) /)
                fnv(i1:i2) = (/ 2, 2, 2, 2 /)
            CASE('tri')
                j2 = j1 + 6 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv2, iv2,iv3, iv3,iv1 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+2), (j1+4) /)
                fnv(i1:i2) = (/ 2, 2, 2 /)
            CASE('hex')
                j2 = j1 + 24 - 1
                v2f_%tab(j1:j2) =  (/ iv1,iv2,iv6,iv5, iv2,iv3,iv7,iv6, iv3,iv4,iv8,iv7, &
                    &             iv4,iv1,iv5,iv8, iv2,iv1,iv4,iv3, iv5,iv6,iv7,iv8 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+4), (j1+8), (j1+12), (j1+16), (j1+20) /)
                fnv(i1:i2) = (/ 4, 4, 4, 4, 4, 4 /)
            CASE('pri')
                j2 = j1 + 18 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv2,iv5,iv4, iv2,iv3,iv6,iv5, iv3,iv1,iv4,iv6, &
                    &             iv1,iv3,iv2, iv4,iv5,iv6 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+4), (j1+8), (j1+12), (j1+15) /)
                fnv(i1:i2) = (/ 4, 4, 4, 3, 3  /)
            CASE('tet')
                j2 = j1 + 12 - 1
                v2f_%tab(j1:j2) = (/ iv2,iv1,iv3, iv1,iv2,iv4, iv2,iv3,iv4, iv3,iv1,iv4 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+3), (j1+6), (j1+9) /)
                fnv(i1:i2) = (/ 3, 3, 3, 3  /)
            CASE('pyr')
                j2 = j1 + 16 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv4,iv3,iv2, iv1,iv2,iv5, iv2,iv3,iv5, &
                    &            iv3,iv4,iv5, iv4,iv1,iv5 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+4), (j1+7), (j1+10), (j1+13) /)
                fnv(i1:i2) = (/ 4, 3, 3, 3, 3  /)
            END SELECT

            i1 = i2 + 1
            j1 = j2 + 1
            f2c_%lookup(ic+1) = i1
            v2f_%lookup(i2+1) = j1
        END DO

        ! #############################################################################
        IF(debug) THEN
            DO ic = 1, ncells
                i1 = f2c_%lookup(ic)
                i2 = f2c_%lookup(ic+1) - 1
                j1 = f2c_%tab(i1)
                j2 = f2c_%tab(i2)
                DO IF = j1, j2
                    iv1 = v2f_%lookup(IF)
                    iv2 = v2f_%lookup(IF+1) - 1
                    WRITE(*,300) ic, cellgeo(ic), IF, v2f_%tab(iv1:iv2);
                END DO
            END DO
            WRITE(*,*)
    300     FORMAT(' cell: ',i7,' type: ',a3, ' face: ',i6,' vertices:', 8(1x,i7))
        END IF
        ! ###########################################################################

        ! Builds connection table f2v, dual of v2f
        CALL v2f_%get_dual_table(f2v)

        ! Initializes face permutation array
        ALLOCATE(perm(nfaces), stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF
        DO IF = 1, nfaces
            perm(IF) = IF
        END DO

        ! Locates repeated faces and sets their flags = -1
        IF(ncd == 2) THEN
            pile_2D:  DO iv = 1, nverts
                i = f2v%lookup(iv) - 1! Offset
                n = f2v%lookup(iv+1) - f2v%lookup(iv) ! # of elements
                if1_2D: DO j = 1, n
                    if1 = f2v%tab(i+j)
                    IF(iflag(if1) == -1 .OR. islave(if1) /= 0) CYCLE
                    i1 = v2f_%lookup(if1) - 1
                    iv1 = v2f_%tab(i1+1) ! 1st iv of if1
                    iv2 = v2f_%tab(i1+2) ! 2nd iv of if1
                    if2_2D: DO k = j+1, n
                        if2 = f2v%tab(i+k)
                        i2 = v2f_%lookup(if2)-1
                        iv3 = v2f_%tab(i2+1) ! 1st iv of if2
                        iv4 = v2f_%tab(i2+2) ! 2nd iv of if2
                        !---
                        IF(iv4 == iv1 .AND. iv3 == iv2) THEN
                            iflag(if2) = -1
                            islave(if1) = imaster(if2)
                            imaster(if2) = 0
                            perm(if2) = if1
                            EXIT if2_2D
                        END IF
                    END DO if2_2D
                END DO if1_2D
            END DO pile_2D
        ELSE IF(ncd == 3) THEN
            ALLOCATE(buf(6),stat=info)
            IF(info /= 0) THEN
                WRITE(*,100)
                CALL abort_psblas
            END IF
            ! ---
            pile_3D:  DO iv = 1, nverts
                i = f2v%lookup(iv) - 1! Offset
                n = f2v%lookup(iv+1) - f2v%lookup(iv) ! # of elements
                if1_3D: DO j = 1, n-1
                    if1=f2v%tab(i+j)
                    IF(iflag(if1) == -1 .OR. islave(if1) /= 0) CYCLE
                    ! iflag(if1) = -1  --> repeated face
                    ! islave(if1) /= 0 --> already examined face
                    i1 = v2f_%lookup(if1) - 1
                    iv1 = v2f_%tab(i1+1)
                    iv2 = v2f_%tab(i1+2)
                    iv3 = v2f_%tab(i1+3)
                    found = .FALSE.
                    if2_3D: DO k = j+1, n
                        if2 = f2v%tab(i+k)
                        i2 = v2f_%lookup(if2)
                        j2 = v2f_%lookup(if2+1) - 1
                        l = fnv(if2)
                        ! Copies if2 iv-sequence in buf
                        buf(1) = v2f_%tab(j2)
                        buf(2:(l+1)) = v2f_%tab(i2:j2)
                        buf(l+2) = v2f_%tab(i2)
                        IF(l == 3) buf(6) = 0
                        !---
                        ! Searches for iv2 in buf
                        match: DO m = 2, (l+1)
                            IF(buf(m) /= iv2) CYCLE
                            IF(buf(m+1) == iv1 .AND. buf(m-1) == iv3) THEN
                                iflag(if2) = -1
                                islave(if1) = imaster(if2)
                                imaster(if2) = 0
                                perm(if2) = if1
                                found = .TRUE.
                            END IF
                        END DO match
                        IF(found) EXIT if2_3D
                    END DO if2_3D
                END DO if1_3D
            END DO pile_3D
            DEALLOCATE(buf)
        END IF
        CALL f2v%free_table()

        ! ###########################################################################
        IF (debug) THEN
            DO IF = 1, nfaces
                WRITE(*,310) IF, iflag(IF), imaster(IF), islave(IF)
            END DO
            WRITE(*,*)
    310     FORMAT(' face: ',i4,' flag: ',i2,' master: ',i4,' slave: ',i4)
        END IF
        ! ###########################################################################

        ! Completes the definition of permutation array
        ! new=perm(old)
        ! old=pinv(new)
        !
        ! By first faces with iflag(if)=0 ...
        j = 0
        DO IF = 1, nfaces
            IF(iflag(IF) == 0) THEN
                j = j + 1
                perm(IF) = j
            END IF
        END DO
        ! ... then faces with iflag(if)=-1
        DO IF = 1, nfaces
            IF(iflag(IF) == -1) THEN
                j = perm(IF)
                perm(IF) = perm(j)
            END IF
        END DO

        ! ###########################################################################
        IF(debug) THEN
            n = COUNT(iflag == 0)
            DO IF = 1, nfaces
                i1 = v2f_%lookup(IF)
                k = fnv(IF)
                WRITE(*,320) IF, iflag(IF), perm(IF), (v2f_%tab(j), j = i1, i1+k-1)
            END DO
            WRITE(*,*)
            DO IF = 1, nfaces
                i1 = v2f_%lookup(IF)
                k = fnv(IF)
            END DO
    320     FORMAT(' face: ',i7,' flag: ',i2,' perm: ',i7,' vertices',4i7)
        END IF
        ! ###########################################################################

        ! Reordering of face-based arrays

        ! Updates NFACES and stores OLD NFACES in N
        n = nfaces
        nfaces = COUNT(iflag == 0)

        ! Allocation of PINV and definitive face-related arrays
        ALLOCATE(pinv(nfaces), facenv(nfaces), faceflag(nfaces),&
            & facemaster(nfaces), faceslave(nfaces), stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        ! Builds inverse permutation array for the NEW first NFACES faces
        DO IF = 1, n
            IF (iflag(IF) == 0) THEN
                j = perm(IF)
                pinv(j) = IF
            END IF
        END DO

        ! Reordering and assignment of definitive face-related arrays
        DO IF = 1, nfaces
            j = pinv(IF)

            facenv(IF)     = fnv(j)
            faceflag(IF)   = 0
            facemaster(IF) = imaster(j)
            faceslave(IF)  = islave(j)
        END DO
        DEALLOCATE(iflag,imaster,islave,fnv)

        ! Reordering and reallocation of v2f_
        k = 0
        DO IF = 1, nfaces
            j = k
            k = j + facenv(IF)
        END DO
        !
        CALL dmy%alloc_table(nel=nfaces,ntab=k)
        i1 = 1; i2 = 0; dmy%lookup(1) = 1
        DO IF = 1, nfaces
            j = pinv(IF)
            i2 = i1 + facenv(IF) - 1
            j1 = v2f_%lookup(j)
            j2 = j1 + facenv(IF) - 1
            dmy%tab(i1:i2) = v2f_%tab(j1:j2)
            i1 = i2 + 1
            dmy%lookup(IF+1) = i1
        END DO
        CALL v2f_%free_table()

        CALL v2f_%alloc_table(nel=nfaces,ntab=k)
        v2f_%lookup = dmy%lookup(1:nfaces+1)
        v2f_%tab = dmy%tab(1:k)

        ! Reordering of f2c_%tab
        DO ic = 1, ncells
            i1 = f2c_%lookup(ic)
            i2 = f2c_%lookup(ic+1) - 1
            DO i = i1, i2
                j = f2c_%tab(i)
                f2c_%tab(i) = perm(j)
            END DO
        END DO

        CALL dmy%free_table()
        DEALLOCATE(perm,pinv)

        ! ###########################################################################
        IF(debug) THEN
            DO IF = 1, nfaces
                i1 = v2f_%lookup(IF)
                i2 = v2f_%lookup(IF+1) - 1
                WRITE(*,330) IF, facemaster(IF), faceslave(IF), v2f_%tab(i1:i2)
            END DO
            WRITE(*,*)
            DO ic = 1, ncells
                i1 = f2c_%lookup(ic)
                i2 = f2c_%lookup(ic+1) - 1
                WRITE(*,340) ic, f2c_%tab(i1:i2)
            END DO
            WRITE(*,*)
    330     FORMAT(' face: ',i7, ' master: ',i7,' slave: ',i7,' vertices: ',4i7)
    340     FORMAT(' cell: ',i7, ' faces:',6(1x,i7))
        END IF
        ! ###########################################################################

        ! - Reads and assigns boundary conditions. Boundary flags are integer
        ! in the range [1-nbc]. If NBC = 0 from import, automatically NBC = 1 and where
        ! faceslave = 0 a boundary face is asssumed.
        ! - Builds list of faces, grouping them by their flag value.
        !
        ! faceflag(if)=0 --> fluid face
        ! faceflag(if)=i  --> i-th boundary face
        !

        ! Counts boundary faces (faceslave = 0)
        k = COUNT(faceslave == 0)

        IF (nbc > 0) THEN
          ALLOCATE(f2b%lookup(nbc), f2b%tab(k))
          i1 = 1
          DO ib = 1, nbc
            f2b%lookup(ib) = i1
            i2 = i1 + nbcf(ib) - 1
            DO j = 1, nbcf(ib)
              if = faceid(i1 + j - 1)
              vi = facev(if, :)
              jf_loop: DO jf = 1, nfaces
                IF (faceslave(jf) /= 0) CYCLE jf_loop
                j1 = v2f_%lookup(jf)
                j2 = v2f_%lookup(jf+1) - 1
                vj = v2f_%tab(j1:j2)
                IF (ANY(vi == vj(1)) .AND. ANY(vi == vj(2)) .AND. ANY(vi == vj(3))) THEN
                  f2b%tab(if) = jf
                  faceflag(jf) = ib
                  EXIT jf_loop
                END IF
              END DO jf_loop
            END DO
            i1 = i2 + 1
          END DO

        ELSE
          WRITE( *, *) "ERROR! No boundary conditions in GMSH file."
          CALL abort_psblas
        END IF

        ! Reordering of if-indexing following the flag sequence: 0,1,2,...,nbc
        ! f2b%tab is used for building the inverse permutation array pinv
        ! old = pinv(new)
        ! new = perm(old)

        k=SIZE(v2f_%tab)
        ALLOCATE(perm(nfaces),pinv(nfaces),aux(4,nfaces),stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF
        CALL dmy%alloc_table(nel=nfaces,ntab=k)

        ! Builds pinv
        k = 0
        ! First fluid faces ...
        DO IF = 1, nfaces
            IF(faceflag(IF) == 0) THEN
                k = k + 1
                pinv(k) = IF
            END IF
        END DO
        ! ... then bc faces.

        IF ( nfaces-k /= SIZE(f2b%tab) ) THEN
            WRITE(6,*) nfaces, k, nfaces-k, size(f2b%tab)
            WRITE(6,400)
            WRITE(6,*)"Check that the CAD model exported all faces."
            CALL abort_psblas
        ENDIF

        pinv(k+1:nfaces) = f2b%tab

        DO IF = 1, nfaces
            aux(1,IF) = facenv(IF)
            aux(2,IF) = faceflag(IF)
            aux(3,IF) = facemaster(IF)
            aux(4,IF) = faceslave(IF)
        END DO

        DO IF = 1, nfaces
            j = pinv(IF)
            perm(j) = IF ! Permutation array
            facenv(IF) = aux(1,j)
            faceflag(IF) = aux(2,j)
            facemaster(IF) = aux(3,j)
            faceslave(IF) = aux(4,j)
        END DO

        ! Reordering of v2f_%tab and v2f_%lookup
        k  = SIZE(v2f_%tab)
        dmy%lookup  = v2f_%lookup(1:nfaces+1)
        dmy%tab = v2f_%tab(1:k)
        i1 = 1; i2 = 0; v2f_%tab(i1) = 1
        DO IF = 1, nfaces
            i2 = i1 + facenv(IF) - 1

            j = pinv(IF)
            j1 = dmy%lookup(j)
            j2 = j1 + facenv(IF) - 1

            v2f_%tab(i1:i2) = dmy%tab(j1:j2)

            i1 = i2 + 1
            v2f_%lookup(IF+1) = i1
        END DO

        ! Reordering of f2c_%tab
        k = SIZE(f2c_%tab)
        DO i = 1, k
            j = f2c_%tab(i)
            f2c_%tab(i) = perm(j)
        END DO

        ! Counts total number of bc faces
        nbcfaces = COUNT(faceslave == 0)

        ! Redefinition of f2b%tab
        k = COUNT(faceflag == 0) ! Fluid faces
        DO IF = 1, nbcfaces
            f2b%tab(IF) = IF + k
        END DO

        ! ###########################################################################
        IF (debug) THEN
            WRITE(*,350) (f2b%tab(i), i = 1, f2b%lookup(1) -1)
            WRITE(*,*)

            DO ib = 1, nbc
                i1 = f2b%lookup(ib)
                i2 = i1 + nbcf(ib) - 1
                WRITE(*,360) ib, f2b%tab(i1:i2)
            END DO
            WRITE(*,*)

            DO IF = 1, nfaces
                WRITE(*,370) IF, faceflag(IF), facemaster(IF), faceslave(IF)
            END DO
            WRITE(*,*)

            DO i = 0, nbc
                WRITE(*,380) i, COUNT(faceflag == i)
            END DO

            WRITE(*,*)
    350     FORMAT(' Fluid faces: ',5i8:/(14x,5i8))
    360     FORMAT(' Bcset: ',i2,' List of faces: ', 5i8:/(40x,5i8:))
    370     FORMAT(' faces: ',i7,' Flag: ',i2,' Master: ',i7,' Slave: ',i7)
    380     FORMAT(' Total amount of faces with flag',i3,':',i8)
    400     FORMAT(' Fatal Error in RD_GMSH_MESH:  inconsistent face, boundary lists.')
        END IF
        ! ###########################################################################

        ! f2b is no longer useful. It can be deallocated
        CALL f2b%free_table()
        CALL dmy%free_table()
        DEALLOCATE(perm,pinv,aux,nbcf)

        ! Defines ON_BOUNDARY array
        ALLOCATE(on_boundary(nverts),stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF
        on_boundary = .FALSE.

        k = COUNT(faceflag == 0) + 1 ! Offset

        ! Loop on boundary faces
        DO IF = k, nfaces
            i1 = v2f_%lookup(IF)
            i2 = v2f_%lookup(IF+1) - 1
            DO i = i1, i2
                iv = v2f_%tab(i)
                on_boundary(iv) = .TRUE.
            END DO
        END DO

        ! Copies vertex-related data in to the object VERTS of VERTEX class
        CALL alloc_vertex(verts,nverts)
        verts = vertex_(xv,yv,zv,on_boundary)
        DEALLOCATE(xv,yv,zv,on_boundary)

        ! Copies face-related data in to the object FACES of FACE class
        CALL alloc_face(faces,nfaces)
        faces = face_(facenv,facemaster,faceslave,faceflag)
        DEALLOCATE(facenv,facemaster,faceslave,faceflag)

        ! Copies cell-related data in to the object CELLS of CELL class
        CALL alloc_cell(cells,ncells)
        cells = cell_(cellnv,cellnf,cellgroup,cellgeo)
        DEALLOCATE(cellnv,cellnf,cellgroup,cellgeo)

        ! Copies connectivities  V2F, V2C, F2C to dummy arguments V2F_, V2C_, F2C_
        ! (objects of CONNECTIVITY class)
        CALL alloc_conn(v2f,nel=nfaces,nconn=SIZE(v2f_%tab))
        CALL alloc_conn(v2c,nel=ncells,nconn=SIZE(v2c_%tab))
        CALL alloc_conn(f2c,nel=ncells,nconn=SIZE(f2c_%tab))
        CALL alloc_conn(c2g,nel=ngroups,nconn=SIZE(c2g_%tab))

        DO IF = 1, nfaces
            i1 = v2f_%lookup(IF)
            i2 = v2f_%lookup(IF+1) - 1
            CALL v2f%set_ith_conn(IF,v2f_%tab(i1:i2))
        END DO

        DO ic = 1, ncells
            i1 = v2c_%lookup(ic)
            i2 = v2c_%lookup(ic+1) - 1
            CALL v2c%set_ith_conn(ic,v2c_%tab(i1:i2))
        END DO

        DO ic = 1, ncells
            i1 = f2c_%lookup(ic)
            i2 = f2c_%lookup(ic+1) - 1
            CALL f2c%set_ith_conn(ic,f2c_%tab(i1:i2))
        END DO

        DO ig = 1, ngroups
            i1 = c2g_%lookup(ig)
            i2 = c2g_%lookup(ig+1) - 1
            CALL c2g%set_ith_conn(ig,c2g_%tab(i1:i2))
        END DO

        ! Deallocates local copies of connectivity data
        CALL v2f_%free_table()
        CALL v2c_%free_table()
        CALL f2c_%free_table()
        CALL c2g_%free_table()

        WRITE(*,'()')

        !     FORMAT Instructions
050     FORMAT(' ERROR! Failure to open Gmsh mesh file.',/,&
        &    ' File expected: ', a)
100     FORMAT(' ERROR! Memory allocation failure in RD_GMSH_MESH')

    END PROCEDURE rd_gmsh_mesh

END SUBMODULE rd_gmsh_implementation


!===============================================================================
! Copyright 2004-2020 Intel Corporation.
!
! This software and the related documents are Intel copyrighted  materials,  and
! your use of  them is  governed by the  express license  under which  they were
! provided to you (License).  Unless the License provides otherwise, you may not
! use, modify, copy, publish, distribute,  disclose or transmit this software or
! the related documents without Intel's prior written permission.
!
! This software and the related documents  are provided as  is,  with no express
! or implied  warranties,  other  than those  that are  expressly stated  in the
! License.
!===============================================================================

!   Content:
!           Intel(R) Math Kernel Library (Intel(R) MKL) DSS Fortran header file
!
!           Contains more detailed information on internal datatypes and
!           constants used by DSS interface to PARDISO.
!
!*******************************************************************************

      MODULE MKL_SPARSE_HANDLE

      USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T

      ENUM, BIND(C)
          ENUMERATOR :: MKL_ZERO_BASED, MKL_ONE_BASED
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_C_STYLE, MKL_FORTRAN_STYLE
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_NO_PRINT, MKL_PRINT
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_GENERAL_STRUCTURE, MKL_UPPER_TRIANGULAR, MKL_LOWER_TRIANGULAR, MKL_STRUCTURAL_SYMMETRIC
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_CSR
      END ENUM

      TYPE, BIND(C) :: SPARSE_STRUCT
          INTEGER N
          INTEGER (C_INTPTR_T) :: CSR_IA
          INTEGER (C_INTPTR_T) :: CSR_JA
          INTEGER CHECK_RESULT(3)
          INTEGER(KIND=4) INDEXING
          INTEGER(KIND=4) MATRIX_STRUCTURE
          INTEGER(KIND=4) MATRIX_FORMAT
          INTEGER(KIND=4) MESSAGE_LEVEL
          INTEGER(KIND=4) PRINT_STYLE
      END TYPE SPARSE_STRUCT

      INTERFACE

          FUNCTION sparse_matrix_checker(PT)
              IMPORT SPARSE_STRUCT
              TYPE(SPARSE_STRUCT), INTENT(INOUT) :: PT
              INTEGER sparse_matrix_checker
          END

          SUBROUTINE sparse_matrix_checker_init(PT)
              IMPORT SPARSE_STRUCT
              TYPE(SPARSE_STRUCT), INTENT(INOUT) :: PT
          END

      END INTERFACE

      INTEGER, PARAMETER :: MKL_SPARSE_CHECKER_SUCCESS = 0
      INTEGER, PARAMETER :: MKL_SPARSE_CHECKER_NON_MONOTONIC = 21
      INTEGER, PARAMETER :: MKL_SPARSE_CHECKER_OUT_OF_RANGE = 22
      INTEGER, PARAMETER :: MKL_SPARSE_CHECKER_NONTRIANGULAR = 23
      INTEGER, PARAMETER :: MKL_SPARSE_CHECKER_NONORDERED = 24

      END MODULE MKL_SPARSE_HANDLE


c
c Example analysis for "p p > ta+ ta- [QCD]" process.
c
C----------------------------------------------------------------------
      SUBROUTINE RCLOS()
C     DUMMY IF HBOOK IS USED
C----------------------------------------------------------------------
      END

C----------------------------------------------------------------------
      SUBROUTINE PYABEG(nnn,wwwi)
C     USER''S ROUTINE FOR INITIALIZATION
C----------------------------------------------------------------------
      INCLUDE 'HEPMC.INC'
      include 'reweight0.inc'
      integer j,kk,l,i,nnn
      character*5 cc(2)
      data cc/'     ','Born '/
      integer nwgt_analysis
      common/c_analysis/nwgt_analysis
      character*50 weights_info(max_weight_shower)
     $     ,wwwi(max_weight_shower)
c
      call inihist
      weights_info(1)="central value  "
      do i=1,nnn+1
         weights_info(i+1)=wwwi(i)
      enddo
      nwgt=nnn+1
      nwgt_analysis=nwgt
      do i=1,1
      do kk=1,nwgt_analysis
        l=(kk-1)*8+(i-1)*4
        call mbook(l+1,'total rate  '//cc(i)//weights_info(kk),
     &       1.0d0,0.5d0,5.5d0)
        call mbook(l+2,'ta+ta- mass '//cc(i)//weights_info(kk),
     &       5d0,0d0,200d0)
        call mbook(l+3,'ta+ta- rap  '//cc(i)//weights_info(kk),
     &       0.25d0,-5d0,5d0)
        call mbook(l+4,'ta+ta- pt   '//cc(i)//weights_info(kk),
     &       20d0,0d0,400d0)
      enddo
      enddo
 999  END

C----------------------------------------------------------------------
      SUBROUTINE PYAEND(IEVTTOT)
C     USER''S ROUTINE FOR TERMINAL CALCULATIONS, HISTOGRAM OUTPUT, ETC
C----------------------------------------------------------------------
      INCLUDE 'HEPMC.INC'
      REAL*8 XNORM,IEVTTOT
      INTEGER I,J,KK,l,nwgt_analysis
      integer NPL
      parameter(NPL=15000)
      common/c_analysis/nwgt_analysis
      OPEN(UNIT=99,FILE='PYTLL.TOP',STATUS='UNKNOWN')
C XNORM IS SUCH THAT THE CROSS SECTION PER BIN IS IN PB, SINCE THE HERWIG
C WEIGHT IS IN NB, AND CORRESPONDS TO THE AVERAGE CROSS SECTION
      XNORM=IEVTTOT/DFLOAT(NEVHEP)
      DO I=1,NPL
        CALL MFINAL3(I)
        CALL MCOPY(I,I+NPL)
        CALL MOPERA(I+NPL,'F',I+NPL,I+NPL,(XNORM),0.D0)
        CALL MFINAL3(I+NPL)
      ENDDO
C
      do i=1,1
      do kk=1,nwgt_analysis
         l=(kk-1)*8+(i-1)*4
         call multitop(NPL+l+1,NPL-1,3,2,'total rate  ',' ','LIN')
         call multitop(NPL+l+2,NPL-1,3,2,'ta+ ta- mass',' ','LOG')
         call multitop(NPL+l+3,NPL-1,3,2,'ta+ ta- rap ',' ','LOG')
         call multitop(NPL+l+4,NPL-1,3,2,'ta+ ta- pt  ',' ','LOG')
      enddo
      enddo
      CLOSE(99)
      END

C----------------------------------------------------------------------
      SUBROUTINE PYANAL(nnn,xww)
C     USER''S ROUTINE TO ANALYSE DATA FROM EVENT
C----------------------------------------------------------------------
      INCLUDE 'HEPMC.INC'
      include 'reweight0.inc'
      DOUBLE PRECISION HWVDOT,PSUM(4),PH(5),YCUT,XMH,PTH,YH,THV,ETAV,
     #  PPL(5),PPLB(5),PTL,YL,THL,ETAL,PLL,ENL,PTLB,YLB,THLB,ETALB,
     #  PLLB,ENLB,PTPAIR,DLL,CLL,AZI,AZINORM,XMLL,DETALLB,VAR
      INTEGER ICHSUM,ICHINI,IHEP,IV,IFV,IST,ID,IJ,ID1,JPR,IDENT,
     #  ILL,ILLB,IHRD,ILL0,ILLB0,NLP,NLM
      LOGICAL DIDSOF,flag,ISLP,ISLM,FOUNDP,FOUNDM
      REAL*8 PI,wmass,wgamma,bwcutoff,getinvm,getdelphi,getrapidity,
     &getpseudorap
      PARAMETER (PI=3.14159265358979312D0)
      REAL*8 TINY
      INTEGER KK,i,l
      DATA TINY/.1D-5/
      integer nwgt_analysis,max_weight
      common/c_analysis/nwgt_analysis
      parameter (max_weight=maxscales*maxscales+maxpdfs+1)
      double precision ww(max_weight),www(max_weight),xww(max_weight)
      common/cww/ww
c
      ww(1)=xww(2)
      if(nnn.eq.0)ww(1)=1d0
      do i=2,nnn+1
         ww(i)=xww(i)
      enddo
c
      IF (WW(1).EQ.0D0) THEN
         WRITE(*,*)'WW(1) = 0. Stopping'
         STOP
      ENDIF
      IDENT=15
C INCOMING PARTONS MAY TRAVEL IN THE SAME DIRECTION: IT''S A POWER-SUPPRESSED
C EFFECT, SO THROW THE EVENT AWAY
      IF(SIGN(1.D0,PHEP(3,1)).EQ.SIGN(1.D0,PHEP(3,2)))THEN
         WRITE(*,*)'WARNING 111 IN PYANAL'
         GOTO 999
      ENDIF
      DO I=1,nwgt_analysis
         WWW(I)=EVWGT*ww(i)/ww(1)
      ENDDO
      ICHSUM=0
      DIDSOF=.FALSE.
      FOUNDP=.FALSE.
      FOUNDM=.FALSE.
      NLP=0
      NLM=0
      DO 100 IHEP=1,NHEP
        IST=ISTHEP(IHEP)
        ID1=IDHEP(IHEP)
         ISLP=ID1.EQ.IDENT
         ISLM=ID1.EQ.-IDENT
         IF(NLM.EQ.0.AND.ISLM)THEN
            NLM=NLM+1
            ILL=IHEP
            FOUNDM=.TRUE.
         ENDIF
         IF(NLP.EQ.0.AND.ISLP)THEN
            NLP=NLP+1
            ILLB=IHEP
            FOUNDP=.TRUE.
         ENDIF
  100 CONTINUE
      IF(.NOT.FOUNDP.OR..NOT.FOUNDM)THEN
         WRITE(*,*)'NO TAUS FOUND.'
         STOP
      ENDIF
      DO IJ=1,5
        PPL(IJ)=PHEP(IJ,ILL)
        PPLB(IJ)=PHEP(IJ,ILLB)
        PH(IJ)=PPL(IJ)+PPLB(IJ)
      ENDDO
      xmh = getinvm(ph(4),ph(1),ph(2),ph(3))
      yh  = getrapidity(ph(4),ph(3))
      pth = sqrt(max(ph(1)**2+ph(2)**2,0d0))
      var = 1.d0
      do i=1,1
         do kk=1,nwgt_analysis
            l=(kk-1)*8+(i-1)*4
            call mfill(l+1,var,www(kk))
            call mfill(l+2,xmh,www(kk))
            call mfill(l+3,yh,www(kk))
            call mfill(l+4,pth,www(kk))
         enddo
      enddo
C
 999  END

      function getrapidity(en,pl)
      implicit none
      real*8 getrapidity,en,pl,tiny,xplus,xminus,y
      parameter (tiny=1.d-8)
      xplus=en+pl
      xminus=en-pl
      if(xplus.gt.tiny.and.xminus.gt.tiny)then
         if( (xplus/xminus).gt.tiny.and.(xminus/xplus).gt.tiny)then
            y=0.5d0*log( xplus/xminus  )
         else
            y=sign(1.d0,pl)*1.d8
         endif
      else
         y=sign(1.d0,pl)*1.d8
      endif
      getrapidity=y
      return
      end

      function getpseudorap(en,ptx,pty,pl)
      implicit none
      real*8 getpseudorap,en,ptx,pty,pl,tiny,pt,eta,th
      parameter (tiny=1.d-5)
c
      pt=sqrt(ptx**2+pty**2)
      if(pt.lt.tiny.and.abs(pl).lt.tiny)then
        eta=sign(1.d0,pl)*1.d8
      else
        th=atan2(pt,pl)
        eta=-log(tan(th/2.d0))
      endif
      getpseudorap=eta
      return
      end

      function getinvm(en,ptx,pty,pl)
      implicit none
      real*8 getinvm,en,ptx,pty,pl,tiny,tmp
      parameter (tiny=1.d-5)
c
      tmp=en**2-ptx**2-pty**2-pl**2
      if(tmp.gt.0.d0)then
        tmp=sqrt(tmp)
      elseif(tmp.gt.-tiny)then
        tmp=0.d0
      else
        write(*,*)'Attempt to compute a negative mass'
        stop
      endif
      getinvm=tmp
      return
      end

      function getdelphi(ptx1,pty1,ptx2,pty2)
      implicit none
      real*8 getdelphi,ptx1,pty1,ptx2,pty2,tiny,pt1,pt2,tmp
      parameter (tiny=1.d-5)
c
      pt1=sqrt(ptx1**2+pty1**2)
      pt2=sqrt(ptx2**2+pty2**2)
      if(pt1.ne.0.d0.and.pt2.ne.0.d0)then
        tmp=ptx1*ptx2+pty1*pty2
        tmp=tmp/(pt1*pt2)
        if(abs(tmp).gt.1.d0+tiny)then
          write(*,*)'Cosine larger than 1'
          stop
        elseif(abs(tmp).ge.1.d0)then
          tmp=sign(1.d0,tmp)
        endif
        tmp=acos(tmp)
      else
        tmp=1.d8
      endif
      getdelphi=tmp
      return
      end