!----------------------------------------------------------------------
! NEMO system team, System and Interface for oceanic RElocable Nesting
!----------------------------------------------------------------------
!
! DESCRIPTION:
!> @brief This module manage Horizontal grid.
!>
!> @details
!> ** Purpose :   Compute the geographical position (in degre) of the
!>      model grid-points,  the horizontal scale factors (in meters) and
!>      the Coriolis factor (in s-1).
!>
!> ** Method  :   The geographical position of the model grid-points is
!>    defined from analytical functions, fslam and fsphi, the derivatives of which gives the horizontal scale factors e1,e2.
!>    Defining two function fslam and fsphi and their derivatives in the two horizontal directions (fse1 and fse2),
!>    the model grid-point position and scale factors are given by:
!>    - t-point:
!>       - glamt(i,j) = fslam(i    ,j    )   e1t(i,j) = fse1(i    ,j    )
!>       - gphit(i,j) = fsphi(i    ,j    )   e2t(i,j) = fse2(i    ,j    )
!>    - u-point:
!>       - glamu(i,j) = fslam(i+1/2,j    )   e1u(i,j) = fse1(i+1/2,j    )
!>       - gphiu(i,j) = fsphi(i+1/2,j    )   e2u(i,j) = fse2(i+1/2,j    )
!>    - v-point:
!>       - glamv(i,j) = fslam(i    ,j+1/2)   e1v(i,j) = fse1(i    ,j+1/2)
!>       - gphiv(i,j) = fsphi(i    ,j+1/2)   e2v(i,j) = fse2(i    ,j+1/2)
!>    - f-point:
!>       - glamf(i,j) = fslam(i+1/2,j+1/2)   e1f(i,j) = fse1(i+1/2,j+1/2)
!>       - gphif(i,j) = fsphi(i+1/2,j+1/2)   e2f(i,j) = fse2(i+1/2,j+1/2)
!>
!>    Where fse1 and fse2 are defined by:
!>       - fse1(i,j) = ra * rad * SQRT( (cos(phi) di(fslam))**2
!>                                     +          di(fsphi) **2 )(i,j)
!>       - fse2(i,j) = ra * rad * SQRT( (cos(phi) dj(fslam))**2
!>                                     +          dj(fsphi) **2 )(i,j)
!>
!>    The coriolis factor is given at z-point by:
!>        - ff = 2.*omega*sin(gphif)      (in s-1)<br/>
!>
!>        This routine is given as an example, it must be modified
!>      following the user s desiderata. nevertheless, the output as
!>      well as the way to compute the model grid-point position and
!>      horizontal scale factors must be respected in order to insure
!>      second order accuracy schemes.
!>
!> @note If the domain is periodic, verify that scale factors are also
!>      periodic, and the coriolis term again.
!>
!> ** Action  :
!>    - define  glamt, glamu, glamv, glamf: longitude of t-, u-, v- and f-points (in degre)
!>    - define  gphit, gphiu, gphiv, gphit: latitude  of t-, u-, v-  and f-points (in degre)
!>    - define e1t, e2t, e1u, e2u, e1v, e2v, e1f, e2f: horizontal
!>    - scale factors (in meters) at t-, u-, v-, and f-points.
!>    - define ff: coriolis factor at f-point
!>
!> References :   Marti, Madec and Delecluse, 1992, JGR
!>                Madec, Imbard, 1996, Clim. Dyn.
!>
!> @author
!> G, Madec
!>
!> @date March, 1988 - Original code
!> @date January, 1996
!> - terrain following coordinates
!> @date February, 1997
!> - print mesh informations
!> @date November, 1999
!> - M. Imbard : NetCDF format with IO-IPSL
!> @date Augustr, 2000
!> - D. Ludicone : Reduced section at Bab el Mandeb
!> @date September, 2001
!> - M. Levy : eel config: grid in km, beta-plane
!> @date August, 2002
!> - G. Madec :  F90: Free form and module, namelist
!> @date January, 2004
!> - A.M. Treguier, J.M. Molines : Case 4 (Mercator mesh)
!> use of parameters in par_CONFIG-Rxx.h90, not in namelist
!> @date May, 2004
!> - A. Koch-Larrouy : Add Gyre configuration
!> @date February, 2011
!> - G. Madec : add cell surface (e1e2t)
!> @date September, 2015
!> - J, Paul : rewrite to SIREN format from $Id: domhgr.F90 5506 2015-06-29 15:19:38Z clevy $
!> @date October, 2016
!> - J, Paul : update from trunk (revision 6961): add wetting and drying, ice sheet coupling..
!> - J, Paul : compute coriolis factor at f-point and at t-point
!> - J, Paul : do not use anymore special case for ORCA grid
!>
!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE grid_hgr

   USE netcdf                          ! nf90 library
   USE kind                            ! F90 kind parameter
   USE fct                             ! basic usefull function
   USE global                          ! global parameter
   USE phycst                          ! physical constant
   USE logger                          ! log file manager
   USE file                            ! file manager
   USE var                             ! variable manager
   USE dim                             ! dimension manager
   USE dom                             ! domain manager
   USE grid                            ! grid manager
   USE iom                             ! I/O manager
   USE mpp                             ! MPP manager
   USE iom_mpp                         ! I/O MPP manager
   USE lbc                             ! lateral boundary conditions

   IMPLICIT NONE
   ! NOTE_avoid_public_variables_if_possible

   ! type and variable
   PUBLIC :: TNAMH

   PUBLIC :: tg_tmask
   PUBLIC :: tg_umask
   PUBLIC :: tg_vmask
   PUBLIC :: tg_fmask

!   PUBLIC :: tg_wmask
!   PUBLIC :: tg_wumask
!   PUBLIC :: tg_wvmask

   PUBLIC :: tg_ssmask
!   PUBLIC :: tg_ssumask
!   PUBLIC :: tg_ssvmask
!   PUBLIC :: tg_ssfmask

   PUBLIC :: tg_glamt
   PUBLIC :: tg_glamu
   PUBLIC :: tg_glamv
   PUBLIC :: tg_glamf

   PUBLIC :: tg_gphit
   PUBLIC :: tg_gphiu
   PUBLIC :: tg_gphiv
   PUBLIC :: tg_gphif

   PUBLIC :: tg_e1t
   PUBLIC :: tg_e1u
   PUBLIC :: tg_e1v
   PUBLIC :: tg_e1f

   PUBLIC :: tg_e2t
   PUBLIC :: tg_e2u
   PUBLIC :: tg_e2v
   PUBLIC :: tg_e2f

   PUBLIC :: tg_ff_t
   PUBLIC :: tg_ff_f

   PUBLIC :: tg_gcost
   PUBLIC :: tg_gcosu
   PUBLIC :: tg_gcosv
   PUBLIC :: tg_gcosf

   PUBLIC :: tg_gsint
   PUBLIC :: tg_gsinu
   PUBLIC :: tg_gsinv
   PUBLIC :: tg_gsinf

   ! function and subroutine
   PUBLIC :: grid_hgr_init
   PUBLIC :: grid_hgr_fill
   PUBLIC :: grid_hgr_clean
   PUBLIC :: grid_hgr_nam

   PRIVATE :: grid_hgr__fill_curv
   PRIVATE :: grid_hgr__fill_reg
   PRIVATE :: grid_hgr__fill_plan
   PRIVATE :: grid_hgr__fill_merc
   PRIVATE :: grid_hgr__fill_gyre
   PRIVATE :: grid_hgr__fill_coriolis
   PRIVATE :: grid_hgr__angle

   TYPE TNAMH

      CHARACTER(LEN=lc) :: c_coord
      INTEGER(i4)       :: i_perio

      INTEGER(i4)       :: i_mshhgr
      REAL(dp)          :: d_ppglam0
      REAL(dp)          :: d_ppgphi0

      REAL(dp)          :: d_ppe1_deg
      REAL(dp)          :: d_ppe2_deg
!      REAL(dp)          :: d_ppe1_m
!      REAL(dp)          :: d_ppe2_m

!      INTEGER(i4)       :: i_cla

!      CHARACTER(LEN=lc) :: c_cfg
      INTEGER(i4)       :: i_cfg
      LOGICAL           :: l_bench

   END TYPE

   TYPE(TVAR), SAVE :: tg_tmask
   TYPE(TVAR), SAVE :: tg_umask
   TYPE(TVAR), SAVE :: tg_vmask
   TYPE(TVAR), SAVE :: tg_fmask
!   TYPE(TVAR), SAVE :: tg_wmask
!   TYPE(TVAR), SAVE :: tg_wumask
!   TYPE(TVAR), SAVE :: tg_wvmask

   TYPE(TVAR), SAVE :: tg_ssmask
!   TYPE(TVAR), SAVE :: tg_ssumask
!   TYPE(TVAR), SAVE :: tg_ssvmask
!   TYPE(TVAR), SAVE :: tg_ssfmask

   TYPE(TVAR), SAVE :: tg_glamt
   TYPE(TVAR), SAVE :: tg_glamu
   TYPE(TVAR), SAVE :: tg_glamv
   TYPE(TVAR), SAVE :: tg_glamf

   TYPE(TVAR), SAVE :: tg_gphit
   TYPE(TVAR), SAVE :: tg_gphiu
   TYPE(TVAR), SAVE :: tg_gphiv
   TYPE(TVAR), SAVE :: tg_gphif

   TYPE(TVAR), SAVE :: tg_e1t
   TYPE(TVAR), SAVE :: tg_e1u
   TYPE(TVAR), SAVE :: tg_e1v
   TYPE(TVAR), SAVE :: tg_e1f

   TYPE(TVAR), SAVE :: tg_e2t
   TYPE(TVAR), SAVE :: tg_e2u
   TYPE(TVAR), SAVE :: tg_e2v
   TYPE(TVAR), SAVE :: tg_e2f

   TYPE(TVAR), SAVE :: tg_ff_t
   TYPE(TVAR), SAVE :: tg_ff_f

   TYPE(TVAR), SAVE :: tg_gcost
   TYPE(TVAR), SAVE :: tg_gcosu
   TYPE(TVAR), SAVE :: tg_gcosv
   TYPE(TVAR), SAVE :: tg_gcosf

   TYPE(TVAR), SAVE :: tg_gsint
   TYPE(TVAR), SAVE :: tg_gsinu
   TYPE(TVAR), SAVE :: tg_gsinv
   TYPE(TVAR), SAVE :: tg_gsinf

CONTAINS
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr_init(jpi, jpj, jpk, ld_domcfg)
   !-------------------------------------------------------------------
   !> @brief This subroutine initialise hgr structure
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !> @param[in] jpi
   !> @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      INTEGER(i4), INTENT(IN) :: jpi
      INTEGER(i4), INTENT(IN) :: jpj
      INTEGER(i4), INTENT(IN) :: jpk
      LOGICAL    , INTENT(IN) :: ld_domcfg

      REAL(dp), DIMENSION(jpi,jpj)     :: dl_tmp2D
      REAL(dp), DIMENSION(jpi,jpj,jpk) :: dl_tmp3D
      ! loop indices
      !----------------------------------------------------------------
      ! variable 2D
      dl_tmp2D(:,:)  =dp_fill_i1

      tg_ssmask   = var_init('ssmask' ,dl_tmp2D(:,:)  , dd_fill=dp_fill_i1, id_type=NF90_BYTE)
!      tg_ssumask  = var_init('ssumask',dl_tmp2D(:,:)  , dd_fill=dp_fill_i1, id_type=NF90_BYTE)
!      tg_ssvmask  = var_init('ssvmask',dl_tmp2D(:,:)  , dd_fill=dp_fill_i1, id_type=NF90_BYTE)
!      tg_ssfmask  = var_init('ssfmask',dl_tmp2D(:,:)  , dd_fill=dp_fill_i1, id_type=NF90_BYTE)

      dl_tmp2D(:,:)=dp_fill

      tg_glamt    = var_init('glamt',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_glamu    = var_init('glamu',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_glamv    = var_init('glamv',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_glamf    = var_init('glamf',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)

      tg_gphit    = var_init('gphit',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_gphiu    = var_init('gphiu',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_gphiv    = var_init('gphiv',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_gphif    = var_init('gphif',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)

      tg_e1t      = var_init('e1t'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_e1u      = var_init('e1u'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_e1v      = var_init('e1v'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_e1f      = var_init('e1f'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)

      tg_e2t      = var_init('e2t'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_e2u      = var_init('e2u'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_e2v      = var_init('e2v'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_e2f      = var_init('e2f'  ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)

      tg_ff_t     = var_init('ff_t' ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      tg_ff_f     = var_init('ff_f' ,dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)

      IF( .NOT. ld_domcfg )THEN
         tg_gcost     =var_init('gcost',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
         tg_gcosu     =var_init('gcosu',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
         tg_gcosv     =var_init('gcosv',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
         tg_gcosf     =var_init('gcosf',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)

         tg_gsint     =var_init('gsint',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
         tg_gsinu     =var_init('gsinu',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
         tg_gsinv     =var_init('gsinv',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
         tg_gsinf     =var_init('gsinf',dl_tmp2D(:,:)   , dd_fill=dp_fill, id_type=NF90_DOUBLE)
      ENDIF

      ! variable 3D
      dl_tmp3D(:,:,:)=dp_fill_i1

      tg_tmask   = var_init('tmask'  ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE)
      tg_umask   = var_init('umask'  ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE)
      tg_vmask   = var_init('vmask'  ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE)
      IF( .NOT. ld_domcfg )THEN
         tg_fmask   = var_init('fmask'  ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE)
      ENDIF

!      tg_wmask   = var_init('wmask'  ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE)
!      tg_wumask  = var_init('wumask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE)
!      tg_wvmask  = var_init('wvmask' ,dl_tmp3D(:,:,:), dd_fill=dp_fill_i1, id_type=NF90_BYTE)

   END SUBROUTINE grid_hgr_init
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr_clean(ld_domcfg)
   !-------------------------------------------------------------------
   !> @brief This subroutine clean hgr structure
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      LOGICAL    , INTENT(IN) :: ld_domcfg

      ! local variable
      ! loop indices
      !----------------------------------------------------------------
      CALL var_clean(tg_ssmask  )

      CALL var_clean(tg_glamt)
      CALL var_clean(tg_glamu)
      CALL var_clean(tg_glamv)
      CALL var_clean(tg_glamf)

      CALL var_clean(tg_gphit)
      CALL var_clean(tg_gphiu)
      CALL var_clean(tg_gphiv)
      CALL var_clean(tg_gphif)

      CALL var_clean(tg_e1t  )
      CALL var_clean(tg_e1u  )
      CALL var_clean(tg_e1v  )
      CALL var_clean(tg_e1f  )

      CALL var_clean(tg_e2t  )
      CALL var_clean(tg_e2u  )
      CALL var_clean(tg_e2v  )
      CALL var_clean(tg_e2f  )

      CALL var_clean(tg_ff_t )
      CALL var_clean(tg_ff_f )

      IF( .NOT. ld_domcfg )THEN
         CALL var_clean(tg_gcost )
         CALL var_clean(tg_gcosu )
         CALL var_clean(tg_gcosv )
         CALL var_clean(tg_gcosf )

         CALL var_clean(tg_gsint )
         CALL var_clean(tg_gsinu )
         CALL var_clean(tg_gsinv )
         CALL var_clean(tg_gsinf )
      ENDIF

      CALL var_clean(tg_tmask   )
      CALL var_clean(tg_umask   )
      CALL var_clean(tg_vmask   )
      IF( .NOT. ld_domcfg )THEN
         CALL var_clean(tg_fmask   )
      ENDIF
   END SUBROUTINE grid_hgr_clean
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION grid_hgr_nam(cd_coord, id_perio, cd_namelist) &
         & RESULT (tf_namh)
   !-------------------------------------------------------------------
   !> @brief This function initialise hgr namelist structure
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !> @param[in] cd_coord
   !> @param[in] id_perio
   !> @param[in] cd_namelist
   !> @return hgr namelist structure
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      CHARACTER(LEN=*), INTENT(IN) :: cd_coord
      INTEGER(i4)     , INTENT(IN) :: id_perio
      CHARACTER(LEN=*), INTENT(IN) :: cd_namelist

      ! function
      TYPE(TNAMH)                  :: tf_namh

      ! local variable
      INTEGER(i4)        :: il_status
      INTEGER(i4)        :: il_fileid

      LOGICAL            :: ll_exist

      ! loop indices
      ! namelist

      ! namhgr
      INTEGER(i4)       :: in_mshhgr   = 0
      REAL(dp)          :: dn_ppglam0  = NF90_FILL_DOUBLE
      REAL(dp)          :: dn_ppgphi0  = NF90_FILL_DOUBLE
      REAL(dp)          :: dn_ppe1_deg = NF90_FILL_DOUBLE
      REAL(dp)          :: dn_ppe2_deg = NF90_FILL_DOUBLE
!      REAL(dp)          :: dn_ppe1_m   = NF90_FILL_DOUBLE
!      REAL(dp)          :: dn_ppe2_m   = NF90_FILL_DOUBLE

!      ! namcla
!      INTEGER(i4)       :: in_cla      = 0

      ! namgrd
!      CHARACTER(LEN=lc) :: cn_cfg      = ''
      INTEGER(i4)       :: in_cfg      = 0
      LOGICAL           :: ln_bench    = .FALSE.

      !----------------------------------------------------------------
      NAMELIST /namhgr/ &
      &  in_mshhgr,     &  !< type of horizontal mesh
                           !< 0: curvilinear coordinate on the sphere read in coordinate.nc
                           !< 1: geographical mesh on the sphere with regular grid-spacing
                           !< 2: f-plane with regular grid-spacing
                           !< 3: beta-plane with regular grid-spacing
                           !< 4: Mercator grid with T/U point at the equator
                           !< 5: beta-plane with regular grid-spacing and rotated domain (GYRE configuration)
      &  dn_ppglam0,    &  !< longitude of first raw and column T-point (in_mshhgr = 1 or 4)
      &  dn_ppgphi0,    &  !< latitude  of first raw and column T-point (in_mshhgr = 1 or 4)
      &  dn_ppe1_deg,   &  !< zonal      grid-spacing (degrees)         (in_mshhgr = 1,2,3 or 4)
      &  dn_ppe2_deg       !< meridional grid-spacing (degrees)         (in_mshhgr = 1,2,3 or 4)
!      &  dn_ppe1_m,     &  !< zonal      grid-spacing (degrees)
!      &  dn_ppe2_m         !< meridional grid-spacing (degrees)

!      NAMELIST /namcla/ &
!      &  in_cla            !< =1 cross land advection for exchanges through some straits (ORCA2)

      NAMELIST/namgrd/  &  !< orca grid namelist
!      &  cn_cfg,        &  !< name of the configuration (orca)
      &  in_cfg,        &  !< resolution of the configuration (2,1,025..)
      &  ln_bench          !< benchmark parameter (in_mshhgr = 5 ).

      !----------------------------------------------------------------
      ! read namelist
      INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist)
      IF( ll_exist )THEN

         il_fileid=fct_getunit()

         OPEN( il_fileid, FILE=TRIM(cd_namelist), &
            &             FORM='FORMATTED',       &
            &             ACCESS='SEQUENTIAL',    &
            &             STATUS='OLD',           &
            &             ACTION='READ',          &
            &             IOSTAT=il_status)
         CALL fct_err(il_status)
         IF( il_status /= 0 )THEN
            CALL logger_fatal("GRID HGR NAM: error opening "//&
               &  TRIM(cd_namelist))
         ENDIF

         READ( il_fileid, NML = namhgr  )
!         READ( il_fileid, NML = namcla  )
!         READ( il_fileid, NML = namgrd  )

         CLOSE( il_fileid, IOSTAT=il_status )
         CALL fct_err(il_status)
         IF( il_status /= 0 )THEN
            CALL logger_error("GRID HGR NAM: closing "//TRIM(cd_namelist))
         ENDIF

         tf_namh%c_coord   = TRIM(cd_coord)
         tf_namh%i_perio   = id_perio

         tf_namh%i_mshhgr  = in_mshhgr
         tf_namh%d_ppglam0 = dn_ppglam0
         tf_namh%d_ppgphi0 = dn_ppgphi0

         tf_namh%d_ppe1_deg= dn_ppe1_deg
         tf_namh%d_ppe2_deg= dn_ppe2_deg
!         tf_namh%d_ppe1_m  = dn_ppe1_m
!         tf_namh%d_ppe2_m  = dn_ppe2_m

!         tf_namh%i_cla     = in_cla

!         tf_namh%c_cfg     = TRIM(cn_cfg)
         tf_namh%i_cfg     = in_cfg
         tf_namh%l_bench   = ln_bench

      ELSE

         CALL logger_fatal(" GRID HGR NAM: can't find "//TRIM(cd_namelist))

      ENDIF

   END FUNCTION grid_hgr_nam
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr_fill(td_nam, jpi, jpj, ld_domcfg)
   !-------------------------------------------------------------------
   !> @brief This subroutine fill horizontal mesh (hgr structure)
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !> @param[in] td_nam
   !> @param[in] jpi
   !> @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
      INTEGER(i4), INTENT(IN) :: jpi
      INTEGER(i4), INTENT(IN) :: jpj
      LOGICAL    , INTENT(IN) :: ld_domcfg

      ! local variable
      REAL(dp)    :: znorme
      ! loop indices
      !----------------------------------------------------------------
      CALL logger_info('GRID HGR FILL : define the horizontal mesh from the'//&
      &  ' type of horizontal mesh mshhgr = '//TRIM(fct_str(td_nam%i_mshhgr)))
      IF( td_nam%i_mshhgr == 1 )THEN
         CALL logger_info('   position of the first row and     ppglam0  = '//&
            &  TRIM(fct_str(td_nam%d_ppglam0  )) )
         CALL logger_info('   column grid-point (degrees)       ppgphi0  = '//&
            &  TRIM(fct_str(td_nam%d_ppgphi0  )) )
      ELSEIF( td_nam%i_mshhgr == 2 .OR. td_nam%i_mshhgr == 3  )THEN
         CALL logger_info('   zonal      grid-spacing (degrees) ppe1_deg = '//&
            &  TRIM(fct_str(td_nam%d_ppe1_deg )) )
         CALL logger_info('   meridional grid-spacing (degrees) ppe2_deg = '//&
            &  TRIM(fct_str(td_nam%d_ppe2_deg )) )
!         CALL logger_info('   zonal      grid-spacing (meters)  ppe1_m   = '//&
!            &  TRIM(fct_str(td_nam%d_ppe1_m   )) )
!         CALL logger_info('   meridional grid-spacing (meters)  ppe2_m   = '//&
!            &  TRIM(fct_str(td_nam%d_ppe2_m   )) )
      ENDIF

      SELECT CASE( td_nam%i_mshhgr ) ! type of horizontal mesh

         CASE(0)   !  curvilinear coordinate on the sphere read in coordinate.nc file

            CALL grid_hgr__fill_curv(td_nam)!,jpi,jpj)

         CASE(1)   ! geographical mesh on the sphere with regular grid-spacing

            CALL grid_hgr__fill_reg(td_nam,jpi,jpj)

         CASE(2:3) ! f- or beta-plane with regular grid-spacing

            CALL grid_hgr__fill_plan(td_nam,jpi,jpj)

         CASE(4)   ! geographical mesh on the sphere, isotropic MERCATOR type

            CALL grid_hgr__fill_merc(td_nam,jpi,jpj)

         CASE(5)   ! beta-plane with regular grid-spacing and rotated domain (GYRE configuration)

            CALL grid_hgr__fill_gyre(td_nam,jpi,jpj)

         CASE DEFAULT

            CALL logger_fatal('GRID HGR FILL : bad flag value for mshhgr = '//&
               &  TRIM(fct_str(td_nam%i_mshhgr)))

      END SELECT

      ! No Useful associated horizontal metrics
      ! ---------------------------------------

      ! create coriolis factor
      CALL grid_hgr__fill_coriolis(td_nam,jpi)!,jpj)

      ! Control of domain for symetrical condition
      ! ------------------------------------------
      ! The equator line must be the latitude coordinate axe

      IF( td_nam%i_perio == 2 ) THEN
         znorme = SQRT( SUM(tg_gphiu%d_value(:,2,1,1)*tg_gphiu%d_value(:,2,1,1)) ) / FLOAT( jpi )
         IF( znorme > 1.e-13 )THEN
            CALL logger_fatal( ' ===>>>> : symmetrical condition: rerun with good equator line' )
         ENDIF
      ENDIF

      ! compute angles between model grid lines and the North direction
      ! ---------------------------------------------------------------
      IF( .NOT. ld_domcfg )THEN
         CALL grid_hgr__angle(td_nam,jpi,jpj)
      ENDIF

   END SUBROUTINE grid_hgr_fill
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr__fill_curv(td_nam)!,jpi,jpj)
   !-------------------------------------------------------------------
   !> @brief This subroutine fill horizontal mesh (hgr structure)
   !> for case of curvilinear coordinate on the sphere read in coordinate.nc file
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !> @date October, 2016
   !> - do not use anymore special case for ORCA grid
   !>
   !> @param[in] td_nam
   ! @param[in] jpi
   ! @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
!      INTEGER(i4), INTENT(IN) :: jpi
!      INTEGER(i4), INTENT(IN) :: jpj

      ! local variable
!      INTEGER(i4) :: ii0, ii1, ij0, ij1   ! temporary integers
!      INTEGER(i4) :: isrow                ! index for ORCA1 starting row

      TYPE(TMPP)  :: tl_coord

      ! loop indices
      !----------------------------------------------------------------

      ! read coordinates
      ! open file
      IF( td_nam%c_coord /= '' )THEN
         tl_coord=mpp_init( file_init(TRIM(td_nam%c_coord)), id_perio=td_nam%i_perio)
         CALL grid_get_info(tl_coord)
      ELSE
         CALL logger_fatal("GRID HGR FILL: no input coordinates file found. "//&
         &     "check namelist")
      ENDIF

      CALL iom_mpp_open( tl_coord )

      ! read variable in coordinates
      tg_glamt=iom_mpp_read_var(tl_coord, 'glamt')
      tg_glamu=iom_mpp_read_var(tl_coord, 'glamu')
      tg_glamv=iom_mpp_read_var(tl_coord, 'glamv')
      tg_glamf=iom_mpp_read_var(tl_coord, 'glamf')

      tg_gphit=iom_mpp_read_var(tl_coord, 'gphit')
      tg_gphiu=iom_mpp_read_var(tl_coord, 'gphiu')
      tg_gphiv=iom_mpp_read_var(tl_coord, 'gphiv')
      tg_gphif=iom_mpp_read_var(tl_coord, 'gphif')

      ! force output type
      tg_glamt%i_type=NF90_DOUBLE
      tg_glamu%i_type=NF90_DOUBLE
      tg_glamv%i_type=NF90_DOUBLE
      tg_glamf%i_type=NF90_DOUBLE

      tg_gphit%i_type=NF90_DOUBLE
      tg_gphiu%i_type=NF90_DOUBLE
      tg_gphiv%i_type=NF90_DOUBLE
      tg_gphif%i_type=NF90_DOUBLE

      tg_e1t  =iom_mpp_read_var(tl_coord, 'e1t')
      tg_e1u  =iom_mpp_read_var(tl_coord, 'e1u')
      tg_e1v  =iom_mpp_read_var(tl_coord, 'e1v')
      tg_e1f  =iom_mpp_read_var(tl_coord, 'e1f')

      tg_e2t  =iom_mpp_read_var(tl_coord, 'e2t')
      tg_e2u  =iom_mpp_read_var(tl_coord, 'e2u')
      tg_e2v  =iom_mpp_read_var(tl_coord, 'e2v')
      tg_e2f  =iom_mpp_read_var(tl_coord, 'e2f')

      CALL iom_mpp_close( tl_coord )
      ! clean
      CALL mpp_clean(tl_coord)

      !! WARNING extended grid have to be correctly fill

!      !! special case for ORCA grid
!      ! ORCA R2 configuration
!      IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 2 ) THEN
!            IF( td_nam%i_cla == 0 ) THEN
!               !
!               ! Gibraltar Strait (e2u = 20 km)
!               ii0 = 139   ;   ii1 = 140
!               ij0 = 102   ;   ij1 = 102
!               ! e2u = 20 km
!               tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  20.e3
!               CALL logger_info('orca_r2: Gibraltar    : e2u reduced to 20 km')
!               !
!               ! Bab el Mandeb (e2u = 18 km)
!               ii0 = 160   ;   ii1 = 160
!               ij0 =  88   ;   ij1 =  88
!               ! e1v = 18 km
!               tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) =  18.e3
!               ! e2u = 30 km
!               tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  30.e3
!
!               CALL logger_info('orca_r2: Bab el Mandeb: e2u reduced to 30 km')
!               CALL logger_info('e1v reduced to 18 km')
!            ENDIF
!            ! Danish Straits
!            ii0 = 145   ;   ii1 = 146
!            ij0 = 116   ;   ij1 = 116
!            ! e2u = 10 km
!            tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  10.e3
!            CALL logger_info('orca_r2: Danish Straits : e2u reduced to 10 km')
!      ENDIF
!
!      ! ORCA R1 configuration
!      IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 1 ) THEN
!         ! This dirty section will be suppressed by simplification process: all this will come back in input files
!         ! Currently these hard-wired indices relate to configuration with
!         ! extend grid (jpjglo=332)
!         ! which had a grid-size of 362x292.
!
!         isrow = 332 - jpj
!
!         ! Gibraltar Strait (e2u = 20 km)
!         ii0 = 282           ;   ii1 = 283
!         ij0 = 201 + isrow   ;   ij1 = 241 - isrow
!         ! e2u = 20 km
!         tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  20.e3
!         CALL logger_info('orca_r1: Gibraltar : e2u reduced to 20 km')
!
!         ! Bhosporus Strait (e2u = 10 km)
!         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km)
!         ij0 = 208 + isrow   ;   ij1 = 248 - isrow
!         ! Bhosporus Strait (e2u = 10 km)
!         tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  10.e3
!         CALL logger_info('orca_r1: Bhosporus : e2u reduced to 10 km')
!
!         ! Lombok Strait (e1v = 13 km)
!         ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v = 13 km)
!         ij0 = 124 + isrow   ;   ij1 = 165 - isrow
!         ! Lombok Strait (e1v = 13 km)
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) =  13.e3
!         CALL logger_info('orca_r1: Lombok : e1v reduced to 10 km')
!
!         ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on]
!         ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on]
!         ij0 = 124 + isrow   ;   ij1 = 165 - isrow
!         ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on]
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) =  8.e3
!         CALL logger_info('orca_r1: Sumba : e1v reduced to 8 km')
!
!         ! Ombai Strait (e1v = 13 km)
!         ii0 =  53           ;   ii1 =  53        ! Ombai Strait (e1v = 13 km)
!         ij0 = 124 + isrow   ;   ij1 = 165 - isrow
!         ! Ombai Strait (e1v = 13 km)
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 13.e3
!         CALL logger_info('orca_r1: Ombai : e1v reduced to 13 km')
!
!         ! Timor Passage (e1v = 20 km)
!         ii0 =  56           ;   ii1 =  56        ! Timor Passage (e1v = 20 km)
!         ij0 = 124 + isrow   ;   ij1 = 145 - isrow
!         ! Timor Passage (e1v = 20 km)
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 20.e3
!         CALL logger_info('orca_r1: Timor Passage : e1v reduced to 20 km')
!
!          ! West Halmahera Strait (e1v = 30 km)
!         ii0 =  55           ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km)
!         ij0 = 141 + isrow   ;   ij1 = 182 - isrow
!         ! West Halmahera Strait (e1v = 30 km)
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 30.e3
!         CALL logger_info('orca_r1: W Halmahera : e1v reduced to 30 km')
!
!         ! East Halmahera Strait (e1v = 50 km)
!         ii0 =  58           ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km)
!         ij0 = 141 + isrow   ;   ij1 = 182 - isrow
!         ! East Halmahera Strait (e1v = 50 km)
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) = 50.e3
!         CALL logger_info('orca_r1: E Halmahera : e1v reduced to 50 km')
!
!      ENDIF
!
!      ! ORCA R05 configuration
!      IF( TRIM(td_nam%c_cfg) == "orca" .AND. td_nam%i_cfg == 05 ) THEN
!
!         ! Gibraltar Strait (e2u = 20 km)
!         ii0 = 563   ;   ii1 = 564        ! Gibraltar Strait (e2u = 20 km)
!         ij0 = 327   ;   ij1 = 327
!         ! Gibraltar Strait (e2u = 20 km)
!         tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  20.e3
!         CALL logger_info('orca_r05: Reduced e2u at the Gibraltar Strait')
!         !
!         ! Bosphore Strait (e2u = 10 km)
!         ii0 = 627   ;   ii1 = 628        ! Bosphore Strait (e2u = 10 km)
!         ij0 = 343   ;   ij1 = 343
!         ! Bosphore Strait (e2u = 10 km)
!         tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  10.e3
!         CALL logger_info('orca_r05: Reduced e2u at the Bosphore Strait')
!         !
!         ! Sumba Strait (e2u = 40 km)
!         ii0 =  93   ;   ii1 =  94        ! Sumba Strait (e2u = 40 km)
!         ij0 = 232   ;   ij1 = 232
!         ! Sumba Strait (e2u = 40 km)
!         tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  40.e3
!         CALL logger_info('orca_r05: Reduced e2u at the Sumba Strait')
!         !
!         ! Ombai Strait (e2u = 15 km)
!         ii0 = 103   ;   ii1 = 103        ! Ombai Strait (e2u = 15 km)
!         ij0 = 232   ;   ij1 = 232
!         ! Ombai Strait (e2u = 15 km)
!         tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  15.e3
!         CALL logger_info('orca_r05: Reduced e2u at the Ombai Strait')
!         !
!         ! Palk Strait (e2u = 10 km)
!         ii0 =  15   ;   ii1 =  15        ! Palk Strait (e2u = 10 km)
!         ij0 = 270   ;   ij1 = 270
!         ! Palk Strait (e2u = 10 km)
!         tg_e2u%d_value(ii0:ii1,ij0:ij1,1,1) =  10.e3
!         CALL logger_info('orca_r05: Reduced e2u at the Palk Strait')
!         !
!         ! Lombok Strait (e1v = 10 km)
!         ii0 =  87   ;   ii1 =  87        ! Lombok Strait (e1v = 10 km)
!         ij0 = 232   ;   ij1 = 233
!         ! Lombok Strait (e1v = 10 km)
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) =  10.e3
!         CALL logger_info('orca_r05: Reduced e1v at the Lombok Strait')
!         !
!         !
!         ! Bab el Mandeb (e1v = 25 km)
!         ii0 = 662   ;   ii1 = 662        ! Bab el Mandeb (e1v = 25 km)
!         ij0 = 276   ;   ij1 = 276
!         ! Bab el Mandeb (e1v = 25 km)
!         tg_e1v%d_value(ii0:ii1,ij0:ij1,1,1) =  25.e3
!         CALL logger_info('orca_r05: Reduced e1v at the Bab el Mandeb')
!
!      ENDIF

   END SUBROUTINE grid_hgr__fill_curv
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr__fill_reg(td_nam, jpi, jpj)
   !-------------------------------------------------------------------
   !> @brief This subroutine fill horizontal mesh (hgr structure)
   !> for case of geographical mesh on the sphere with regular grid-spacing
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !> @param[in] td_nam
   !> @param[in] jpi
   !> @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
      INTEGER(i4), INTENT(IN) :: jpi
      INTEGER(i4), INTENT(IN) :: jpj

      ! local variable
      REAL(dp)   ::   zti, zui, zvi, zfi   ! local scalars
      REAL(dp)   ::   ztj, zuj, zvj, zfj   !

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      CALL logger_info('GRID HGR FILL : geographical mesh on the sphere with'//&
         &  ' regular grid-spacing given by ppe1_deg and ppe2_deg')

      DO jj = 1, jpj
         DO ji = 1, jpi
            zti = FLOAT( ji - 1 )         ;   ztj = FLOAT( jj - 1 )
            zui = FLOAT( ji - 1 ) + 0.5   ;   zuj = FLOAT( jj - 1 )
            zvi = FLOAT( ji - 1 )         ;   zvj = FLOAT( jj - 1 ) + 0.5
            zfi = FLOAT( ji - 1 ) + 0.5   ;   zfj = FLOAT( jj - 1 ) + 0.5
      ! Longitude
            tg_glamt%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zti
            tg_glamu%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zui
            tg_glamv%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zvi
            tg_glamf%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zfi
      ! Latitude
            tg_gphit%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * ztj
            tg_gphiu%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * zuj
            tg_gphiv%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * zvj
            tg_gphif%d_value(ji,jj,1,1) = td_nam%d_ppgphi0 + td_nam%d_ppe2_deg * zfj
      ! e1
            tg_e1t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphit%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e1u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiu%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e1v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiv%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e1f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphif%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
      ! e2
            tg_e2t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg
            tg_e2u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg
            tg_e2v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg
            tg_e2f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * td_nam%d_ppe2_deg
         END DO
      END DO

   END SUBROUTINE grid_hgr__fill_reg
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr__fill_plan(td_nam, jpi, jpj)
   !-------------------------------------------------------------------
   !> @brief This subroutine fill horizontal mesh (hgr structure)
   !> for case of f- or beta-plane with regular grid-spacing
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !> @param[in] td_nam
   !> @param[in] jpi
   !> @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
      INTEGER(i4), INTENT(IN) :: jpi
      INTEGER(i4), INTENT(IN) :: jpj

      ! local variable
      REAL(dp)    :: dl_glam0
      REAL(dp)    :: dl_gphi0

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      CALL logger_info('GRID HGR FILL : f- or beta-plane with regular'//&
         &  ' grid-spacing given by ppe1_deg and ppe2_deg')
!         &  ' grid-spacing given by ppe1_m and ppe2_m')

      ! Position coordinates (in kilometers)
      !                          ==========
      dl_glam0 = 0.e0
      dl_gphi0 = - td_nam%d_ppe2_deg * 1.e-3
!      dl_gphi0 = - td_nam%d_ppe2_m * 1.e-3

         !
      DO jj = 1, jpj
         DO ji = 1, jpi
!            tg_glamt%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_m * 1.e-3 * ( FLOAT( ji - 1 )       )
!            tg_glamu%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_m * 1.e-3 * ( FLOAT( ji - 1 ) + 0.5 )
            tg_glamt%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_deg * 1.e-3 * ( FLOAT( ji - 1 )       )
            tg_glamu%d_value(ji,jj,1,1) = dl_glam0 + td_nam%d_ppe1_deg * 1.e-3 * ( FLOAT( ji - 1 ) + 0.5 )
            tg_glamv%d_value(ji,jj,1,1) = tg_glamt%d_value(ji,jj,1,1)
            tg_glamf%d_value(ji,jj,1,1) = tg_glamu%d_value(ji,jj,1,1)

            !tg_gphit%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_m * 1.e-3 * ( FLOAT( jj - 1 )       )
            tg_gphit%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_deg * 1.e-3 * ( FLOAT( jj - 1 )       )
            tg_gphiu%d_value(ji,jj,1,1) = tg_gphit%d_value(ji,jj,1,1)
            !tg_gphiv%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_m * 1.e-3 * ( FLOAT( jj - 1 ) + 0.5 )
            tg_gphiv%d_value(ji,jj,1,1) = dl_gphi0 + td_nam%d_ppe2_deg * 1.e-3 * ( FLOAT( jj - 1 ) + 0.5 )
            tg_gphif%d_value(ji,jj,1,1) = tg_gphiv%d_value(ji,jj,1,1)
         END DO
      END DO

      ! Horizontal scale factors (in meters)
      !                              ======
!      tg_e1t%d_value(:,:,1,1) = td_nam%d_ppe1_m
!      tg_e1u%d_value(:,:,1,1) = td_nam%d_ppe1_m
!      tg_e1v%d_value(:,:,1,1) = td_nam%d_ppe1_m
!      tg_e1f%d_value(:,:,1,1) = td_nam%d_ppe1_m
      tg_e1t%d_value(:,:,1,1) = td_nam%d_ppe1_deg
      tg_e1u%d_value(:,:,1,1) = td_nam%d_ppe1_deg
      tg_e1v%d_value(:,:,1,1) = td_nam%d_ppe1_deg
      tg_e1f%d_value(:,:,1,1) = td_nam%d_ppe1_deg

!      tg_e2t%d_value(:,:,1,1) = td_nam%d_ppe2_m
!      tg_e2u%d_value(:,:,1,1) = td_nam%d_ppe2_m
!      tg_e2v%d_value(:,:,1,1) = td_nam%d_ppe2_m
!      tg_e2f%d_value(:,:,1,1) = td_nam%d_ppe2_m
      tg_e2t%d_value(:,:,1,1) = td_nam%d_ppe2_deg
      tg_e2u%d_value(:,:,1,1) = td_nam%d_ppe2_deg
      tg_e2v%d_value(:,:,1,1) = td_nam%d_ppe2_deg
      tg_e2f%d_value(:,:,1,1) = td_nam%d_ppe2_deg

   END SUBROUTINE grid_hgr__fill_plan
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr__fill_merc(td_nam, jpi, jpj)
   !-------------------------------------------------------------------
   !> @brief This subroutine fill horizontal mesh (hgr structure)
   !> for case of geographical mesh on the sphere, isotropic MERCATOR type
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !> @param[in] td_nam
   !> @param[in] jpi
   !> @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
      INTEGER(i4), INTENT(IN) :: jpi
      INTEGER(i4), INTENT(IN) :: jpj

      ! local variable
      INTEGER  ::   ijeq                 ! index of equator T point (used in case 4)

      REAL(dp) ::   zti, zui, zvi, zfi   ! local scalars
      REAL(dp) ::   ztj, zuj, zvj, zfj   !
      REAL(dp) ::   zarg

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      CALL logger_info('GRID HGR FILL : geographical mesh on the sphere, '//&
        &  'MERCATOR type longitudinal/latitudinal spacing given by ppe1_deg')

      IF( td_nam%d_ppgphi0 == -90 )THEN
         CALL logger_fatal(' Mercator grid cannot start at south pole !!!! ' )
      ENDIF

      !  Find index corresponding to the equator, given the grid spacing e1_deg
      !  and the (approximate) southern latitude ppgphi0.
      !  This way we ensure that the equator is at a "T / U" point, when in the domain.
      !  The formula should work even if the equator is outside the domain.
      zarg = dp_pi / 4. - dp_pi / 180. * td_nam%d_ppgphi0 / 2.
      ijeq = ABS( 180./dp_pi * LOG( COS( zarg ) / SIN( zarg ) ) / td_nam%d_ppe1_deg )
      IF( td_nam%d_ppgphi0 > 0 )  ijeq = -ijeq

      CALL logger_info('Index of the equator on the MERCATOR grid: '//TRIM(fct_str(ijeq)))

      DO jj = 1, jpj
         DO ji = 1, jpi
            zti = FLOAT( ji - 1 )         ;   ztj = FLOAT( jj - ijeq )
            zui = FLOAT( ji - 1 ) + 0.5   ;   zuj = FLOAT( jj - ijeq )
            zvi = FLOAT( ji - 1 )         ;   zvj = FLOAT( jj - ijeq ) + 0.5
            zfi = FLOAT( ji - 1 ) + 0.5   ;   zfj = FLOAT( jj - ijeq ) + 0.5
         ! Longitude
            tg_glamt%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zti
            tg_glamu%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zui
            tg_glamv%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zvi
            tg_glamf%d_value(ji,jj,1,1) = td_nam%d_ppglam0 + td_nam%d_ppe1_deg * zfi
         ! Latitude
            tg_gphit%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* ztj ) )
            tg_gphiu%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* zuj ) )
            tg_gphiv%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* zvj ) )
            tg_gphif%d_value(ji,jj,1,1) = 1./dp_deg2rad * ASIN ( TANH( td_nam%d_ppe1_deg *dp_deg2rad* zfj ) )
         ! e1
            tg_e1t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphit%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e1u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiu%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e1v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiv%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e1f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphif%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
         ! e2
            tg_e2t%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphit%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e2u%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiu%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e2v%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphiv%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
            tg_e2f%d_value(ji,jj,1,1) = dp_rearth * dp_deg2rad * COS( dp_deg2rad * tg_gphif%d_value(ji,jj,1,1) ) * td_nam%d_ppe1_deg
         END DO
      END DO

   END SUBROUTINE grid_hgr__fill_merc
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr__fill_gyre(td_nam, jpi, jpj)
   !-------------------------------------------------------------------
   !> @brief This subroutine fill horizontal mesh (hgr structure)
   !> for case of beta-plane with regular grid-spacing and rotated domain (GYRE configuration)
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !>
   !> @param[in] td_nam
   !> @param[in] jpi
   !> @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
      INTEGER(i4), INTENT(IN) :: jpi
      INTEGER(i4), INTENT(IN) :: jpj

      ! local variable
      REAL(dp) ::   zlam1, zcos_alpha, zim1 , zjm1 , ze1, ze1deg
      REAL(dp) ::   zphi1, zsin_alpha, zim05, zjm05

      REAL(dp) ::   dl_glam0
      REAL(dp) ::   dl_gphi0

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      CALL logger_info('GRID HGR FILL : beta-plane with regular grid-spacing '//&
         &  'and rotated domain (GYRE configuration)')

      ! Position coordinates (in kilometers)
      !
      ! angle 45deg and ze1=106.e+3 / jp_cfg forced -> zlam1 = -85deg, zphi1 = 29degN
      zlam1 = -85
      zphi1 = 29
      ! resolution in meters
      ze1 = 106000. / FLOAT(td_nam%i_cfg)
      ! benchmark: forced the resolution to be about 100 km
      IF( td_nam%l_bench )   ze1 = 106000.e0
      zsin_alpha = - SQRT( 2. ) / 2.
      zcos_alpha =   SQRT( 2. ) / 2.
      ze1deg = ze1 / (dp_rearth * dp_deg2rad)
      dl_glam0 = zlam1 + zcos_alpha * ze1deg * FLOAT( jpj-2 )
      dl_gphi0 = zphi1 + zsin_alpha * ze1deg * FLOAT( jpj-2 )

      DO jj = 1, jpj
         DO ji = 1, jpi
            zim1 = FLOAT( ji - 1 )   ;   zim05 = FLOAT( ji ) - 1.5
            zjm1 = FLOAT( jj - 1 )   ;   zjm05 = FLOAT( jj ) - 1.5

            tg_glamf%d_value(ji,jj,1,1) = dl_glam0 &
                                        &  + zim1  * ze1deg * zcos_alpha &
                                        &  + zjm1  * ze1deg * zsin_alpha
            tg_gphif%d_value(ji,jj,1,1) = dl_gphi0 &
                                        & - zim1  * ze1deg * zsin_alpha &
                                        & + zjm1  * ze1deg * zcos_alpha

            tg_glamt%d_value(ji,jj,1,1) = dl_glam0 &
                                        & + zim05 * ze1deg * zcos_alpha &
                                        & + zjm05 * ze1deg * zsin_alpha
            tg_gphit%d_value(ji,jj,1,1) = dl_gphi0 &
                                        & - zim05 * ze1deg * zsin_alpha &
                                        & + zjm05 * ze1deg * zcos_alpha

            tg_glamu%d_value(ji,jj,1,1) = dl_glam0 &
                                        & + zim1  * ze1deg * zcos_alpha &
                                        & + zjm05 * ze1deg * zsin_alpha
            tg_gphiu%d_value(ji,jj,1,1) = dl_gphi0 &
                                        & - zim1  * ze1deg * zsin_alpha &
                                        & + zjm05 * ze1deg * zcos_alpha

            tg_glamv%d_value(ji,jj,1,1) = dl_glam0 &
                                        & + zim05 * ze1deg * zcos_alpha &
                                        & + zjm1  * ze1deg * zsin_alpha
            tg_gphiv%d_value(ji,jj,1,1) = dl_gphi0 &
                                        & - zim05 * ze1deg * zsin_alpha &
                                        & + zjm1  * ze1deg * zcos_alpha

         END DO
      END DO

      ! Horizontal scale factors (in meters)
      !                              ======
      tg_e1t%d_value(:,:,1,1) = ze1
      tg_e1u%d_value(:,:,1,1) = ze1
      tg_e1v%d_value(:,:,1,1) = ze1
      tg_e1f%d_value(:,:,1,1) = ze1

      tg_e2t%d_value(:,:,1,1) = ze1
      tg_e2u%d_value(:,:,1,1) = ze1
      tg_e2v%d_value(:,:,1,1) = ze1
      tg_e2f%d_value(:,:,1,1) = ze1

   END SUBROUTINE grid_hgr__fill_gyre
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr__fill_coriolis(td_nam, jpi)!,jpj)
   !-------------------------------------------------------------------
   !> @brief This subroutine fill coriolis factor
   !>
   !> @author J.Paul
   !> @date September, 2015 - Initial version
   !> @date October, 2016
   !> - compute coriolis factor at f-point and at t-point
   !>
   !> @param[in] td_nam
   !> @param[in] jpi
   ! @param[in] jpj
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
      INTEGER(i4), INTENT(IN) :: jpi
!      INTEGER(i4), INTENT(IN) :: jpj

      ! local variable
      REAL(dp) :: zbeta
      REAL(dp) :: zphi0
      REAL(dp) :: zf0

      ! loop indices
      !----------------------------------------------------------------

      !  Coriolis factor
      SELECT CASE( td_nam%i_mshhgr )   ! type of horizontal mesh

         CASE ( 0, 1, 4 ) ! mesh on the sphere

            tg_ff_f%d_value(:,:,1,1) = 2. * dp_omega * SIN(dp_deg2rad * tg_gphif%d_value(:,:,1,1))
            tg_ff_t%d_value(:,:,1,1) = 2. * dp_omega * SIN(dp_deg2rad * tg_gphit%d_value(:,:,1,1)) ! at t-point

         CASE ( 2 )  ! f-plane at ppgphi0

            tg_ff_f%d_value(:,:,1,1) = 2. * dp_omega * SIN( dp_deg2rad * td_nam%d_ppgphi0 )
            tg_ff_t%d_value(:,:,1,1) = 2. * dp_omega * SIN( dp_deg2rad * td_nam%d_ppgphi0 )
            CALL logger_info('f-plane: Coriolis parameter = constant = '//&
               &  TRIM(fct_str(tg_ff_f%d_value(1,1,1,1))) )

         CASE ( 3 )  ! beta-plane

            ! beta at latitude ppgphi0
            zbeta = 2. * dp_omega * COS( dp_deg2rad * td_nam%d_ppgphi0 ) / dp_rearth
            ! latitude of the first row F-points
!            zphi0 = td_nam%d_ppgphi0 - FLOAT( jpi/2 ) * td_nam%d_ppe2_m / ( dp_rearth * dp_deg2rad )
            zphi0 = td_nam%d_ppgphi0 - FLOAT( jpi/2 ) * td_nam%d_ppe2_deg / ( dp_rearth * dp_deg2rad )

            ! compute f0 1st point south
            zf0 = 2. * dp_omega * SIN( dp_deg2rad * zphi0 )
            ! f = f0 +beta* y ( y=0 at south)
            tg_ff_f%d_value(:,:,1,1) = zf0 + zbeta * tg_gphif%d_value(:,:,1,1) * 1.e3
            tg_ff_t%d_value(:,:,1,1) = zf0 + zbeta * tg_gphit%d_value(:,:,1,1) * 1.e3

         CASE ( 5 )  ! beta-plane and rotated domain (gyre configuration)

            ! beta at latitude ppgphi0
            zbeta = 2. * dp_omega * COS( dp_deg2rad * td_nam%d_ppgphi0 ) / dp_rearth
            ! latitude of the first row F-points
            zphi0 = 15.e0
            ! compute f0 1st point south
            zf0   = 2. * dp_omega * SIN( dp_deg2rad * zphi0 )

            ! f = f0 +beta* y ( y=0 at south)
            tg_ff_f%d_value(:,:,1,1) = ( zf0 + zbeta * ABS( tg_gphif%d_value(:,:,1,1) - zphi0 ) &
                                     & * dp_deg2rad * dp_rearth )
            tg_ff_t%d_value(:,:,1,1) = ( zf0 + zbeta * ABS( tg_gphit%d_value(:,:,1,1) - zphi0 ) &
                                     & * dp_deg2rad * dp_rearth )

      END SELECT

   END SUBROUTINE grid_hgr__fill_coriolis
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE grid_hgr__angle(td_nam, jpi, jpj)
   !!----------------------------------------------------------------------
   !> @brief This subroutine compute angles between model grid lines and the North direction
   !>
   !> @details
   !> ** Method  :
   !>
   !> ** Action  :   Compute (gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf) arrays:
   !>      sinus and cosinus of the angle between the north-south axe and the
   !>      j-direction at t, u, v and f-points
   !>
   !> History :
   !>   7.0  !  96-07  (O. Marti )  Original code
   !>   8.0  !  98-06  (G. Madec )
   !>   8.5  !  98-06  (G. Madec )  Free form, F90 + opt.
   !>   9.2  !  07-04  (S. Masson)  Add T, F points and bugfix in cos lateral boundary
   !>
   !> @author J.Paul
   !> @date September, 2015 - rewrite from geo2ocean
   !>
   !> @param[in] td_nam
   !> @param[in] jpi
   !> @param[in] jpj
   !!----------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TNAMH), INTENT(IN) :: td_nam
      INTEGER(i4), INTENT(IN) :: jpi
      INTEGER(i4), INTENT(IN) :: jpj

      ! local variable
      REAL(dp) :: zlam, zphi
      REAL(dp) :: zlan, zphh
      REAL(dp) :: zxnpt, zynpt, znnpt ! x,y components and norm of the vector: T point to North Pole
      REAL(dp) :: zxnpu, zynpu, znnpu ! x,y components and norm of the vector: U point to North Pole
      REAL(dp) :: zxnpv, zynpv, znnpv ! x,y components and norm of the vector: V point to North Pole
      REAL(dp) :: zxnpf, zynpf, znnpf ! x,y components and norm of the vector: F point to North Pole
      REAL(dp) :: zxvvt, zyvvt, znvvt ! x,y components and norm of the vector: between V points below and above a T point
      REAL(dp) :: zxffu, zyffu, znffu ! x,y components and norm of the vector: between F points below and above a U point
      REAL(dp) :: zxffv, zyffv, znffv ! x,y components and norm of the vector: between F points left  and right a V point
      REAL(dp) :: zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !!----------------------------------------------------------------------

      ! ============================= !
      ! Compute the cosinus and sinus !
      ! ============================= !
      ! (computation done on the north stereographic polar plane)

      DO jj = 2, jpj-1
!CDIR NOVERRCHK
         DO ji = 2, jpi   ! vector opt.

            ! north pole direction & modulous (at t-point)
            zlam = tg_glamt%d_value(ji,jj,1,1)
            zphi = tg_gphit%d_value(ji,jj,1,1)
            zxnpt = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            zynpt = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            znnpt = zxnpt*zxnpt + zynpt*zynpt

            ! north pole direction & modulous (at u-point)
            zlam = tg_glamu%d_value(ji,jj,1,1)
            zphi = tg_gphiu%d_value(ji,jj,1,1)
            zxnpu = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            zynpu = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            znnpu = zxnpu*zxnpu + zynpu*zynpu

            ! north pole direction & modulous (at v-point)
            zlam = tg_glamv%d_value(ji,jj,1,1)
            zphi = tg_gphiv%d_value(ji,jj,1,1)
            zxnpv = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            zynpv = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            znnpv = zxnpv*zxnpv + zynpv*zynpv

            ! north pole direction & modulous (at f-point)
            zlam = tg_glamf%d_value(ji,jj,1,1)
            zphi = tg_gphif%d_value(ji,jj,1,1)
            zxnpf = 0._dp - 2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            zynpf = 0._dp - 2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )
            znnpf = zxnpf*zxnpf + zynpf*zynpf

            ! j-direction: v-point segment direction (around t-point)
            zlam = tg_glamv%d_value(ji,jj  ,1,1)
            zphi = tg_gphiv%d_value(ji,jj  ,1,1)
            zlan = tg_glamv%d_value(ji,jj-1,1,1)
            zphh = tg_gphiv%d_value(ji,jj-1,1,1)
            zxvvt =  2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            zyvvt =  2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt )  )
            znvvt = MAX( znvvt, dp_eps )

            ! j-direction: f-point segment direction (around u-point)
            zlam = tg_glamf%d_value(ji,jj  ,1,1)
            zphi = tg_gphif%d_value(ji,jj  ,1,1)
            zlan = tg_glamf%d_value(ji,jj-1,1,1)
            zphh = tg_gphif%d_value(ji,jj-1,1,1)
            zxffu =  2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            zyffu =  2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu )  )
            znffu = MAX( znffu, dp_eps )

            ! i-direction: f-point segment direction (around v-point)
            zlam = tg_glamf%d_value(ji  ,jj,1,1)
            zphi = tg_gphif%d_value(ji  ,jj,1,1)
            zlan = tg_glamf%d_value(ji-1,jj,1,1)
            zphh = tg_gphif%d_value(ji-1,jj,1,1)
            zxffv =  2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            zyffv =  2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv )  )
            znffv = MAX( znffv, dp_eps )

            ! j-direction: u-point segment direction (around f-point)
            zlam = tg_glamu%d_value(ji,jj+1,1,1)
            zphi = tg_gphiu%d_value(ji,jj+1,1,1)
            zlan = tg_glamu%d_value(ji,jj  ,1,1)
            zphh = tg_gphiu%d_value(ji,jj  ,1,1)
            zxuuf =  2._dp * COS( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * COS( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            zyuuf =  2._dp * SIN( dp_deg2rad*zlam ) * TAN( dp_pi/4._dp - dp_deg2rad*zphi/2._dp )   &
               &  -  2._dp * SIN( dp_deg2rad*zlan ) * TAN( dp_pi/4._dp - dp_deg2rad*zphh/2._dp )
            znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf )  )
            znuuf = MAX( znuuf, dp_eps )

            ! cosinus and sinus using scalar and vectorial products
            tg_gsint%d_value(ji,jj,1,1) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt
            tg_gcost%d_value(ji,jj,1,1) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt

            tg_gsinu%d_value(ji,jj,1,1) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu
            tg_gcosu%d_value(ji,jj,1,1) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu

            tg_gsinf%d_value(ji,jj,1,1) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf
            tg_gcosf%d_value(ji,jj,1,1) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf

            ! (caution, rotation of 90 degres)
            tg_gsinv%d_value(ji,jj,1,1) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv
            tg_gcosv%d_value(ji,jj,1,1) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv

         END DO
      END DO

      ! =============== !
      ! Geographic mesh !
      ! =============== !

      DO jj = 2, jpj-1
         DO ji = 2, jpi   ! vector opt.
            IF( MOD( ABS( tg_glamv%d_value(ji,jj,1,1) - tg_glamv%d_value(ji,jj-1,1,1) ), 360._dp ) < 1.e-8 ) THEN
               tg_gsint%d_value(ji,jj,1,1) = 0._dp
               tg_gcost%d_value(ji,jj,1,1) = 1._dp
            ENDIF
            IF( MOD( ABS( tg_glamf%d_value(ji,jj,1,1) - tg_glamf%d_value(ji,jj-1,1,1) ), 360._dp ) < 1.e-8 ) THEN
               tg_gsinu%d_value(ji,jj,1,1) = 0._dp
               tg_gcosu%d_value(ji,jj,1,1) = 1._dp
            ENDIF
            IF(      ABS( tg_gphif%d_value(ji,jj,1,1) - tg_gphif%d_value(ji-1,jj,1,1) )            < 1.e-8 ) THEN
               tg_gsinv%d_value(ji,jj,1,1) = 0._dp
               tg_gcosv%d_value(ji,jj,1,1) = 1._dp
            ENDIF
            IF( MOD( ABS( tg_glamu%d_value(ji,jj,1,1) - tg_glamu%d_value(ji,jj+1,1,1) ), 360._dp ) < 1.e-8 ) THEN
               tg_gsinf%d_value(ji,jj,1,1) = 0._dp
               tg_gcosf%d_value(ji,jj,1,1) = 1._dp
            ENDIF
         END DO
      END DO

      ! =========================== !
      ! Lateral boundary conditions !
      ! =========================== !

      ! lateral boundary cond.: T-, U-, V-, F-pts, sgn
      CALL lbc_lnk( tg_gcost%d_value(:,:,1,1), 'T', td_nam%i_perio, -1._dp )
      CALL lbc_lnk( tg_gcosu%d_value(:,:,1,1), 'U', td_nam%i_perio, -1._dp )
      CALL lbc_lnk( tg_gcosv%d_value(:,:,1,1), 'V', td_nam%i_perio, -1._dp )
      CALL lbc_lnk( tg_gcosf%d_value(:,:,1,1), 'F', td_nam%i_perio, -1._dp )

      CALL lbc_lnk( tg_gsint%d_value(:,:,1,1), 'T', td_nam%i_perio, -1._dp )
      CALL lbc_lnk( tg_gsinu%d_value(:,:,1,1), 'U', td_nam%i_perio, -1._dp )
      CALL lbc_lnk( tg_gsinv%d_value(:,:,1,1), 'V', td_nam%i_perio, -1._dp )
      CALL lbc_lnk( tg_gsinf%d_value(:,:,1,1), 'F', td_nam%i_perio, -1._dp )

   END SUBROUTINE grid_hgr__angle
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
END MODULE grid_hgr


  subroutine clearsky_optical_properties( &
       wavelength_ns, nsmax,      ns_elas,    &
       maxlay,        nstokes,    maxleg,     &
       relN2,         relO2,      relAr,      &
       csabs_O3,      csabs_O4,   csabs_NO2,  &
       csRay_N2,      csRay_O2,   csRay_Ar,   &
       csram_N2,      csram_O2,   csram_air,  &
       eps_N2,        eps_O2,     eps_Ar,     &
       dvO4,          dvO3,       dvNO2,      &
       dvair,         dz,         tautot,     &
       omega_Ray,     omega_Cab,  om_air,     &
       pRay_N2,       pCab_N2,    pRay_O2,    &
       pCab_O2,       pRay_Ar,    pCab_Ar,    &
       pRay_air,      pCab_air,   pRam_air,   &
       maxcoeffs)

!-------------------------------------------------------------------
!
! Subroutine:
!   clearsky_optical_properties
!
! Purpose:
!   Return optical properties of clear sky atmosphere
!   (optical thickness; single scattering albedo; phase functions;
!    expansion coefficient matrices)
!!
! Assumption: phase matrix does not change over wavelength range
! wavelength_ns(0 ... nsmax)
!
! omega = (csram+cscab) / csray
!
! For phase matrix and phase function see Table A.1 in
! appendix A of "Rotational Raman scattering  of polarized light in
! the Earth's atmosphere..." - Landgraf et al., jqsrt 2004
!-------------------------------------------------------------------
!
! The Rayleigh, Cabannes and Raman phase matrix P has the shape:
!
!        ( P11  P12   0    0  )
!   P =  ( P21  P22   0    0  )   where P11 = phase function
!        (  0    0   P33  P34 )
!        (  0    0   P43  P44 )
!
!        P11 = [ A [1 + (costheta)**2] + C] / N
!        P12 =  -A [1 - (costheta)**2] + C] / N
!        P22 =   A [1 + (costheta)**2] / N
!        P33 =  2A [costheta] / N
!        P44 =   B [costheta] / N
!        P21 =  P12
!        P43 =  -P34 = 0
!
!  Rayleigh:
!
!    A = 3(45 + eps)
!    B = 30(9 - eps)
!    C = 36 eps
!    N = 180 + 40 eps
!
!  Cabannes:
!
!    A = 3(180 + eps)
!    B = 30(36 - eps)
!    C = 36 eps
!    N = 40(18 + eps)
!
!  Raman:
!    A =   3
!    B =  -30 (erratum Landgraf et al. -10 -> -30)
!    C =  36
!    N =  40
!
!  where eps is the molecular anistropy,
!  related to the king factor (Bates 1984) as Fking = 1 + (2/9)eps
!
!  The phase matrix is expanded in generalized spherical function as
!  follows:
!                 2
!    P11       = sum [alpha1(ns)] * p(l,0,0)
!                l=0
!
!                 2
!    P22 + P33 = sum [alpha2(ns) + alpha3(ns)] * p(l,2,+2)
!                l=2
!
!                 2
!    P22 - P33 = sum [alpha2(ns) - alpha3(ns)] * p(l,2,-2)
!                l=2
!
!                 2
!    P44       = sum [alpha4(ns)] * p(l,0,0)
!                l=0
!
!                 2
!    P12 = P21 = sum [beta1(ns)] * p(l,0,+2)
!                l=2
!
!                 2
!    P34       = sum [beta2(ns)] * p(l,0,+2)
!                l=2
!
!    P43       = -P34
!
!  where generalized spherical functions p(l,m,n) are given by
!  [de Haan et al 1987, A&A 183, 371-391]:
!
!    l    p(l,m,n)
!   ---------------------------------------------------------
!    0    p(0,0,0)  = 1
!    1    p(1,0,0)  = costheta
!    2    p(2,0,0)  = 0.50*[3(costheta)**2 - 1]
!    0    p(0,0,+2) = p(0,0,-2) =  0
!    1    p(1,0,+2) = p(1,0,-2) =  0
!    2    p(2,0,+2) = p(2,0,-2) = -0.25*sqrt(6)*[1 - (costheta)**2]
!    0    p(0,2,+2) = p(0,2,-2) = 0
!    1    p(1,2,+2) = p(0,2,-2) = 0
!    2    p(2,2,+2) = 0.25*[1 + 2costheta + costheta**2]
!    2    p(2,2,-2) = 0.25*[1 - 2costheta + costheta**2]
!
!  see also subroutine "gsf.f90"
!
!  Expansion coefficient matrix for Rayleigh, Cabannes and Raman
!  scattering is returned as phaseRay, phaseCab and phaseRam :
!
!    ( alpha1  beta1     0       0     )
!    ( beta1   alpha2    0       0     )
!    (   0       0     alpha3   beta2  )
!    (   0       0     -beta2   alpha4 )
!
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

  integer,intent(in):: &
    nsmax,    & !nr of wavenumbers (incident light)
    ns_elas,  & !wavelength_ns elastic scattering
    maxlay,   &
    nstokes,  &
    maxleg

  real(kind=dp),intent(in):: &
    wavelength_ns(0:nsmax)

  real(kind=dp),intent(in):: &
     relN2, & !N2 volume mixing ratio
     relO2, & !O2 volume mixing ratio
     relAr    !Ar volume mixing ratio

  real(kind=dp),intent(in):: &
    dz(maxlay),              & !layer tickness [m]
    csabs_O3(maxlay,0:nsmax),  & !O3 csabs section [cm^2]
    csabs_O4(maxlay,0:nsmax),  & !O4 csabs section [cm^5 molec-2]
    csabs_NO2(maxlay,0:nsmax), & !NO2 csabs section [cm^2]
    csRay_N2(0:nsmax),         & !Rayleigh csabs section [cm2] for N2
    csRay_O2(0:nsmax),         & !Rayleigh csabs section [cm2] for O2
    csRay_Ar(0:nsmax),         & !Rayleigh csabs section [cm2] for Ar
    eps_N2(0:nsmax),           & !epsilon for N2
    eps_O2(0:nsmax),           & !epsilon for O2
    eps_Ar(0:nsmax),           & !epsilon for Ar = 0
    dvO4(maxlay),            & !diff. O4 column density [part^2./cm^5]
    dvO3(maxlay),            & !diff. O3 column density [part./cm^2]
    dvNO2(maxlay),           & !diff. NO2 column density [part./cm^2]
    dvair(maxlay)              !diff. O2 column density [part./cm^2]

  real(kind=dp),intent(in):: &
    csram_N2(maxlay,0:nsmax,0:nsmax), &
    csram_O2(maxlay,0:nsmax,0:nsmax), &
    csram_air(maxlay,0:nsmax,0:nsmax) !Cab+Ram

  real(kind=dp)::  &
    elasfac_N2,       & !elastic fraction
    elasfac_O2,       &
    elasfac_Ar,       &
    weight_N2,     &
    weight_O2,     &
    weight_Ar,     &
    tausca_Ray_N2, &
    tausca_Ray_O2, &
    tausca_Ray_Ar

! phase matrix for vector radiative transfer,
! elements are divided by 2m+1
  real(kind=dp):: &
    A_Ray_N2, & !Rayleigh
    A_Ray_O2, &
    A_Ray_Ar, &
    B_Ray_N2, &
    B_Ray_O2, &
    B_Ray_Ar, &
    C_Ray_N2, &
    C_Ray_O2, &
    C_Ray_Ar, &
    N_Ray_N2, &
    N_Ray_O2, &
    N_Ray_Ar, &
    A_Cab_N2, & !Cabannes
    A_Cab_O2, &
    A_Cab_Ar, &
    B_Cab_N2, &
    B_Cab_O2, &
    B_Cab_Ar, &
    C_Cab_N2, &
    C_Cab_O2, &
    C_Cab_Ar, &
    N_Cab_N2, &
    N_Cab_O2, &
    N_Cab_Ar, &
    A_Ram,    & !Raman
    B_Ram,    &
    C_Ram,    &
    N_Ram

  real(kind=dp):: &
    phaseRay_air(4,4,0:2), & !Rayleigh phase fct. moments
    phaseRay_N2(4,4,0:2),  & !Rayleigh phase fct. moments
    phaseRay_O2(4,4,0:2),  & !Rayleigh phase fct. moments
    phaseRay_Ar(4,4,0:2),  & !Rayleigh phase fct. moments
    phaseCab_air(4,4,0:2), & !Cabannes phase fct. moments
    phaseCab_N2(4,4,0:2),  & !Cabannes phase fct. moments
    phaseCab_O2(4,4,0:2),  & !Cabannes phase fct. moments
    phaseCab_Ar(4,4,0:2),  & !Cabannes phase fct. moments
    phaseRam(4,4,0:2)        !Raman phase fct. moments

  integer::ns,k,m,lg,i1,i2,i_st,j_st

  real(kind=dp),dimension(maxlay,0:nsmax):: &
    tauabs, & !total abs. optical depth
    tausca,&    !total scat. optical depth
    bscat_Ray, & !beta_scat [m-1]
    bscat_Cab  !beta_scat [m-1]

  real(kind=dp),dimension(maxlay,0:nsmax),intent(out):: &
    tautot,    & !total optical depth
    omega_Ray, & !Rayleigh single scattering albedo
    omega_Cab    !Cabannes single scattering albedo

  real(kind=dp),intent(out):: &
    om_air(maxlay,0:nsmax,0:nsmax) !watch out, different for each layer k

 real(kind=dp), &
  dimension(nstokes,nstokes,0:maxleg,maxlay),intent(out):: &
    pCab_N2,  & !Cabannes phase fct. moments
    pRay_N2,  & !Rayleigh phase fct. moments
    pCab_O2,  & !Cabannes phase fct. moments
    pRay_O2,  & !Rayleigh phase fct. moments
    pCab_Ar,  & !Cabannes phase fct. moments
    pRay_Ar,  & !Rayleigh phase fct. moments
    pCab_air, & !Cabannes phase fct. moments
    pRay_air, & !Rayleigh phase fct. moments
    pRam_air    !Raman    phase fct. moments

 integer::maxcoeffs(maxlay) !number of phase fct. coeff.

 logical,parameter::scalar =.true.

 logical,parameter:: &
   verbose_input  = .false., & !show setup expansion coefficients
   verbose_output = .false.    !show selected expans.coefficients

 do ns=0,nsmax

!-------------------------------------------------------------------
!    Optical depths and single scattering albedos
!-------------------------------------------------------------------

     elasfac_N2 = (18.d0+eps_N2(ns))/(18.d0+4.d0*eps_N2(ns))
     elasfac_O2 = (18.d0+eps_O2(ns))/(18.d0+4.d0*eps_O2(ns))
     elasfac_Ar =  1.d0

!    Total optical depth (Rayleigh + absorption) and
!    single scattering albedo for Cabannes and Rayleigh scattering

     do k = 1,maxlay

        tausca_Ray_N2 = csRay_N2(ns) * relN2 * dvair(k)
        tausca_Ray_O2 = csRay_O2(ns) * relO2 * dvair(k)
        tausca_Ray_Ar = csRay_Ar(ns) * relAr * dvair(k)

        tausca(k,ns) = tausca_Ray_N2 + &
                       tausca_Ray_O2 + &
                       tausca_Ray_Ar

        tauabs(k,ns) = csabs_O3(k,ns)  * dvO3(k)  + &
                       csabs_O4(k,ns)  * dvO4(k)  + &
                       csabs_NO2(k,ns) * dvNO2(k)

        tautot(k,ns) = tauabs(k,ns) + tausca(k,ns)

!        if(ns.eq.ns_elas) &
!           write(*,'(i4,f10.4,4d12.4)') &
!             k,wavelength_ns(ns),tausca(k,ns_elas),tauabs(k,ns_elas),tautot(k,ns_elas)

        omega_Ray(k,ns)    = 0.d0
        omega_Cab(k,ns)    = 0.d0
        om_air(k,0:nsmax,ns) = 0.d0

        if(tautot(k,ns).ne.0.d0)then

           omega_Ray(k,ns) = tausca(k,ns)/tautot(k,ns)
           omega_Cab(k,ns) =(elasfac_N2*tausca_Ray_N2 + &
                             elasfac_O2*tausca_Ray_O2 + &
                             elasfac_Ar*tausca_Ray_Ar)/tautot(k,ns)

           om_air(k,0:nsmax,ns) = &
             csram_air(k,0:nsmax,ns)*dvair(k)/tautot(k,ns)
        endif

        bscat_Ray(k,ns) = omega_Ray(k,ns)*tautot(k,ns)/dz(k) ![m-1]
        bscat_Cab(k,ns) = omega_Cab(k,ns)*tautot(k,ns)/dz(k) ![m-1]

     enddo

!--------------------------------------------------------------------
!    Setup Rayleigh phase matrix,
!    assume independent of ns (calculate for ns_elas)
!-------------------------------------------------------------------

     if(ns.eq.ns_elas)then

!       Save omega, tautot and pRay for selected wavelength
!       weight = omega_Ray_species(k)/omega_Ray_air(k,ns),
!       which does not depend on altitude

        weight_N2 = csRay_N2(ns)*relN2/(csRay_N2(ns)*relN2 + &
                                        csRay_O2(ns)*relO2 + &
                                        csRay_Ar(ns)*relAr)
        weight_O2 = csRay_O2(ns)*relO2/(csRay_N2(ns)*relN2 + &
                                        csRay_O2(ns)*relO2 + &
                                        csRay_Ar(ns)*relAr)
        weight_Ar = csRay_Ar(ns)*relAr/(csRay_N2(ns)*relN2 + &
                                        csRay_O2(ns)*relO2 + &
                                        csRay_Ar(ns)*relAr)

!       parameters A,B,C and normalization constant N in
!       Table A.1 landgraf et al.

        A_Ray_N2 = 3.d0 * (45.d0 + eps_N2(ns))
        A_Ray_O2 = 3.d0 * (45.d0 + eps_O2(ns))
        A_Ray_Ar = 3.d0 *  45.d0

        B_Ray_N2 = 30.d0 * (9.d0 - eps_N2(ns))
        B_Ray_O2 = 30.d0 * (9.d0 - eps_O2(ns))
        B_Ray_Ar = 30.d0 *  9.d0

        C_Ray_N2 = 36.d0 * eps_N2(ns)
        C_Ray_O2 = 36.d0 * eps_O2(ns)
        C_Ray_Ar =  0.d0

        N_Ray_N2 = 180.d0 + 40.d0 * eps_N2(ns)
        N_Ray_O2 = 180.d0 + 40.d0 * eps_O2(ns)
        N_Ray_Ar = 180.d0 + 40.d0 * eps_Ar(ns)

!       Rayleigh phase matrix elements
!       in generalized spherical function expansion

        call RayCaB_Ram_EXPANSION_coeff( &
             A_Ray_N2, B_Ray_N2, C_Ray_N2, N_Ray_N2, phaseRay_N2)

        call RayCaB_Ram_EXPANSION_coeff( &
             A_Ray_O2, B_Ray_O2, C_Ray_O2, N_Ray_O2, phaseRay_O2)

        call RayCaB_Ram_EXPANSION_coeff( &
             A_Ray_Ar, B_Ray_Ar, C_Ray_Ar, N_Ray_Ar, phaseRay_Ar)

        do m=0,2
           do i2=1,4
              do i1=1,4
                 phaseRay_air(i1,i2,m) = &
                      weight_N2 * phaseRay_N2(i1,i2,m) + &
                      weight_O2 * phaseRay_O2(i1,i2,m) + &
                      weight_Ar * phaseRay_Ar(i1,i2,m)
              enddo
           enddo
        enddo

     endif !ns_elas

!--------------------------------------------------------------------
!    Setup Cabannes phase matrix, assume independent of ns
!    (Calculate for ns_elas)
!--------------------------------------------------------------------

     if(ns.eq.ns_elas)then

!       weight = omega_Cab_species(k)/omega_Cab(k,ns)
!       which does not depend on altitude

        weight_N2 = elasfac_N2 * csRay_N2(ns) * relN2 / &
                   (elasfac_N2 * csRay_N2(ns) * relN2 + &
                    elasfac_O2 * csRay_O2(ns) * relO2 + &
                    elasfac_Ar * csRay_Ar(ns) * relAr)
        weight_O2 = elasfac_O2 * csRay_O2(ns) * relO2 / &
                   (elasfac_N2 * csRay_N2(ns) * relN2 + &
                    elasfac_O2 * csRay_O2(ns) * relO2 + &
                    elasfac_Ar * csRay_Ar(ns) * relAr)
        weight_Ar = elasfac_Ar * csRay_Ar(ns) * relAr / &
                   (elasfac_N2 * csRay_N2(ns) * relN2 + &
                    elasfac_O2 * csRay_O2(ns) * relO2 + &
                    elasfac_Ar * csRay_Ar(ns) * relAr)

!       parameters A,B,C and normalization constant N in
!       Table A.1 landgraf et al.

        A_Cab_N2 = 3.d0 * (180.d0 + eps_N2(ns))
        A_Cab_O2 = 3.d0 * (180.d0 + eps_O2(ns))
        A_Cab_Ar = 3.d0 *  180.d0

        B_Cab_N2 = 30.d0 * (36.d0 - eps_N2(ns))
        B_Cab_O2 = 30.d0 * (36.d0 - eps_O2(ns))
        B_Cab_Ar = 30.d0 *  36.d0

        C_Cab_N2 = 36.d0 * eps_N2(ns)
        C_Cab_O2 = 36.d0 * eps_O2(ns)
        C_Cab_Ar =  0.d0

        N_Cab_N2 = 40.d0 * (18.d0 + eps_N2(ns))
        N_Cab_O2 = 40.d0 * (18.d0 + eps_O2(ns))
        N_Cab_Ar = 40.d0 *  18.d0

!       Cabannes phase matrix elements
!       in generalized spherical function expansion

        call RayCaB_Ram_EXPANSION_coeff( &
             A_Cab_N2, B_Cab_N2, C_Cab_N2, N_Cab_N2, phaseCab_N2)

        call RayCaB_Ram_EXPANSION_coeff( &
             A_Cab_O2, B_Cab_O2, C_Cab_O2, N_Cab_O2, phaseCab_O2)

        call RayCaB_Ram_EXPANSION_coeff( &
             A_Cab_Ar, B_Cab_Ar, C_Cab_Ar, N_Cab_Ar, phaseCab_Ar)

        do m=0,2
           do i2=1,4
              do i1=1,4
                 phaseCab_air(i1,i2,m) = &
                      weight_N2 * phaseCab_N2(i1,i2,m) + &
                      weight_O2 * phaseCab_O2(i1,i2,m) + &
                      weight_Ar * phaseCab_Ar(i1,i2,m)
              enddo
           enddo
        enddo

     endif !ns_elas only

  enddo !ns

!--------------------------------------------------------------------
! Raman phase matrix, phase function
! independent of wavelength and species
!--------------------------------------------------------------------

! parameters A,B,C and normalization constant N in
! Table A.1 landgraf et al.

  A_Ram =   3.d0
  B_Ram = -30.d0 !correction, used to be -10.d0 in paper Landgraf 2004
  C_Ram =  36.d0
  N_Ram =  40.d0

  call RayCaB_Ram_EXPANSION_coeff( &
       A_Ram, B_Ram, C_Ram, N_Ram, phaseRam)

  if(verbose_input)then
     write(*,*) 'Setup Expansion coefficients for Rayleigh scattering'
     write(*,'(A4,6A9)') &
       'lg','alpha1','alpha2','alpha3','alpha4','beta1','beta2'
     do lg=0,2
        write(*,'(I4,6F9.5)')   &
          lg,                   &
          phaseRay_air(1,1,lg), &
          phaseRay_air(2,2,lg), &
          phaseRay_air(3,3,lg), &
          phaseRay_air(4,4,lg), &
          phaseRay_air(1,2,lg), &
          phaseRay_air(3,4,lg)
      enddo
      write(*,*) &
        'Setup Expansion coefficients for Cabannes scattering'
      write(*,'(A4,6A9)') &
        'lg','alpha1','alpha2','alpha3','alpha4','beta1','beta2'
      do lg=0,2
         write(*,'(I4,6F9.5)')   &
           lg,                   &
           phaseCab_air(1,1,lg), &
           phaseCab_air(2,2,lg), &
           phaseCab_air(3,3,lg), &
           phaseCab_air(4,4,lg), &
           phaseCab_air(1,2,lg), &
           phaseCab_air(3,4,lg)
       enddo
       write(*,*) &
         'Setup Expansion coefficients for Raman scattering'
       write(*,'(A4,6A9)') &
         'lg','alpha1','alpha2','alpha3','alpha4','beta1','beta2'
       do lg=0,2
          write(*,'(I4,6F9.5)')  &
            lg,                  &
            phaseRam(1,1,lg),    &
            phaseRam(2,2,lg),    &
            phaseRam(3,3,lg),    &
            phaseRam(4,4,lg),    &
            phaseRam(1,2,lg),    &
            phaseRam(3,4,lg)
       enddo
  endif

!--------------------------------------------------------------------
! Select phase matrix elements
! for (4,4,lgmax) -> (nstokes,nstokes,maxleg)
!--------------------------------------------------------------------

  do k = 1,maxlay
     maxcoeffs(k) = 2
  enddo

  do k=1,maxlay
   do lg = 0,maxleg
    do i_st = 1,nstokes
     do j_st = 1,nstokes
      if(lg.lE.2)then
         pRay_N2( j_st,i_st,lg,k) = phaseRay_N2( j_st,i_st,lg)
         pCab_N2( j_st,i_st,lg,k) = phaseCab_N2( j_st,i_st,lg)
         pRay_O2( j_st,i_st,lg,k) = phaseRay_O2( j_st,i_st,lg)
         pCab_O2( j_st,i_st,lg,k) = phaseCab_O2( j_st,i_st,lg)
         pRay_Ar( j_st,i_st,lg,k) = phaseRay_Ar( j_st,i_st,lg)
         pCab_Ar( j_st,i_st,lg,k) = phaseCab_Ar( j_st,i_st,lg)
         pRay_air(j_st,i_st,lg,k) = phaseRay_air(j_st,i_st,lg)
         pCab_air(j_st,i_st,lg,k) = phaseCab_air(j_st,i_st,lg)
         pRam_air(j_st,i_st,lg,k) = phaseRam(j_st,i_st,lg)
         if(scalar)then
            pRay_N2( j_st,i_st,lg,k) = 0.d0
            pCab_N2( j_st,i_st,lg,k) = 0.d0
            pRay_O2( j_st,i_st,lg,k) = 0.d0
            pCab_O2( j_st,i_st,lg,k) = 0.d0
            pRay_Ar( j_st,i_st,lg,k) = 0.d0
            pCab_Ar( j_st,i_st,lg,k) = 0.d0
            pRay_air(j_st,i_st,lg,k) = 0.d0
            pCab_air(j_st,i_st,lg,k) = 0.d0
            pRam_air(j_st,i_st,lg,k) = 0.d0
            if((j_st.eq.1).AND.(i_st.eq.1))then
               pRay_N2( j_st,i_st,lg,k) = phaseRay_N2( j_st,i_st,lg)
               pCab_N2( j_st,i_st,lg,k) = phaseCab_N2( j_st,i_st,lg)
               pRay_O2( j_st,i_st,lg,k) = phaseRay_O2( j_st,i_st,lg)
               pCab_O2( j_st,i_st,lg,k) = phaseCab_O2( j_st,i_st,lg)
               pRay_Ar( j_st,i_st,lg,k) = phaseRay_Ar( j_st,i_st,lg)
               pCab_Ar( j_st,i_st,lg,k) = phaseCab_Ar( j_st,i_st,lg)
               pRay_air(j_st,i_st,lg,k) = phaseRay_air(j_st,i_st,lg)
               pCab_air(j_st,i_st,lg,k) = phaseCab_air(j_st,i_st,lg)
               pRam_air(j_st,i_st,lg,k) = phaseRam(j_st,i_st,lg)
            endif
         endif
      else
          pRay_N2( j_st,i_st,lg,k) = 0.d0
          pCab_N2( j_st,i_st,lg,k) = 0.d0
          pRay_O2( j_st,i_st,lg,k) = 0.d0
          pCab_O2( j_st,i_st,lg,k) = 0.d0
          pRay_Ar( j_st,i_st,lg,k) = 0.d0
          pCab_Ar( j_st,i_st,lg,k) = 0.d0
          pRay_air(j_st,i_st,lg,k) = 0.d0
          pCab_air(j_st,i_st,lg,k) = 0.d0
          pRam_air(j_st,i_st,lg,k) = 0.d0
      endif
     enddo
    enddo
   enddo
  enddo

 goto 44
  write(*,*)'Isotropic phasefunctions'
  do lg = 0,maxleg
   do i_st = 1,nstokes
    do j_st = 1,nstokes
     do k = 1,maxlay
        if((i_st.eq.1).AND.(j_st.eq.1).AND.(lg.eq.0))then
           pRay_N2( j_st,i_st,lg,k) = 1.d0
           pCab_N2( j_st,i_st,lg,k) = 1.d0
           pRay_O2( j_st,i_st,lg,k) = 1.d0
           pCab_O2( j_st,i_st,lg,k) = 1.d0
           pRay_Ar( j_st,i_st,lg,k) = 1.d0
           pCab_Ar( j_st,i_st,lg,k) = 1.d0
           pRay_air(j_st,i_st,lg,k) = 1.d0
           pCab_air(j_st,i_st,lg,k) = 1.d0
        else
           pRay_N2( j_st,i_st,lg,k) = 0.d0
           pCab_N2( j_st,i_st,lg,k) = 0.d0
           pRay_O2( j_st,i_st,lg,k) = 0.d0
           pCab_O2( j_st,i_st,lg,k) = 0.d0
           pRay_Ar( j_st,i_st,lg,k) = 0.d0
           pCab_Ar( j_st,i_st,lg,k) = 0.d0
           pRay_air(j_st,i_st,lg,k) = 0.d0
           pCab_air(j_st,i_st,lg,k) = 0.d0
        endif
        if((i_st.eq.1).AND.(j_st.eq.1).AND.(lg.eq.0))then
           pRam_air(j_st,i_st,lg,k) = 1.d0
        else
          pRam_air(j_st,i_st,lg,k) = 0.d0
        endif
      enddo
     enddo
    enddo
   enddo
44 continue

  if(verbose_output)then
     write(*,*) &
       'Output Expansion coefficients for Rayleigh scattering'
     write(*,*) 'lambda [nm] = ',wavelength_ns(ns_elas)
     write(*,'(A4,6A9)') &
       'lg','alpha1','alpha2','alpha3','alpha4','beta1','beta2'
     k = maxlay
     do lg=0,maxleg
        if(nstokes.eq.1)then
           write(*,'(I4,6F9.5)')  &
             lg,                  &
             pRay_air(1,1,lg,k),  &
             0.d0,                &
             0.d0,                &
             0.d0,                &
             0.d0,                &
             0.d0
        endif
        if(nstokes.eq.3)then
           write(*,'(I4,6F9.5)')  &
             lg,                  &
             pRay_air(1,1,lg,k),  &
             pRay_air(2,2,lg,k),  &
             pRay_air(3,3,lg,k),  &
             0.d0,                &
             pRay_air(1,2,lg,k),  &
             0.d0
        endif
        if(nstokes.eq.4)then
           write(*,'(I4,6F9.5)')  &
             lg,                  &
             pRay_air(1,1,lg,k),  &
             pRay_air(2,2,lg,k),  &
             pRay_air(3,3,lg,k),  &
             pRay_air(4,4,lg,k),  &
             pRay_air(1,2,lg,k),  &
             pRay_air(3,4,lg,k)
        endif
     enddo
     write(*,*) &
       'Output Expansion coefficients for Cabannes scattering'
     write(*,'(A4,6A9)') &
       'lg','alpha1','alpha2','alpha3','alpha4','beta1','beta2'
     k = maxlay
     do lg=0,maxleg
        if(nstokes.eq.1)then
           write(*,'(I4,6F9.5)') &
             lg,                 &
             pCab_air(1,1,lg,k), &
             0.d0,               &
             0.d0,               &
             0.d0,               &
             0.d0,               &
             0.d0
         endif
         if(nstokes.eq.3)then
            write(*,'(I4,6F9.5)') &
              lg,                 &
              pCab_air(1,1,lg,k), &
              pCab_air(2,2,lg,k), &
              pCab_air(3,3,lg,k), &
              0.d0,               &
              pCab_air(1,2,lg,k), &
              0.d0
         endif
         if(nstokes.eq.4)then
            write(*,'(I4,6F9.5)') &
              lg,                 &
              pCab_air(1,1,lg,k), &
              pCab_air(2,2,lg,k), &
              pCab_air(3,3,lg,k), &
              pCab_air(4,4,lg,k), &
              pCab_air(1,2,lg,k), &
              pCab_air(3,4,lg,k)
         endif
      enddo
      write(*,*) &
        'Output Expansion coefficients for Raman scattering'
      write(*,*) 'lambda [nm] = ',wavelength_ns(ns_elas)
      write(*,'(A4,6A9)') &
        'lg','alpha1','alpha2','alpha3','alpha4','beta1','beta2'
      k = maxlay
      do lg=0,maxleg
         if(nstokes.eq.1)then
            write(*,'(I4,6F9.5)') &
              lg,                 &
              pRam_air(1,1,lg,k), &
              0.d0,               &
              0.d0,               &
              0.d0,               &
              0.d0,               &
              0.d0
         endif
         if(nstokes.eq.3)then
            write(*,'(I4,6F9.5)') &
              lg,                 &
              pRam_air(1,1,lg,k), &
              pRam_air(2,2,lg,k), &
              pRam_air(3,3,lg,k), &
              0.d0,               &
              pRam_air(1,2,lg,k), &
              0.d0
         endif
         if(nstokes.eq.4)then
            write(*,'(I4,6F9.5)') &
              lg,                 &
              pRam_air(1,1,lg,k), &
              pRam_air(2,2,lg,k), &
              pRam_air(3,3,lg,k), &
              pRam_air(4,4,lg,k), &
              pRam_air(1,2,lg,k), &
              pRam_air(3,4,lg,k)
         endif
      enddo
  endif

  return
end subroutine clearsky_optical_properties

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

subroutine RayCaB_Ram_expansion_coeff(A, B, C, N, coeff)

!--------------------------------------------------------------------
! Purpose:
!   Returns expansion coefficient matrix for Rayleigh, Cabannes
!   scattering in the form of weights,
!
!             ( alpha1  beta1     0       0     )
!     coeff = ( beta1   alpha2    0       0     )
!             (   0       0     alpha3   beta2  )
!             (   0       0     -beta2   alpha4 )
!
!   where expansion coeffcicients depend on Fourier moment lg=0,..,2
!   and wavelength [see Stam et al. JGR vol 107, D20, 2002]
!
!    lg   alpha1  alpha2  alpha3  alpha4      beta1      beta2
!   ------------------------------------------------------------
!     0      1       0       0       0          0           0
!     1      0       0       0      B/N         0           0
!     2    2A/3N    4A/N     0       0    4A/(N*(6**0.5))   0
!
!   the rest is zero. coeff=coeff(i1,i2,lg) where i1,i2 are index
!   for Stokes component, lg is Fourier moment index
!--------------------------------------------------------------------

  implicit none
  integer,parameter::dp=selected_real_kind(8) !double precision
  integer::lg,i1,i2
  logical,parameter::verbose = .false.
    real(kind=dp)::A,B,C,N,coeff(4,4,0:2)

  if(verbose) write(*,*) A,B,C,N

! Set all to zero
  do lg=0,2
     do i2=1,4
        do i1=1,4
           coeff(i1,i2,lg) = 0.d0
        enddo
     enddo
  enddo

! alpha1
  coeff(1,1,0) = 1.d0
  coeff(1,1,1) = 0.d0
  coeff(1,1,2) = 2.d0*A/(3.d0*N)

! alpha2
  coeff(2,2,0) = 0.d0
  coeff(2,2,1) = 0.d0
  coeff(2,2,2) = 4.d0*A/N

! alpha3
  coeff(3,3,0) = 0.d0
  coeff(3,3,1) = 0.d0
  coeff(3,3,2) = 0.d0

! alpha4
  coeff(4,4,0) = 0.d0
  coeff(4,4,1) = B/N
  coeff(4,4,2) = 0.d0

! beta1
  coeff(1,2,0) = 0.d0
  coeff(1,2,1) = 0.d0
  coeff(1,2,2) = 4.d0*A/(dsqrt(6.d0)*N)

  coeff(2,1,0) = coeff(1,2,0)
  coeff(2,1,1) = coeff(1,2,1)
  coeff(2,1,2) = coeff(1,2,2)

! beta2
  coeff(3,4,0) = 0.d0
  coeff(3,4,1) = 0.d0
  coeff(3,4,2) = 0.d0

  coeff(4,3,0) = -coeff(3,4,0)
  coeff(4,3,1) = -coeff(3,4,1)
  coeff(4,3,2) = -coeff(3,4,2)

  return
end subroutine RayCaB_Ram_expansion_coeff


************************************************************************
*
*     Subroutine TACIT_CALC         Called by: AMLSTAT, TACIT_G, TACIT_H
*
*     compute gaussian functions and their derivatives
*
************************************************************************
      SUBROUTINE TACIT_CALC(XSI,A)
*
*     subroutine arguments
*
      DOUBLE PRECISION XSI,A
*
*     function declaration
*
      DOUBLE PRECISION ERFC
*
*
*
      IF (XSI .LT. -6.D0) THEN
         A = -XSI
      ELSEIF (XSI .GT. 6.D0) THEN
         A = 0.D0
      ELSE
         A =  0.3989422D0*EXP(-0.5*XSI**2)/
     &        (1.D0 - ERFC(XSI*0.7071068)/2.D0)
      ENDIF

      RETURN
      END


!> \file sw_adtg.f90
!! \BRIEF
!> Module with sw_adtg function - compute adiabatic temp. gradient from S,T,P
MODULE msw_adtg
CONTAINS
!>  Function to calculate adiabatic temperature gradient as per UNESCO 1983 routines.
FUNCTION sw_adtg  (s,t,p)

  !     ==================================================================
  !     Calculates adiabatic temperature gradient as per UNESCO 1983 routines.
  !     Armin Koehl akoehl@ucsd.edu
  !     ==================================================================
  USE msingledouble
  IMPLICIT NONE
  !> salinity [psu (PSU-78)]
  REAL(kind=r8) :: s
  !> temperature [degree C (IPTS-68)]
  REAL(kind=r8) :: t
  !> pressure [db]
  REAL(kind=r8) :: p

  REAL(kind=r8) :: a0,a1,a2,a3,b0,b1,c0,c1,c2,c3,d0,d1,e0,e1,e2
  REAL(kind=r8) :: sref

  REAL(kind=r8) :: sw_adtg

  sref = 35.d0
  a0 =  3.5803d-5
  a1 = +8.5258d-6
  a2 = -6.836d-8
  a3 =  6.6228d-10

  b0 = +1.8932d-6
  b1 = -4.2393d-8

  c0 = +1.8741d-8
  c1 = -6.7795d-10
  c2 = +8.733d-12
  c3 = -5.4481d-14

  d0 = -1.1351d-10
  d1 =  2.7759d-12

  e0 = -4.6206d-13
  e1 = +1.8676d-14
  e2 = -2.1687d-16

  sw_adtg =  a0 + (a1 + (a2 + a3*T)*T)*T &
       + (b0 + b1*T)*(S-sref) &
       + ( (c0 + (c1 + (c2 + c3*T)*T)*T) + (d0 + d1*T)*(S-sref) )*P &
       + (  e0 + (e1 + e2*T)*T )*P*P

END FUNCTION sw_adtg

!>  Function to calculate adiabatic temperature gradient as per UNESCO 1983 routines.
!! and derivative with respect to temperature and salinity
FUNCTION sw_adtg_DNAD  (s,t,p)

  !     ==================================================================
  !     Calculates adiabatic temperature gradient as per UNESCO 1983 routines.
  !     Armin Koehl akoehl@ucsd.edu
  !     ==================================================================
  USE msingledouble
  USE Dual_Num_Auto_Diff
  IMPLICIT NONE
  !> salinity [psu (PSU-78)]
  TYPE(DUAL_NUM) :: s
  !> temperature [degree C (IPTS-68)]
  TYPE(DUAL_NUM) :: t
  !> pressure [db]
  TYPE(DUAL_NUM) :: p

  REAL(kind=r8) :: a0,a1,a2,a3,b0,b1,c0,c1,c2,c3,d0,d1,e0,e1,e2
  REAL(kind=r8) :: sref

  TYPE(DUAL_NUM) :: sw_adtg_DNAD

  sref = 35.d0
  a0 =  3.5803d-5
  a1 = +8.5258d-6
  a2 = -6.836d-8
  a3 =  6.6228d-10

  b0 = +1.8932d-6
  b1 = -4.2393d-8

  c0 = +1.8741d-8
  c1 = -6.7795d-10
  c2 = +8.733d-12
  c3 = -5.4481d-14

  d0 = -1.1351d-10
  d1 =  2.7759d-12

  e0 = -4.6206d-13
  e1 = +1.8676d-14
  e2 = -2.1687d-16

  sw_adtg_DNAD =  a0 + (a1 + (a2 + a3*T)*T)*T &
       + (b0 + b1*T)*(S-sref) &
       + ( (c0 + (c1 + (c2 + c3*T)*T)*T) + (d0 + d1*T)*(S-sref) )*P &
       + (  e0 + (e1 + e2*T)*T )*P*P

END FUNCTION sw_adtg_DNAD
END MODULE msw_adtg


! Comopute locally averaged statistics of lognormal variable
!                                          JS May 15 2007
      subroutine msla(dx,dy,thx,thy,kmn,ksd,varfnc,istat,kmne,ksde)
      real*8 dvar, dpb, dthx, dthy, dthz, ddx, ddy, oned
      real*8 dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2, uservf
      real*8 dmin1,dble
      real kmn, kmne, ksd, ksde
      character*(*) varfnc
      external dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2, uservf
      common/dparam/ dvar, dpb, dthx, dthy, dthz
      data zero/0.0/, half/0.5/, one/1.0/, two/2.0/, oned/1.d0/
   1  format(a,a)
   3  format(a,e12.5)
         pvr  = alog(one + ksd*ksd/(kmn*kmn))
         pmn  = alog(kmn) - half*pvr
         psd  = sqrt(pvr)
            dvar = oned
            dthx = thx
            dthy = thy
!					find mean and s.d. of log-conductivity
!					averaged over the element
            ddx  = dble(dx)
            ddy  = dble(dy)
            dvar = -dvar		! tell cov functions to return varfunc
            if( varfnc .eq. 'dlavx2' ) then
               vf  = dlavx2(ddx,ddy)
            elseif( varfnc .eq. 'dlsep2' ) then
               vf = dlsep2(ddx,ddy)
            elseif( varfnc .eq. 'dlspx2' ) then
               vf = dlspx2(ddx,ddy)
            elseif( varfnc .eq. 'dlafr2' ) then
               dpb = dmin1(ddx,ddy)
               vf  = dlafr2(ddx,ddy)
            elseif( varfnc .eq. 'dlsfr2' ) then
               dpb = dmin1(ddx,ddy)
               vf  = dlsfr2(ddx,ddy)
            elseif( varfnc .eq. 'uservf' ) then
               vf = uservf(ddx,ddy)
            else
               write(istat,1)'*** Error: unknown variance function name: ', varfnc
               stop
            endif
            dvar = -dvar		! tell cov functions to return cov
            kmne = exp(pmn + half*vf*pvr)
            ksde = kmne*sqrt((exp(vf*pvr) - one))
!						print out some information
            write(istat,3)'Variance reduction   = ',vf
            write(istat,3)'Point Log-Cond. mean = ',pmn
            write(istat,3)'Point Log-Cond. S.D. = ',psd
            write(istat,3)'Cell Cond. mean      = ',kmne
            write(istat,3)'Cell Cond. S.D.      = ',ksde
            write(istat,'()')
      return
      end


    program demo_merge
    implicit none
    integer :: tvals(2,3), fvals(2,3), answer(2,3)
    logical :: mask(2,3)
    integer :: i
    logical :: chooseleft

       tvals(1,:)=[  10, -60,  50 ]
       tvals(2,:)=[ -20,  40, -60 ]

       fvals(1,:)=[ 0, 3, 2 ]
       fvals(2,:)=[ 7, 4, 8 ]

       mask(1,:)=[ .true.,  .false., .true. ]
       mask(2,:)=[ .false., .false., .true. ]

       write(*,*)'mask of logicals'
       answer=merge( tvals, fvals, mask )
       call printme()

       write(*, *)'highest values'
       answer=merge( tvals, fvals, tvals > fvals )
       call printme()

       write(*, *)'lowest values'
       answer=merge( tvals, fvals, tvals < fvals )
       call printme()

       write(*, *)'zero out negative values'
       answer=merge( tvals, 0, tvals < 0)
       call printme()

       write(*, *)'binary choice'
       chooseleft=.false.
       write(*, '(3i4)')merge([1,2,3],[10,20,30],chooseleft)
       chooseleft=.true.
       write(*, '(3i4)')merge([1,2,3],[10,20,30],chooseleft)

    contains

    subroutine printme()
          write(*, '(3i4)')(answer(i, :), i=1, size(answer, dim=1))
    end subroutine printme

    end program demo_merge


      PROGRAM xbeschb
C     driver for routine beschb
      DOUBLE PRECISION gam1,gam2,gamp1,gammi,x,xgam1,xgam2,xgamp1,xgammi
      REAL gammln
1     write(*,*) 'Enter X'
      read(*,*,END=999) x
      call beschb(x,xgam1,xgam2,xgamp1,xgammi)
      write(*,'(1x,t3,a1)') 'X'
      write(*,'(1x,t5,a4,t21,a4,t37,a5,t53,a5)')
     *     'GAM1','GAM2','GAMP1','GAMMI'
      write(*,'(1x,t5,a4,t21,a4,t37,a5,t53,a5)')
     *     'XGAM1','XGAM2','XGAMP1','XGAMMI'
      gamp1=1/exp(gammln(1+sngl(x)))
      gammi=1/exp(gammln(1-sngl(x)))
      gam1=(gammi-gamp1)/(2*x)
      gam2=(gammi+gamp1)/2
      write(*,'(f6.2/1p4e16.6/1p4e16.6)')
     *     x,gam1,gam2,gamp1,gammi,xgam1,xgam2,xgamp1,xgammi
      go to 1
999   END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xbeschb.for


module Rref
  implicit none
contains
  subroutine to_rref(matrix)
    real, dimension(:,:), intent(inout) :: matrix

    integer :: pivot, norow, nocolumn
    integer :: r, i
    real, dimension(:), allocatable :: trow

    pivot = 1
    norow = size(matrix, 1)
    nocolumn = size(matrix, 2)

    allocate(trow(nocolumn))

    do r = 1, norow
       if ( nocolumn <= pivot ) exit
       i = r
       do while ( matrix(i, pivot) == 0 )
          i = i + 1
          if ( norow == i ) then
             i = r
             pivot = pivot + 1
             if ( nocolumn == pivot ) return
          end if
       end do
       trow = matrix(i, :)
       matrix(i, :) = matrix(r, :)
       matrix(r, :) = trow
       matrix(r, :) = matrix(r, :) / matrix(r, pivot)
       do i = 1, norow
          if ( i /= r ) matrix(i, :) = matrix(i, :) - matrix(r, :) * matrix(i, pivot)
       end do
       pivot = pivot + 1
    end do
    deallocate(trow)
  end subroutine to_rref
end module Rref


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program EFIE_RWG_test
    use meshread_mod
    use EFIE_functions
    use EFIE_RWG_matrices
    use linalg_mod
    use mpi
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh, msh_evl
    complex(8), allocatable :: Z(:,:), Einc(:,:), V(:), I(:), Epot(:,:,:), Es(:,:), Ex(:,:)
    real(8), allocatable :: xEvl(:,:)
    real(8) :: ExNorm, Error
    integer :: nEvl, n
    integer, parameter :: nNS = 6        ! number of quadrature points for EFIE
    real(8) :: cond_number

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8) :: k          ! free-space wavenumber [1/m]
    real(8) :: pol(3), src(3)
    character(len=100) :: file_msh, file_evl

    k = 0.5d0 * PI
    pol = [1.0d0, 1.0d0, 1.0d0]      ! polarization vector
    src = [-0.1d0, -0.1d0, -0.25d0]  ! location of dipole source

    file_msh = 'meshes/convergence_sphere/sph0400.msh'
    file_evl = 'meshes/convergence_sphere/sphNF0300.msh'

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute EFIE matrices
    if (id == 0) print *, "EFIE-RWG"
    call genEFIESauterSchwabMat_RWG(Z, msh, k, nNS, nNS)

    ! Solve system
    if (id == 0) then
        allocate(Einc(1:msh%nbNod,1:3))
        allocate(V(msh%nbEdg))
        allocate(I(msh%nbEdg))

        Einc = DipoleOnMesh(pol,src,k,msh)

        V = genRHS_EFIE_RWG(Einc, msh)
        call linsolve(I, Z, V, msh%nbEdg)

    end if

    ! Load eval mesh
    call load_gmsh(file_evl, msh_evl)
    nEvl = msh_evl%nbELm
    allocate(xEvl(1:nEvl,1:3))
    xEvl = msh_evl%CNTR + (msh%h/2.0d0**(0))*msh_evl%NRM

    ! Compute exact solution
    if (id==0) then
        allocate(Ex(1:nEvl,1:3))
        do n=1, nEvl
          Ex(n,:) = Dipole(pol,src,k,xEvl(n,:))
        end do
        ExNorm = maxval(sqrt(abs(Ex(:,1))**2+abs(Ex(:,2))**2+abs(Ex(:,3))**2))
    endif

    ! Compute EFIE potencial
    call genEFIEPot(Epot, nEvl, xEvl, msh, k)

    ! Compute BEM solution and error
    if (id==0) then
        allocate(Es(1:nEvl,1:3))
        Es(:,1) = matmul(Epot(:,:,1), I)
        Es(:,2) = matmul(Epot(:,:,2), I)
        Es(:,3) = matmul(Epot(:,:,3), I)

        Es = Es - Ex
        Error = maxval(sqrt(abs(Es(:,1))**2+abs(Es(:,2))**2+abs(Es(:,3))**2))

        write(*,*) 'h ',' Error (r) '
        write(*,*) msh%h, Error / ExNorm

        call cond(cond_number, Z, N, 'I')
        print *, ' cond: ', cond_number

    end if

    call MPI_Finalize(ierr)
end program