MODULE coolrates_module
  use amr_parameters,only:dp
  implicit none

CONTAINS

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_AlphaA_HII(T)

! Returns case A rec. coefficient [cm3 s-1] for HII (Hui&Gnedin'97)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_AlphaA_HII, lambda
!-------------------------------------------------------------------------
  lambda=  315614./T                                ! 2.d0 * 157807.d0 / T
  comp_AlphaA_HII =  1.269d-13 * lambda**1.503 &
                     / ( ( 1.d0+(lambda/0.522)**0.47 )**1.923 )
END FUNCTION comp_AlphaA_HII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_dAlphaA_dT_HII(T)

! Returns Temperature derivative of the case A rec. coeff. of HII
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_dAlphaA_dT_HII, lambda, f
!-------------------------------------------------------------------------
  lambda=  315614./T
  f= 1.d0+(lambda/0.522)**0.47
  comp_dAlphaA_dT_HII = 1.269d-13 * lambda**1.503 / f**1.923             &
                        / T * ( 0.90381*(f-1.)/f - 1.503 )
END FUNCTION comp_dAlphaA_dT_HII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_AlphaA_HeII(T)

! Returns case A rec. coefficient [cm3 s-1] for HeII (Hui&Gnedin'97)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_AlphaA_HeII, lambda
!-------------------------------------------------------------------------
  lambda=  570670./T
  comp_AlphaA_HeII =  3.d-14 * lambda**0.654
END FUNCTION comp_AlphaA_HeII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_AlphaA_HeIII(T)

! Returns case A rec. coefficient [cm3 s-1] for HeIII (Hui&Gnedin'97)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_AlphaA_HeIII, lambda
!-------------------------------------------------------------------------
  lambda=  1263030./T
  comp_AlphaA_HeIII =  2.538d-13 * lambda**1.503                         &
                     / ( ( 1.d0+(lambda/0.522)**0.47 )**1.923 )
END FUNCTION comp_AlphaA_HeIII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_AlphaB_HII(T)

! Returns case B rec. coefficient [cm3 s-1] for HII (Hui&Gnedin'97)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_AlphaB_HII, lambda
!-------------------------------------------------------------------------
  lambda = 315614./T
  comp_AlphaB_HII =  &
       2.753d-14 * lambda**1.5 / ( (1.d0+(lambda/2.74)**0.407)**2.242 )
END FUNCTION comp_AlphaB_HII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_AlphaB_HeII(T)

! Returns case B rec. coefficient [cm3 s-1] for HeII (Hui&Gnedin'97)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_AlphaB_HeII, lambda
!-------------------------------------------------------------------------
  lambda = 570670./T
  comp_AlphaB_HeII = 1.26d-14 * lambda**0.75
END FUNCTION comp_AlphaB_HeII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_AlphaB_HeIII(T)

! Returns case B rec. coefficient [cm3 s-1] for HeIII (Hui&Gnedin'97)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_AlphaB_HeIII, lambda
!-------------------------------------------------------------------------
  lambda=  1263030./T
  comp_AlphaB_HeIII =  5.506d-14 * lambda**1.5                           &
                     / ( ( 1.d0+(lambda/2.74)**0.407 )**2.242 )
END FUNCTION comp_AlphaB_HeIII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_dAlphaB_dT_HII(T)

! Returns temperature derivative of the case B recombination rate
! Gnedin 1997
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_dAlphaB_dT_HII, lambda, f
!-------------------------------------------------------------------------
  lambda = 315614./T
  f= 1.d0+(lambda/2.74)**0.407
  comp_dAlphaB_dT_HII = 2.753d-14 * lambda**1.5 / f**2.242               &
                  / T * ( 0.912494*(f-1.)/f - 1.5 )
END FUNCTION comp_dAlphaB_dT_HII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_Beta_HI(T)

! Returns collisional ionization rate [cm3 s-1] of HI (Maselli&'03)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_Beta_HI, T5
!-------------------------------------------------------------------------
  T5 = T/1.d5
  comp_Beta_HI = &
                5.85d-11 * sqrt(T) / (1.d0+sqrt(T5)) * exp(-157809.1d0/T)
END FUNCTION comp_Beta_HI

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_dBeta_dT_HI(T)

! Returns T derivative of collisional ionization rate [cm3 s-1] of HI
! (Maselli&'03)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::f, T5, comp_dBeta_dT_HI
!-------------------------------------------------------------------------
  T5 = T/1.d5
  f = 1.+sqrt(T5)
  comp_dBeta_dT_HI = 5.85d-11 * sqrt(T) / f * exp(-157809.1d0/T)         &
                * (0.5/T + 157809.1d0/T**2 - .5/(sqrt(1.d5*T)*f))
END FUNCTION comp_dBeta_dT_HI

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_Beta_HeI(T)

! Returns collisional ionization rate [cm3 s-1] of HeI (Maselli&'03)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_Beta_HeI, T5
!-------------------------------------------------------------------------
  T5 = T/1.d5
  comp_Beta_HeI = &
                2.38d-11 * sqrt(T) / (1.d0+sqrt(T5)) * exp(-285335.4d0/T)
END FUNCTION comp_Beta_HeI

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_Beta_HeII(T)

! Returns collisional ionization rate [cm3 s-1] of HeII (Maselli&'03)
! T           => Temperature [K]
!-------------------------------------------------------------------------
  implicit none
  real(dp),intent(in)::T
  real(dp)::comp_Beta_HeII, T5
!-------------------------------------------------------------------------
  T5 = T/1.d5
  comp_Beta_HeII = &
                5.68d-12 * sqrt(T) / (1.d0+sqrt(T5)) * exp(-631515.d0/T)
END FUNCTION comp_Beta_HeII

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
ELEMENTAL FUNCTION comp_collExrate_HI(TK)

! Gives Collisional Excitation rate coefficient for the 1->2
! transition in hydrogen atom energies, in [cm3 s-1], according to
! Callaway, Unnikrishnan & Oza 1987.
! TK      => Temperatue in Kelvin
!-------------------------------------------------------------------------
  real(dp),intent(in)::TK
  real(dp)::comp_collExrate_HI
  real(dp),parameter ::kB    = 1.38062d-16       ! Boltzm.const. [erg K-1]
!-------------------------------------------------------------------------
  comp_collExrate_HI =                                                   &
       2.41d-6/sqrt(TK) * (TK/1.d4)**0.22 * exp(-1.63d-11/(kb*TK))
END FUNCTION comp_collExrate_HI

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
FUNCTION compCoolrate(T, ne, nHI, nHII, nHeI, nHeII, nHeIII, aexp,     &
                       dcooldT, rt_OTSA)

! Compute cooling rate in a cell
! T        => Cell emperature [K]
! xion     => Cell ionization fraction
! nH       => Hydrogen number density [cm-3]
! aexp     => Cosmic expansion
! dcooldT <=  Temperature derivative of the rate
! dcooldx <=  Ionized fraction derivative of the rate
! returns:  Resulting cooling rate [erg s-1 cm-3]
!-------------------------------------------------------------------------
  implicit none
  real(dp)::T, ne, nHI, nHII, nHeI, nHeII, nHeIII, aexp
  real(dp)::compCoolrate, dcooldT!----------------------------------------
  real(dp)::T2, sqrtT, sqrt5T, fT5, sqrtT_fT5, f, Ta
  real(dp)::laHII, laHeII, laHeIII
  real(dp)::ci_HI, ci_HeI, ci_HeII, dci_HI, dci_HeI, dci_HeII
  real(dp)::r_HII, r_HeII, r_HeIII, dr_HII, dr_HeII, dr_HeIII
  real(dp)::ce_HI, ce_HeI, ce_HeII, dce_HI, dce_HeI, dce_HeII
  real(dp)::bre, dbre, com, dcom, die, ddie
  real(dp),parameter::kb=1.3806d-16        ! Boltzmann constant [ergs K-1]
  logical::RT_OTSA
!-------------------------------------------------------------------------
  T2       = T**2
  sqrtT    = sqrt(T)
  sqrt5T   = sqrt(1.d5*T)
  fT5      = 1.+sqrt(T/1.d5)

  ! Coll. Ionization Cooling from Cen 1992 (via Maselli et al 2003)
  sqrtT_fT5 = sqrtT/fT5
  ci_HI   = 1.27d-21 * sqrtT_fT5 * exp(-157809.1/T)           * ne *   nHI
  ci_HeI  = 9.38d-22 * sqrtT_fT5 * exp(-285335.4/T)           * ne *  nHeI
  ci_HeII = 4.95d-22 * sqrtT_fT5 * exp(-631515. /T)           * ne * nHeII
  f    = 0.5/T - 0.5/(sqrt5T+T)
  dci_HI  = ci_HI *   ( f + 157809.1/T2 )                             !dHI
  dci_HeI = ci_HeI *  ( f + 285335.4/T2 )                            !dHeI
  dci_HeII= ci_HeII * ( f + 631515.0/T2 )                           !dHeII

  ! Recombination Cooling (Hui&Gnedin'97)
  laHII  = 315614./T
  laHeII  = 570670./T
  laHeIII  = 1263030./T
  if(.not. rt_otsa) then ! Case A
     f       = 1.d0+(laHII/0.541)**0.502
     r_HII   = 1.778d-29 * laHII**1.965 / f**2.697 * T      * ne *   nHII
     dr_HII  = r_HII/T * ( - 0.965 + 1.35389*(f-1.)/f )             !dHII

     r_HeII  = 3.d-14 * laHeII**0.654 * kb * T              * ne *  nHeII
     dr_HeII = r_HeII / T * 0.346                                  !dHeII

     f       = 1.d0+(laHeIII/0.541)**0.502
     r_HeIII = 14.224d-29 * laHeIII**1.965 / f**2.697 * T   * ne * nHeIII
     dr_HeIII= r_HeIII/T * ( - 0.965 + 1.35389*(f-1.)/f )         !dHeIII
  else ! Case B
     f      = 1.d0+(laHII/2.25)**0.376
     r_HII  = 3.435d-30 * laHII**1.97 / f**3.72 * T         * ne *   nHII
     dr_HII = r_HII/T * ( - 0.97 + 1.39827*(f-1.)/f )               !dHII

     r_HeII  = 1.26d-14 * laHeII**0.75 * kb * T             * ne *  nHeII
     dr_HeII = r_HeII / T * 0.25                                   !dHeII

     f       = 1.d0+(laHeIII/2.25)**0.376
     r_HeIII = 27.48d-30 * laHeIII**1.97 / f**3.72 * T      * ne * nHeIII
     dr_HeIII =r_HeIII/T * ( - 0.97 + 1.39827*(f-1.)/f )          !dHeIII
  endif

  ! Collisional excitation cooling from Cen'92
  ce_HI  = 7.5d-19 * exp(-118348./T) / fT5                  * ne *    nHI
  ce_HeI = 9.10d-27 * exp(-13179./T) / fT5 * T**(-0.1687)   * ne *   nHeI
  ce_HeII = 5.54d-17 * exp(-473638./T) / fT5 * T**(-0.397)  * ne *  nHeII

  f = 0.5/(sqrt5T+T)
  dce_HI  = ce_HI * ( 118348./T2 - f)                                !dHI
  dce_HeI  = ce_HeI * ( 13179./T2 - f - 0.1687/T)                   !dHeI
  dce_HeII  = ce_HeII * ( 473638./T2 - f - 0.397/T)                !dHeII

  ! Bremsstrahlung from Osterbrock & Ferland 2006
  bre  = 1.42d-27 * 1.5 * sqrtT       * ne * (nHII + nHeII + 4. * nHeIII)
  dbre = bre * 0.5 / T

  ! Compton Cooling from Haimann et al. 96, via Maselli et al.
  Ta     = 2.727/aexp
  com     = 1.017d-37 * Ta**4 * (T-Ta)                               * ne
  dcom  = com / (T-Ta)

  ! Dielectronic recombination cooling, from Black 1981
  f = 1.24D-13*T**(-1.5d0)*exp(-470000.d0/T)                 * ne * nHeII
  die = f*(1.D0+0.3d0*exp(-94000.d0/T))
  ddie = die/T2*(564000.-1.5*T) - f*94000./T2

  ! Overall Cooling
  compCoolrate  = ci_HI    + r_HII    + ce_HI    + com    &
                + ci_HeI   + r_HeII   + ce_HeI   + die    &
                + ci_HeII  + r_HeIII  + ce_HeII  + bre

  dCooldT       = dci_HI   + dr_HII   + dce_HI   + dcom   &
                + dci_HeI  + dr_HeII  + dce_HeI  + ddie   &
                + dci_HeII + dr_HeIII + dce_HeII + dbre

END FUNCTION compCoolrate

END MODULE coolrates_module


MODULE common
!=======================================================================
!
! [PURPOSE:] General constants and procedures
!
! [ATTENTION:] This module calls 'SFMT.f90'
!
! [HISTORY:]
!   07/20/2004 Takemasa MIYOSHI  created
!   01/23/2009 Takemasa MIYOSHI  modified for SFMT
!
!=======================================================================
  IMPLICIT NONE
  PUBLIC
!-----------------------------------------------------------------------
! Variable size definitions
!-----------------------------------------------------------------------
  INTEGER,PARAMETER :: r_dble=kind(0.0d0)
  INTEGER,PARAMETER :: r_sngl=kind(0.0e0)
!#ifdef SINGLE
!  INTEGER,PARAMETER :: r_size=r_sngl
!#else
  INTEGER,PARAMETER :: r_size=r_dble
!#endif
!-----------------------------------------------------------------------
! Constants
!-----------------------------------------------------------------------
  REAL(r_size),PARAMETER :: pi=3.1415926535d0
  REAL(r_size),PARAMETER :: gg=9.81d0
  REAL(r_size),PARAMETER :: rd=287.05d0       ! gas constant air (J/kg/K)      GYL
  REAL(r_size),PARAMETER :: rv=461.50d0       ! gas constant H2O (J/kg/K)      GYL
  REAL(r_size),PARAMETER :: cp=1005.7d0       ! spec heat air [p] (J/kg/K)
  REAL(r_size),PARAMETER :: hvap=2.5d6        ! heat of vaporization (J/kg)
  REAL(r_size),PARAMETER :: fvirt=rv/rd-1.0d0 ! parameter for T/Tv conversion  GYL
  REAL(r_size),PARAMETER :: re=6371.3d3
  REAL(r_size),PARAMETER :: r_omega=7.292d-5
  REAL(r_size),PARAMETER :: t0c=273.15d0
  REAL(r_size),PARAMETER :: undef=-9.99d33
  REAL(r_size),PARAMETER :: deg2rad=pi/180.0d0 ! GYL
  REAL(r_size),PARAMETER :: rad2deg=180.0d0/pi ! GYL

CONTAINS
!-----------------------------------------------------------------------
! Mean
!-----------------------------------------------------------------------
SUBROUTINE com_mean(ndim,var,amean)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: amean

  INTEGER :: i

  amean = 0.0d0
  DO i=1,ndim
    amean = amean + var(i)
  END DO
  amean = amean / REAL(ndim,r_size)

  RETURN
END SUBROUTINE com_mean
!-----------------------------------------------------------------------
! Standard deviation
!-----------------------------------------------------------------------
SUBROUTINE com_stdev(ndim,var,aout)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: aout

  REAL(r_size) :: amean
  REAL(r_size) :: dev(ndim)

  CALL com_mean(ndim,var,amean)

  dev(:) = var(:) - amean

  aout = SQRT( SUM(dev*dev) / REAL(ndim-1,r_size) )

  RETURN
END SUBROUTINE com_stdev
!-----------------------------------------------------------------------
! Covariance
!-----------------------------------------------------------------------
SUBROUTINE com_covar(ndim,var1,var2,cov)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var1(ndim)
  REAL(r_size),INTENT(IN) :: var2(ndim)
  REAL(r_size),INTENT(OUT) :: cov

  REAL(r_size) :: amean1,amean2
  REAL(r_size) :: dev1(ndim),dev2(ndim)

  CALL com_mean(ndim,var1,amean1)
  CALL com_mean(ndim,var2,amean2)

  dev1(:) = var1(:) - amean1
  dev2(:) = var2(:) - amean2

  cov = SUM( dev1*dev2 ) / REAL(ndim-1,r_size)

  RETURN
END SUBROUTINE com_covar
!-----------------------------------------------------------------------
! Correlation
!-----------------------------------------------------------------------
SUBROUTINE com_correl(ndim,var1,var2,cor)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var1(ndim)
  REAL(r_size),INTENT(IN) :: var2(ndim)
  REAL(r_size),INTENT(OUT) :: cor

  REAL(r_size) :: cov,stdev1,stdev2

  CALL com_stdev(ndim,var1,stdev1)
  CALL com_stdev(ndim,var2,stdev2)
  CALL com_covar(ndim,var1,var2,cov)

  cor = cov/stdev1/stdev2

  RETURN
END SUBROUTINE com_correl
!-----------------------------------------------------------------------
! Anomaly Correlation
!-----------------------------------------------------------------------
SUBROUTINE com_anomcorrel(ndim,var1,var2,varmean,cor)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var1(ndim)
  REAL(r_size),INTENT(IN) :: var2(ndim)
  REAL(r_size),INTENT(IN) :: varmean(ndim)
  REAL(r_size),INTENT(OUT) :: cor

  REAL(r_size) :: dev1(ndim),dev2(ndim)

  dev1 = var1 - varmean
  dev2 = var2 - varmean

  cor = SUM( dev1*dev2 ) / SQRT( SUM(dev1*dev1) * SUM(dev2*dev2) )

  RETURN
END SUBROUTINE com_anomcorrel
!-----------------------------------------------------------------------
! L2 Norm
!-----------------------------------------------------------------------
SUBROUTINE com_l2norm(ndim,var,anorm)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: anorm

  anorm = SQRT( SUM(var*var) )

  RETURN
END SUBROUTINE com_l2norm
!-----------------------------------------------------------------------
! RMS (root mean square)
!-----------------------------------------------------------------------
SUBROUTINE com_rms(ndim,var,rmsv)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: rmsv

  rmsv = SQRT( SUM(var*var) / REAL(ndim,r_size) )

  RETURN
END SUBROUTINE com_rms
!-----------------------------------------------------------------------
! Lanczos Filter (Low-pass) with cyclic boundary
!-----------------------------------------------------------------------
SUBROUTINE com_filter_lanczos(ndim,fc,var)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: fc    ! critical frequency in [0,pi]
  REAL(r_size),INTENT(INOUT) :: var(ndim)

  INTEGER,PARAMETER :: lresol=10

  REAL(r_size) :: weight(-lresol:lresol)
  REAL(r_size) :: varwk(1-lresol:ndim+lresol)
  REAL(r_size) :: rl,rlresol
  INTEGER :: i,l
!
! Weight
!
  rlresol = REAL(lresol,r_size)
  DO l=-lresol,-1
    rl = REAL(l,r_size)
    weight(l) = SIN(fc*rl) * SIN(pi*rl/rlresol) &
      & * rlresol / pi / rl / pi / rl
  END DO
  DO l=1,lresol
    rl = REAL(l,r_size)
    weight(l) = SIN(fc*rl) * SIN(pi*rl/rlresol) &
      & * rlresol / pi / rl / pi / rl
  END DO
  weight(0) = fc / pi
!
! Cyclic boundary
!
  DO i=0,1-lresol,-1
    varwk(i) = var(ndim+i)
  END DO
  DO i=ndim+1,ndim+lresol
    varwk(i) = var(i-ndim)
  END DO
  varwk(1:ndim) = var(1:ndim)
!
! Filter
!
  var = 0.0d0
  DO i=1,ndim
    DO l=-lresol,lresol
      var(i) = var(i) + weight(l) * varwk(i+l)
    END DO
  END DO

  RETURN
END SUBROUTINE com_filter_lanczos
!-----------------------------------------------------------------------
! RAND (random number with uniform distribution)
!-----------------------------------------------------------------------
SUBROUTINE com_rand(ndim,var)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(OUT) :: var(1:ndim)
  REAL(r_dble) :: genrand_res53
  INTEGER :: idate(8)
  INTEGER :: i,iseed
  LOGICAL,SAVE :: first=.true.

  IF (first) THEN
    CALL DATE_AND_TIME(VALUES=idate)
    iseed = idate(8) + idate(7)*1000
    CALL init_gen_rand(iseed)
    first=.false.
  END IF

  DO i=1,ndim
    var(i) = genrand_res53()
  END DO

  RETURN
END SUBROUTINE com_rand
!-----------------------------------------------------------------------
! RANDN (random number with normal distribution)
!-----------------------------------------------------------------------
SUBROUTINE com_randn(ndim,var)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(OUT) :: var(1:ndim)
  REAL(r_size) :: rnd(2)
  REAL(r_dble) :: genrand_res53
  INTEGER :: idate(8)
  INTEGER :: i,iseed
  LOGICAL,SAVE :: first=.true.

  IF (first) THEN
    CALL DATE_AND_TIME(VALUES=idate)
    iseed = idate(8) + idate(7)*1000
    CALL init_gen_rand(iseed)
    first=.false.
  END IF

  IF( MOD(ndim,2)==0 ) THEN
    DO i=1,ndim/2
      rnd(1) = genrand_res53()
      rnd(2) = genrand_res53()
      var(i*2-1) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
      var(i*2) = sqrt( -2.0d0 * log( rnd(1) ) ) * cos( 2.0d0*pi*rnd(2) )
    END DO
  ELSE
    DO i=1,(ndim-1)/2
      rnd(1) = genrand_res53()
      rnd(2) = genrand_res53()
      var(i*2-1) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
      var(i*2) = sqrt( -2.0d0 * log( rnd(1) ) ) * cos( 2.0d0*pi*rnd(2) )
    END DO
    rnd(1) = genrand_res53()
    rnd(2) = genrand_res53()
    var(ndim) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
  END IF

  RETURN
END SUBROUTINE com_randn
!-----------------------------------------------------------------------
! TIMEINC
!-----------------------------------------------------------------------
SUBROUTINE com_timeinc_hr(iy,im,id,ih,incr)
  IMPLICIT NONE

  INTEGER,INTENT(INOUT) :: iy
  INTEGER,INTENT(INOUT) :: im
  INTEGER,INTENT(INOUT) :: id
  INTEGER,INTENT(INOUT) :: ih
  INTEGER,INTENT(IN) :: incr

  ih = ih + incr
  IF(ih>23) THEN
    ih = ih - 24
    id = id + 1
    IF(id==29.AND.im==2.AND.mod(iy,4)/=0) THEN
      id = 1
      im = 3
    ELSE IF(id==30.AND.im==2.AND.mod(iy,4)==0) THEN
      id = 1
      im = 3
    ELSE IF(id==31.AND.(im==4.OR.im==6.OR.im==9.OR.im==11)) THEN
      id = 1
      im = im + 1
    ELSE IF(id==32.AND.(im==1.OR.im==3.OR.im==5.OR.im==7.OR.im==8.OR.im==10)) THEN
      id = 1
      im = im + 1
    ELSE IF(id==32.AND.im==12) THEN
      id = 1
      im = 1
      iy = iy + 1
    END IF
  END IF

  RETURN
END SUBROUTINE com_timeinc_hr
!-----------------------------------------------------------------------
! TIMECONVERSION
!-----------------------------------------------------------------------
SUBROUTINE com_time2ymdh(itime,iy,im,id,ih)
  IMPLICIT NONE
  INTEGER(8),INTENT(IN) :: itime
  INTEGER,INTENT(OUT) :: iy
  INTEGER,INTENT(OUT) :: im
  INTEGER,INTENT(OUT) :: id
  INTEGER,INTENT(OUT) :: ih

  iy = INT(  itime / 1000000 )
  im = INT( (itime-iy*1000000) / 10000 )
  id = INT( (itime-iy*1000000-im*10000) / 100 )
  ih = INT(  itime-iy*1000000-im*10000-id*100 )

  RETURN
END SUBROUTINE com_time2ymdh

SUBROUTINE com_ymdh2time(iy,im,id,ih,itime)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: iy
  INTEGER,INTENT(IN) :: im
  INTEGER,INTENT(IN) :: id
  INTEGER,INTENT(IN) :: ih
  INTEGER(8),INTENT(OUT) :: itime

  itime=iy*1000000+im*10000+id*100+ih

  RETURN
END SUBROUTINE com_ymdh2time
!-----------------------------------------------------------------------
! DISTANCE BETWEEN TWO POINTS (LONa,LATa)-(LONb,LATb)
!-----------------------------------------------------------------------
SUBROUTINE com_distll(ndim,alon,alat,blon,blat,dist)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: alon(ndim)
  REAL(r_size),INTENT(IN) :: alat(ndim)
  REAL(r_size),INTENT(IN) :: blon(ndim)
  REAL(r_size),INTENT(IN) :: blat(ndim)
  REAL(r_size),INTENT(OUT) :: dist(ndim)
  REAL(r_size),PARAMETER :: r180=1.0d0/180.0d0
  REAL(r_size) :: lon1,lon2,lat1,lat2
  REAL(r_size) :: cosd(ndim)
  INTEGER :: i

  DO i=1,ndim
    lon1 = alon(i) * pi * r180
    lon2 = blon(i) * pi * r180
    lat1 = alat(i) * pi * r180
    lat2 = blat(i) * pi * r180

    cosd(i) = SIN(lat1)*SIN(lat2) + COS(lat1)*COS(lat2)*COS(lon2-lon1)
    cosd(i) = MIN( 1.d0,cosd(i))
    cosd(i) = MAX(-1.d0,cosd(i))

    dist(i) = ACOS( cosd(i) ) * re
  END DO

  RETURN
END SUBROUTINE com_distll
!-----------------------------------------------------------------------
! DISTANCE BETWEEN TWO POINTS (LONa,LATa)-(LONb,LATb)
!-----------------------------------------------------------------------
SUBROUTINE com_distll_1(alon,alat,blon,blat,dist)
  IMPLICIT NONE
  REAL(r_size),INTENT(IN) :: alon
  REAL(r_size),INTENT(IN) :: alat
  REAL(r_size),INTENT(IN) :: blon
  REAL(r_size),INTENT(IN) :: blat
  REAL(r_size),INTENT(OUT) :: dist
  REAL(r_size),PARAMETER :: r180=1.0d0/180.0d0
  REAL(r_size) :: lon1,lon2,lat1,lat2
  REAL(r_size) :: cosd

  lon1 = alon * pi * r180
  lon2 = blon * pi * r180
  lat1 = alat * pi * r180
  lat2 = blat * pi * r180

  cosd = SIN(lat1)*SIN(lat2) + COS(lat1)*COS(lat2)*COS(lon2-lon1)
  cosd = MIN( 1.d0,cosd)
  cosd = MAX(-1.d0,cosd)

  dist = ACOS( cosd ) * re

  RETURN
END SUBROUTINE com_distll_1
!-----------------------------------------------------------------------
! Cubic spline interpolation
!   [Reference:] Akima, H., 1970: J. ACM, 17, 589-602.
!-----------------------------------------------------------------------
SUBROUTINE com_interp_spline(ndim,x,y,n,x5,y5)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: ndim         ! number of grid points
  REAL(r_size),INTENT(IN) :: x(ndim) ! coordinate
  REAL(r_size),INTENT(IN) :: y(ndim) ! variable
  INTEGER,INTENT(IN) :: n            ! number of targets
  REAL(r_size),INTENT(IN) :: x5(n)   ! target coordinates
  REAL(r_size),INTENT(OUT) :: y5(n)  ! target values
  INTEGER :: i,j,m
  REAL(r_size) :: dydx(5),ddydx(4),t(2),dx21,dx
  REAL(r_size) :: wk

  TGT: DO j=1,n
    DO i=1,ndim
      IF(x5(j) == x(i)) THEN
        y5(j) = y(i)
        CYCLE TGT
      END IF
      IF(x5(j) < x(i)) EXIT
    END DO
!       i-3   i-2   i-1    i    i+1   i+2
!     ---+-----+-----+---*-+-----+-----+---
!dydx       1     2     3     4     5
!ddydx         1     2     3     4
!t                   1     2
    IF(i==2) THEN
      DO m=3,5
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(2) = 2.0d0*dydx(3) - dydx(4)
      dydx(1) = 2.0d0*dydx(2) - dydx(3)
    ELSE IF(i==3) THEN
      DO m=2,5
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(1) = 2.0d0*dydx(2) - dydx(3)
    ELSE IF(i==ndim) THEN
      DO m=1,3
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(4) = 2.0d0*dydx(3) - dydx(2)
      dydx(5) = 2.0d0*dydx(4) - dydx(3)
    ELSE IF(i==ndim-1) THEN
      DO m=1,4
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(5) = 2.0d0*dydx(4) - dydx(3)
    ELSE
      DO m=1,5
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
    END IF
    DO m=1,4
      ddydx(m) = ABS(dydx(m+1) - dydx(m))
    END DO
    DO m=1,2
      wk = ddydx(m+2) + ddydx(m)
      IF(wk == 0) THEN
        t(m) = 0.0d0
      ELSE
        t(m) = (ddydx(m+2)*dydx(m+1)+ddydx(m)*dydx(m+2))/wk
      END IF
    END DO
    dx21 = x(i)-x(i-1)
    dx = x5(j) - x(i-1)
    y5(j) = y(i-1) &
        & + dx*t(1) &
        & + dx*dx*(3.0d0*dydx(3)-2.0d0*t(1)-t(2))/dx21 &
        & + dx*dx*dx*(t(1)+t(2)-2.0d0*dydx(3))/dx21/dx21
  END DO TGT

  RETURN
END SUBROUTINE com_interp_spline
!-----------------------------------------------------------------------
! (LON,LAT) --> (i,j) conversion
!   [ORIGINAL AUTHOR:] Masaru Kunii
!-----------------------------------------------------------------------
SUBROUTINE com_pos2ij(msw,nx,ny,flon,flat,num_obs,olon,olat,oi,oj)
  IMPLICIT NONE
  ! --- inout variables
  INTEGER,INTENT(IN) :: msw   !MODE SWITCH: 1: fast, 2: accurate
  INTEGER,INTENT(IN) :: nx,ny !number of grid points
  REAL(r_size),INTENT(IN) :: flon(nx,ny),flat(nx,ny) !(lon,lat) at (i,j)
  INTEGER,INTENT(IN) :: num_obs !repetition number of conversion
  REAL(r_size),INTENT(IN) :: olon(num_obs),olat(num_obs) !target (lon,lat)
  REAL(r_size),INTENT(OUT) :: oi(num_obs),oj(num_obs) !target (i,j)
  ! --- local work variables
  LOGICAL,PARAMETER :: detailout = .FALSE.
  INTEGER,PARAMETER :: num_grid_ave = 4  ! fix
  INTEGER :: inum,ix,jy,ip,wk_maxp
  INTEGER :: iorder_we,iorder_sn
  INTEGER :: nxp,nyp
  REAL(r_size),PARAMETER :: miss = -32768
  REAL(r_size),PARAMETER :: max_dist = 2.0e+6
  REAL(r_size) :: rlat_max, rlat_min, rlon_max, rlon_min
  REAL(r_size) :: dist(num_grid_ave)
  REAL(r_size) :: dist_min_x(num_obs, num_grid_ave)
  REAL(r_size) :: dist_min_y(num_obs, num_grid_ave)
  REAL(r_size) :: wk_dist, sum_dist
  REAL(r_size) :: ratio(num_grid_ave)
  IF(detailout) THEN
    WRITE(6,'(A)') '====================================================='
    WRITE(6,'(A)') '      Detailed output of SUBROUTINE com_pos2ij       '
    WRITE(6,'(A)') '====================================================='
  END IF
  ! ================================================================
  !   Check the Order of flon, flat
  ! ================================================================
  iorder_we = 1
  iorder_sn = 1
  IF(flon(1,1) > flon(2,1)) THEN
    iorder_we = -1
  END IF
  IF(flat(1,1) > flat(1,2)) THEN
    iorder_sn = -1
  END IF
  IF(detailout) THEN
    WRITE(6,'(3X,A,I5)') 'Obs Order (WE) :',iorder_we
    WRITE(6,'(3X,A,I5)') 'Obs Order (SN) :',iorder_sn
  END IF
  ! ================================================================
  !  FAST MODE
  ! ================================================================
  IF(msw == 1) THEN
    ! ==============================================================
    !   Surrounding 4 Grid Points Interpolation
    ! ==============================================================
    Obs_Loop_1 : DO inum=1,num_obs
      IF(detailout) WRITE(6,'(A,I5,2F15.5)') '*** START OBS ',inum,olon(inum),olat(inum)
      ! ------------------------------------------------------------
      !    Search Basic Point
      ! ------------------------------------------------------------
      nxp = miss
      nyp = miss
      DO jy=1,ny-1
        DO ix=1,nx-1
          rlon_max = MAXVAL(flon(ix:ix+1, jy:jy+1))
          rlon_min = MINVAL(flon(ix:ix+1, jy:jy+1))
          rlat_max = MAXVAL(flat(ix:ix+1, jy:jy+1))
          rlat_min = MINVAL(flat(ix:ix+1, jy:jy+1))
          IF(rlon_min <= olon(inum) .AND. rlon_max >= olon(inum) .AND. &
           & rlat_min <= olat(inum) .AND. rlat_max >= olat(inum)) THEN
            nxp = ix
            nyp = jy
            EXIT
          END IF
        END DO
      END DO
      IF(detailout) WRITE(6,'(3X,A,2I7)') 'nxp, nyp =',nxp,nyp
      IF(nxp == miss .OR. nyp == miss) THEN
        WRITE(6,'(A)') '!!WARNING(com_pos2ij): obs position cannot be detected'
        oi(inum) = miss
        oj(inum) = miss
        CYCLE Obs_Loop_1
      END IF
      ! ------------------------------------------------------------
      !    Interpolation
      ! ------------------------------------------------------------
      CALL com_distll_1(flon(nxp  ,nyp  ),flat(nxp  ,nyp  ),&
                      & olon(inum),olat(inum),dist(1))
      CALL com_distll_1(flon(nxp+1,nyp  ),flat(nxp+1,nyp  ),&
                      & olon(inum),olat(inum),dist(2))
      CALL com_distll_1(flon(nxp  ,nyp+1),flat(nxp  ,nyp+1),&
                      & olon(inum),olat(inum),dist(3))
      CALL com_distll_1(flon(nxp+1,nyp+1),flat(nxp+1,nyp+1),&
                      & olon(inum),olat(inum),dist(4))
      dist(1:4) = dist(1:4) * 1.D-3
      IF(detailout) WRITE(6,'(3X,A,4F15.5)') 'distance :',dist(1:4)
      sum_dist = dist(1) * dist(1) * dist(2) * dist(2) * dist(3) * dist(3) &
             & + dist(2) * dist(2) * dist(3) * dist(3) * dist(4) * dist(4) &
             & + dist(3) * dist(3) * dist(4) * dist(4) * dist(1) * dist(1) &
             & + dist(4) * dist(4) * dist(1) * dist(1) * dist(2) * dist(2)
      ratio(1) = (dist(2)*dist(2)*dist(3)*dist(3)*dist(4)*dist(4))/sum_dist
      ratio(2) = (dist(3)*dist(3)*dist(4)*dist(4)*dist(1)*dist(1))/sum_dist
      ratio(3) = (dist(4)*dist(4)*dist(1)*dist(1)*dist(2)*dist(2))/sum_dist
      ratio(4) = (dist(1)*dist(1)*dist(2)*dist(2)*dist(3)*dist(3))/sum_dist
      IF(detailout) WRITE(6,'(3X,A,5F15.5)') 'ratio    :',ratio(1:4),SUM(ratio(1:4))
      oi(inum) = ratio(1) *  nxp    + ratio(2) * (nxp+1) &
             & + ratio(3) *  nxp    + ratio(4) * (nxp+1)
      oj(inum) = ratio(1) *  nyp    + ratio(2) *  nyp    &
             & + ratio(3) * (nyp+1) + ratio(4) * (nyp+1)
      IF(detailout) WRITE(6,'(3X,A,2F15.5)') 'position :',oi(inum), oj(inum)

    END DO Obs_Loop_1
  ! ================================================================
  !  ACCURATE MODE
  ! ================================================================
  ELSE IF(msw == 2) THEN
    ! ================================================================
    !   Nearest 4 Grid Points Interpolation
    ! ================================================================
    Obs_Loop_2 : DO inum=1,num_obs
      IF(detailout) WRITE(6,'(A,I5,2F15.5)') '*** START OBS ',inum,olon(inum),olat(inum)
      ! ------------------------------------------------------------
      !    Search 4-Grid Points
      ! ------------------------------------------------------------
      dist(1:num_grid_ave) = 1.D+10
      wk_maxp = num_grid_ave
      DO jy=1,ny
        DO ix=1,nx
          CALL com_distll_1(flon(ix,jy),flat(ix,jy),&
                          & olon(inum) ,olat(inum) ,wk_dist)
          IF(wk_dist > max_dist) CYCLE
          IF(wk_dist < dist(wk_maxp)) THEN
            dist(wk_maxp) = wk_dist
            dist_min_x(inum, wk_maxp) = ix
            dist_min_y(inum, wk_maxp) = jy
            DO ip = 1, num_grid_ave
              IF(dist(ip) == maxval(dist(1:num_grid_ave))) THEN
                wk_maxp = ip
                EXIT
              END IF
            END DO
          END IF
        END DO
      END DO
      IF(detailout) WRITE(6,'(A,4(A,I4,A,I4,A))')  '  Intp Grids : ', &
        & '(', INT(dist_min_x(inum, 1)), ',', INT(dist_min_y(inum, 1)), ') ', &
        & '(', INT(dist_min_x(inum, 2)), ',', INT(dist_min_y(inum, 2)), ') ', &
        & '(', INT(dist_min_x(inum, 3)), ',', INT(dist_min_y(inum, 3)), ') ', &
        & '(', INT(dist_min_x(inum, 4)), ',', INT(dist_min_y(inum, 4)), ') '
      ! ------------------------------------------------------------
      !    Interpolation
      ! ------------------------------------------------------------
      dist(1:num_grid_ave) =  dist(1:num_grid_ave) * 1.0D-3
      sum_dist = dist(1) * dist(1) * dist(2) * dist(2) * dist(3) * dist(3)  &
             & + dist(2) * dist(2) * dist(3) * dist(3) * dist(4) * dist(4)  &
             & + dist(3) * dist(3) * dist(4) * dist(4) * dist(1) * dist(1)  &
             & + dist(4) * dist(4) * dist(1) * dist(1) * dist(2) * dist(2)
      ratio(1) = (dist(2)*dist(2)*dist(3)*dist(3)*dist(4)*dist(4))/sum_dist
      ratio(2) = (dist(3)*dist(3)*dist(4)*dist(4)*dist(1)*dist(1))/sum_dist
      ratio(3) = (dist(4)*dist(4)*dist(1)*dist(1)*dist(2)*dist(2))/sum_dist
      ratio(4) = (dist(1)*dist(1)*dist(2)*dist(2)*dist(3)*dist(3))/sum_dist
      IF(detailout) WRITE(6,'(2X,A,5F15.5)') 'ratio      :',ratio(1:4),SUM(ratio(1:4))
      oi(inum) = SUM(ratio(1:num_grid_ave) * dist_min_x(inum, 1:num_grid_ave))
      oj(inum) = SUM(ratio(1:num_grid_ave) * dist_min_y(inum, 1:num_grid_ave))
      IF(detailout) WRITE(6,'(2X,A,2F15.5)') 'position   :',oi(inum),oj(inum)
    END DO Obs_Loop_2
  END IF

  RETURN
END SUBROUTINE com_pos2ij
!-----------------------------------------------------------------------
! UTC to TAI93
!-----------------------------------------------------------------------
SUBROUTINE com_utc2tai(iy,im,id,ih,imin,sec,tai93)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: iy,im,id,ih,imin
  REAL(r_size),INTENT(IN) :: sec
  REAL(r_size),INTENT(OUT) :: tai93
  REAL(r_size),PARAMETER :: mins = 60.0d0
  REAL(r_size),PARAMETER :: hour = 60.0d0*mins
  REAL(r_size),PARAMETER :: day = 24.0d0*hour
  REAL(r_size),PARAMETER :: year = 365.0d0*day
  INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
  INTEGER :: days,i

  tai93 = REAL(iy-1993,r_size)*year + FLOOR(REAL(iy-1993)/4.0,r_size)*day
  days = id -1
  DO i=1,12
    IF(im > i) days = days + mdays(i)
  END DO
  IF(MOD(iy,4) == 0 .AND. im > 2) days = days + 1 !leap year
  tai93 = tai93 + REAL(days,r_size)*day + REAL(ih,r_size)*hour &
              & + REAL(imin,r_size)*mins + sec
  IF(iy > 1993 .OR. (iy==1993 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1994 .OR. (iy==1994 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1995) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1997 .OR. (iy==1997 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1998) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 2005) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 2008) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 2012 .OR. (iy==2012 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second

  RETURN
END SUBROUTINE com_utc2tai
!-----------------------------------------------------------------------
! TAI93 to UTC
!-----------------------------------------------------------------------
SUBROUTINE com_tai2utc(tai93,iy,im,id,ih,imin,sec)
  IMPLICIT NONE
  INTEGER,PARAMETER :: n=8 ! number of leap seconds after Jan. 1, 1993
  INTEGER,PARAMETER :: leapsec(n) = (/  15638399,  47174400,  94608001,&
                                  &    141868802, 189302403, 410227204,&
                                  &    504921605, 615254406/)
  REAL(r_size),INTENT(IN) :: tai93
  INTEGER,INTENT(OUT) :: iy,im,id,ih,imin
  REAL(r_size),INTENT(OUT) :: sec
  REAL(r_size),PARAMETER :: mins = 60.0d0
  REAL(r_size),PARAMETER :: hour = 60.0d0*mins
  REAL(r_size),PARAMETER :: day = 24.0d0*hour
  REAL(r_size),PARAMETER :: year = 365.0d0*day
  INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
  REAL(r_size) :: wk,tai
  INTEGER :: days,i,leap

  tai = tai93
  sec = 0.0d0
  DO i=1,n
    IF(FLOOR(tai93) == leapsec(i)+1) sec = 60.0d0 + tai93-FLOOR(tai93,r_size)
    IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0
  END DO
  iy = 1993 + FLOOR(tai /year)
  wk = tai - REAL(iy-1993,r_size)*year - FLOOR(REAL(iy-1993)/4.0,r_size)*day
  IF(wk < 0.0d0) THEN
    iy = iy -1
    wk = tai - REAL(iy-1993,r_size)*year - FLOOR(REAL(iy-1993)/4.0,r_size)*day
  END IF
  days = FLOOR(wk/day)
  wk = wk - REAL(days,r_size)*day
  im = 1
  DO i=1,12
    leap = 0
    IF(im == 2 .AND. MOD(iy,4)==0) leap=1
    IF(im == i .AND. days >= mdays(i)+leap) THEN
      im = im + 1
      days = days - mdays(i)-leap
    END IF
  END DO
  id = days +1

  ih = FLOOR(wk/hour)
  wk = wk - REAL(ih,r_size)*hour
  imin = FLOOR(wk/mins)
  IF(sec < 60.0d0) sec = wk - REAL(imin,r_size)*mins

  RETURN
END SUBROUTINE com_tai2utc
!-----------------------------------------------------------------------
! Date and time regulation
!-----------------------------------------------------------------------
SUBROUTINE com_datetime_reg(iy,im,id,ih,imin,isec)
  IMPLICIT NONE
  INTEGER, INTENT(INOUT) :: iy,im,id,ih,imin,isec
  INTEGER :: mdays

  DO WHILE(im <= 0)
    im = im + 12
    iy = iy - 1
  END DO
  DO WHILE(im > 12)
    im = im - 12
    iy = iy + 1
  END DO
  DO WHILE(isec < 0)
    isec = isec + 60
    imin = imin - 1
  END DO
  DO WHILE(isec >= 60)
    isec = isec - 60
    imin = imin + 1
  END DO
  DO WHILE(imin < 0)
    imin = imin + 60
    ih = ih - 1
  END DO
  DO WHILE(imin >= 60)
    imin = imin - 60
    ih = ih + 1
  END DO
  DO WHILE(ih < 0)
    ih = ih + 24
    id = id - 1
  END DO
  DO WHILE(ih >= 24)
    ih = ih - 24
    id = id + 1
  END DO
  DO WHILE(id <= 0)
    im = im - 1
    IF(im <= 0) THEN
      im = im + 12
      iy = iy - 1
    END IF
    CALL com_mdays(iy,im,mdays)
    id = id + mdays
  END DO
  CALL com_mdays(iy,im,mdays)
  DO WHILE(id > mdays)
    id = id - mdays
    im = im + 1
    IF(im > 12) THEN
      im = im - 12
      iy = iy + 1
    END IF
    CALL com_mdays(iy,im,mdays)
  END DO

  RETURN
END SUBROUTINE com_datetime_reg
!-----------------------------------------------------------------------
! Number of days of the month
!-----------------------------------------------------------------------
SUBROUTINE com_mdays(iy,im,mdays)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: iy,im
  INTEGER, INTENT(OUT) :: mdays

  SELECT CASE(im)
  CASE(1,3,5,7,8,10,12)
    mdays = 31
  CASE(4,6,9,11)
    mdays = 30
  CASE(2)
    mdays = 28
    IF(MOD(iy,100) == 0) THEN
      IF(MOD(iy,400) == 0) THEN
        mdays = 29
      END IF
    ELSE IF(MOD(iy,4) == 0) THEN
      mdays = 29
    END IF
  CASE DEFAULT
    WRITE(6,'(A)') '[Error] com_mdays: invalid month.'
    STOP
  END SELECT
END SUBROUTINE com_mdays

!-----------------------------------------------------------------------
! GAMMA FUNCTION
!-----------------------------------------------------------------------

!==================================================
!       Purpose: Compute the gamma function â(x)
!       Input :  x  --- Argument of â(x)
!                       ( x is not equal to 0,-1,-2,úúú )
!       Output:  GA --- â(x)
!==================================================
! Proff. Jianming Jin
! Department of Electrical and Computer Engineering
! University of Illinois

SUBROUTINE com_gamma(x,ga)

        IMPLICIT NONE
        REAL(r_size) :: X , GA
        REAL(r_size) :: G(26)
        REAL(r_size) :: Z , R , GR
        INTEGER      :: M1, K , M

        !DIMENSION G(26)
        IF (X.EQ.INT(X)) THEN
           IF (X.GT.0.0D0) THEN
              GA=1.0D0
              M1=X-1
              DO 10 K=2,M1
10               GA=GA*K
           ELSE
              GA=1.0D+300
           ENDIF
        ELSE
           IF (DABS(X).GT.1.0D0) THEN
              Z=DABS(X)
              M=INT(Z)
              R=1.0D0
              DO 15 K=1,M
15               R=R*(Z-K)
              Z=Z-M
           ELSE
              Z=X
           ENDIF
           DATA G/1.0D0,0.5772156649015329D0,                 &
            -0.6558780715202538D0, -0.420026350340952D-1,     &
            0.1665386113822915D0,-.421977345555443D-1,        &
            -.96219715278770D-2, .72189432466630D-2,          &
            -.11651675918591D-2, -.2152416741149D-3,          &
            .1280502823882D-3, -.201348547807D-4,             &
            -.12504934821D-5, .11330272320D-5,                &
            -.2056338417D-6, .61160950D-8,                    &
            .50020075D-8, -.11812746D-8,                      &
            .1043427D-9, .77823D-11,                          &
            -.36968D-11, .51D-12,                             &
            -.206D-13, -.54D-14, .14D-14, .1D-15/
           GR=G(26)
           DO 20 K=25,1,-1
20            GR=GR*Z+G(K)
           GA=1.0D0/(GR*Z)
           IF (DABS(X).GT.1.0D0) THEN
              GA=GA*R
              IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X))
           ENDIF
        ENDIF
        RETURN
END SUBROUTINE com_gamma

!-----------------------------------------------------------------------
! Lon , lat moving in a certain direction.
!-----------------------------------------------------------------------

!-------------------------------------------------------------------------------------
! Compute the lat and lon reached by moving a certain distance in a certain direction
!        Formula from Map Projections - a working manual.  USGS paper
!        1395.  Equations (5-5) and (5-6).
!-------------------------------------------------------------------------------------
! Note: This routine should be moved to the common module
! Input azimuth in degrees with respect to North
! Input distance in meters
! Input and output lat lon in degrees

SUBROUTINE com_ll_arc_distance(ini_lon,ini_lat,distance,azimuth,final_lon,final_lat)
IMPLICIT NONE
REAL(r_size), INTENT(IN)  :: ini_lon,ini_lat,distance,azimuth
REAL(r_size), INTENT(OUT) :: final_lon,final_lat
REAL(r_size)  :: cdist,sdist,sinll1,cosll1

 IF ( distance .EQ. 0d0 )THEN
    final_lon=ini_lon
    final_lat=ini_lat
 ELSE

 cdist = cos(distance/Re)
 sdist = sin(distance/Re)

 sinll1 = sin(ini_lat*deg2rad)
 cosll1 = cos(ini_lat*deg2rad)

 final_lat=asin(sinll1*cdist + cosll1*sdist*cos(azimuth*deg2rad))/deg2rad
 final_lon=ini_lon + (1/deg2rad)*atan2(sdist*sin(azimuth*deg2rad),cosll1*cdist - sinll1*sdist*cos(azimuth*deg2rad))

 ENDIF
END SUBROUTINE com_ll_arc_distance

END MODULE common


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! { dg-require-effective-target fortran_large_int }
!
! PR fortran/41711
!
! Check reading and writing of real(10/16) BOZ,
! which needs integer(16) support.
!
implicit none
character(len=256) :: str
integer,parameter :: xp = selected_real_kind (precision (0.0d0)+1)
real(xp)    :: r1,r2
complex(xp) :: z1,z2

r2 = 5.0_xp
r1 = 2.0_xp
! Real B(OZ)
write(str,'(b128)') r1
read (str,'(b128)') r2
if(r2 /= r1) STOP 1
! Real (B)O(Z)
r2 = 5.0_xp
write(str,'(o126)') r1
read (str,'(o126)') r2
if(r2 /= r1) STOP 2
! Real (BO)Z
r2 = 5.0_xp
write(str,'(z126)') r1
read (str,'(z126)') r2
if(r2 /= r1) STOP 3

z2 = cmplx(5.0_xp,7.0_xp)
z1 = cmplx(2.0_xp,3.0_xp)
! Complex B(OZ)
write(str,'(2b128)') z1
read (str,'(2b128)') z2
if(z2 /= z1) STOP 4
! Complex (B)O(Z)
z2 = cmplx(5.0_xp,7.0_xp)
write(str,'(2o126)') z1
read (str,'(2o126)') z2
if(z2 /= z1) STOP 5
! Complex (BO)Z
z2 = cmplx(5.0_xp,7.0_xp)
write(str,'(2z126)') z1
read (str,'(2z126)') z2
if(z2 /= z1) STOP 6
end


function add(x, y)
  real :: x
  real :: y
  real :: add
  add = x + y
end function add

program t

  real :: r
  r = add(10.55, 5.1010)
  print *,  r

end program t


      subroutine ksol(nright,neq,nsb,a,r,s,ising)
c-----------------------------------------------------------------------
c
c                Solution of a System of Linear Equations
c                ****************************************
c
c
c
c INPUT VARIABLES:
c
c   nright,nsb       number of columns in right hand side matrix.
c                      for KB2D: nright=1, nsb=1
c   neq              number of equations
c   a()              upper triangular left hand side matrix (stored
c                      columnwise)
c   r()              right hand side matrix (stored columnwise)
c                      for kb2d, one column per variable
c
c
c
c OUTPUT VARIABLES:
c
c   s()              solution array, same dimension as  r  above.
c   ising            singularity indicator
c                      0,  no singularity problem
c                     -1,  neq .le. 1
c                      k,  a null pivot appeared at the kth iteration
c
c
c
c PROGRAM NOTES:
c
c   1. Requires the upper triangular left hand side matrix.
c   2. Pivots are on the diagonal.
c   3. Does not search for max. element for pivot.
c   4. Several right hand side matrices possible.
c   5. USE for ok and sk only, NOT for UK.
c
c
c-----------------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      real*8   a(*),r(*),s(*)
c
c If there is only one equation then set ising and return:
c
      if(neq.le.1) then
            ising = -1
            return
      endif
c
c Initialize:
c
      tol   = 0.1e-06
      ising = 0
      nn    = neq*(neq+1)/2
      nm    = nsb*neq
      m1    = neq-1
      kk    = 0
c
c Start triangulation:
c
      do k=1,m1
            kk=kk+k
            ak=a(kk)
            if(abs(ak).lt.tol) then
                  ising=k
                  return
            endif
            km1=k-1
            do iv=1,nright
                  nm1=nm*(iv-1)
                  ii=kk+nn*(iv-1)
                  piv=1./a(ii)
                  lp=0
                  do i=k,m1
                        ll=ii
                        ii=ii+i
                        ap=a(ii)*piv
                        lp=lp+1
                        ij=ii-km1
                        do j=i,m1
                              ij=ij+j
                              ll=ll+j
                              a(ij)=a(ij)-ap*a(ll)
                        end do
                        do llb=k,nm,neq
                              in=llb+lp+nm1
                              ll1=llb+nm1
                              r(in)=r(in)-ap*r(ll1)
                        end do
                  end do
            end do
      end do
c
c Error checking - singular matrix:
c
      ijm=ij-nn*(nright-1)
      if(abs(a(ijm)).lt.tol) then
            ising=neq
            return
      endif
c
c Finished triangulation, start solving back:
c
      do iv=1,nright
            nm1=nm*(iv-1)
            ij=ijm+nn*(iv-1)
            piv=1./a(ij)
            do llb=neq,nm,neq
                  ll1=llb+nm1
                  s(ll1)=r(ll1)*piv
            end do
            i=neq
            kk=ij
            do ii=1,m1
                  kk=kk-i
                  piv=1./a(kk)
                  i=i-1
                  do llb=i,nm,neq
                        ll1=llb+nm1
                        in=ll1
                        ap=r(in)
                        ij=kk
                        do j=i,m1
                              ij=ij+j
                              in=in+1
                              ap=ap-a(ij)*s(in)
                        end do
                        s(ll1)=ap*piv
                  end do
            end do
      end do
c
c Finished solving back, return:
c
      return
      end


      subroutine SplineCub(x, y, d, n, type, A_d, A_sd, qdy, lll)
*
*     PURPOSE
*        computes a cubic spline interpolation function
*        in Hermite form (ie computes the derivatives d(i) of the
*        spline in each interpolation point (x(i), y(i)))
*
*     ARGUMENTS
*      inputs :
*         n       number of interpolation points (n >= 3)
*         x, y    the n interpolation points, x must be in strict increasing order
*         type    type of the spline : currently
*                    type = 0 correspond to a  NOT_A_KNOT spline where it is
*                             imposed the conditions :
*                                 s'''(x(2)-) = s'''(x(2)+)
*                             and s'''(x(n-1)-) = s'''(x(n-1)+)
*                    type = 1 correspond to a NATURAL spline with the conditions :
*                                 s''(x1) = 0
*                             and s''(xn) = 0
*                    type = 2 correspond to a CLAMPED spline (d(1) and d(n) are given)
*
*                    type = 3 correspond to a PERIODIC spline
*      outputs :
*         d    the derivatives in each x(i) i = 1..n
*
*      work arrays :
*         A_d(1..n), A_sd(1..n-1), qdy(1..n-1)
*         lll(1..n-1) (used only in the periodic case)
*
*    NOTES
*         this routine requires (i)   n >= 3 (for natural) n >=4 (for not_a_knot)
*                               (ii)  strict increasing abscissae x(i)
*                               (iii) y(1) = y(n) in the periodic case
*         THESE CONDITIONS MUST BE TESTED IN THE CALLING CODE
*
*     AUTHOR
*        Bruno Pincon
*
*     July 22 2004 : correction of the case not_a_knot which worked only
*                    for equidistant abscissae
*
      implicit none

      integer n, type
      double precision x(n), y(n), d(n), A_d(n), A_sd(n-1), qdy(n-1),
     $                 lll(n-1)

      include 'constinterp.h'
      integer i
      double precision r

      if (n .eq. 2) then
         if (type .ne. CLAMPED) then
            d(1) = (y(2) - y(1)) / (x(2) - x(1))
            d(2) = d(1)
         endif
         return
      endif

      if (n .eq. 3  .and.  type .eq. NOT_A_KNOT) then
         call derivd(x, y, d, n, 1, FAST)
         return
      endif

      do i = 1, n-1
         A_sd(i) = 1.d0 / (x(i+1) - x(i))
         qdy(i) = (y(i+1) - y(i)) * A_sd(i)**2
      enddo

*     compute the coef matrix and r.h.s. for rows 2..n-1
*     (which don't relies on the type)
      do i = 2, n-1
         A_d(i) = 2.d0*( A_sd(i-1) + A_sd(i) )
         d(i) = 3.d0 * ( qdy(i-1) + qdy(i) )
      enddo

*     compute equ 1 and n in function of the type
      if (type .eq. NATURAL) then
         A_d(1) =  2.d0*A_sd(1)
         d(1) = 3.d0 * qdy(1)
         A_d(n) =  2.d0*A_sd(n-1)
         d(n) =  3.d0 * qdy(n-1)
         call TriDiagLDLtSolve(A_d, A_sd, d, n)

      else if (type .eq. NOT_A_KNOT) then
         !  s'''(x(2)-) = s'''(x(2)+)
         r = A_sd(2)/A_sd(1)
         A_d(1) = A_sd(1)/(1.d0 + r)
         d(1) = ((3.d0*r+2.d0)*qdy(1)+r*qdy(2))/(1.d0+r)**2
         !  s'''(x(n-1)-) = s'''(x(n-1)+)
         r = A_sd(n-2)/A_sd(n-1)
         A_d(n) = A_sd(n-1)/(1.d0 + r)
         d(n) = ((3.d0*r+2.d0)*qdy(n-1)+r*qdy(n-2))/(1.d0+r)**2
         call TriDiagLDLtSolve(A_d, A_sd, d, n)

      else if (type .eq. CLAMPED) then
         ! d(1) and d(n) are already known
         d(2) = d(2) - d(1)*A_sd(1)
         d(n-1) = d(n-1) - d(n)*A_sd(n-1)
         call TriDiagLDLtSolve(A_d(2), A_sd(2), d(2), n-2)

      else if (type .eq. PERIODIC) then
         A_d(1) = 2.d0*( A_sd(1) + A_sd(n-1) )
         d(1) = 3.d0 * ( qdy(1) + qdy(n-1) )
         lll(1) = A_sd(n-1)
         call dset(n-2, 0.d0, lll(2),1)  ! mise a zero
         lll(n-2) = A_sd(n-2)
         call CyclicTriDiagLDLtSolve(A_d, A_sd, lll, d, n-1)
         d(n) = d(1)

      endif

      end ! subroutine SplineCub

      subroutine TriDiagLDLtSolve(d, l, b, n)
*
*     PURPOSE
*        solve a linear system A x = b with a symetric tridiagonal positive definite
*        matrix A by using an LDL^t factorization
*
*     PARAMETERS
*        d(1..n)   : on input the diagonal of A
*                    on output the diagonal of the (diagonal) matrix D
*        l(1..n-1) : on input the sub-diagonal of A
*                    on output the sub-diagonal of L
*        b(1..n)   : on input contains the r.h.s. b
*                    on output the solution x
*        n         : the dimension
*
*     CAUTION
*        no zero pivot detection
*
      implicit none
      integer n
      double precision d(n), l(n-1), b(n)

      integer i
      double precision temp

      do i = 2, n
         temp = l(i-1)
         l(i-1) = l(i-1) / d(i-1)
         d(i) = d(i) - temp * l(i-1)
         b(i) = b(i) - l(i-1)*b(i-1)
      enddo

      b(n) = b(n) / d(n)
      do i = n-1, 1, -1
         b(i) = b(i)/d(i) - l(i)*b(i+1)
      enddo

      end ! subroutine TriDiagLDLtSolve

      subroutine CyclicTriDiagLDLtSolve(d, lsd, lll, b, n)
*
*     PURPOSE
*        solve a linear system A x = b with a symetric "nearly" tridiagonal
*        positive definite matrix A by using an LDL^t factorization,
*        the matrix A has the form :
*
*          |x x         x|                        |1            |
*          |x x x        |                        |x 1          |
*          |  x x x      |                        |  x 1        |
*          |    x x x    |  and so the L is like  |    x 1      |
*          |      x x x  |                        |      x 1    |
*          |        x x x|                        |        x 1  |
*          |x         x x|                        |x x x x x x 1|
*
*     PARAMETERS
*        d(1..n)     : on input the diagonal of A
*                      on output the diagonal of the (diagonal) matrix D
*        lsd(1..n-2) : on input the sub-diagonal of A (without  A(n,n-1))
*                      on output the sub-diagonal of L (without  L(n,n-1))
*        lll(1..n-1) : on input the last line of A (without A(n,n))
*                      on output the last line of L (without L(n,n))
*        b(1..n)     : on input contains the r.h.s. b
*                      on output the solution x
*        n           : the dimension
*
*     CAUTION
*        no zero pivot detection
*
      implicit none
      integer n
      double precision d(n), lsd(n-2), lll(n-1), b(n)

      integer i, j
      double precision temp1, temp2

*     compute the LDL^t factorization
      do i = 1, n-2
         temp1 = lsd(i)
         temp2 = lll(i)
         lsd(i) = lsd(i) / d(i) ! elimination coef L(i,i-1)
         lll(i) = lll(i) / d(i) ! elimination coef L(n,i-1)

         d(i+1)   = d(i+1)   - lsd(i) * temp1 ! elimination on line i+1
         lll(i+1) = lll(i+1) - lll(i) * temp1 ! elimination on line n
         d(n)     = d(n)     - lll(i) * temp2 ! elimination on line n
      enddo
      temp2 = lll(n-1)
      lll(n-1) = lll(n-1) / d(n-1)
      d(n)     = d(n) - lll(n-1) * temp2

*     solve LDL^t x = b  (but use b for x and for the intermediary vectors...)
      do i = 2, n-1
         b(i) = b(i) - lsd(i-1)*b(i-1)
      enddo
      do j = 1, n-1
         b(n) = b(n) - lll(j)*b(j)
      enddo

      do i = 1, n
         b(i) = b(i) / d(i)
      enddo

      b(n-1) = b(n-1) - lll(n-1)*b(n)
      do i = n-2, 1, -1
         b(i) = b(i) - lsd(i)*b(i+1) - lll(i)*b(n)
      enddo

      end ! subroutine CyclicTriDiagLDLtSolve

      integer function isearch(t, x, n)
*
*     PURPOSE
*        x(1..n) being an array (with strict increasing order and n >=2)
*        representing intervals, this routine return i such that :
*
*           x(i) <= t <= x(i+1)
*
*        and 0 if t is not in [x(1), x(n)]
*
      implicit none
      integer n
      double precision t, x(n)

      integer i1, i2, i

      if ( x(1) .le. t  .and.  t .le. x(n)) then
*        dichotomic search
         i1 = 1
         i2 = n
         do while ( i2 - i1 .gt. 1 )
            i = (i1 + i2)/2
            if ( t .le. x(i) ) then
               i2 = i
            else
               i1 = i
            endif
         enddo
         isearch = i1
      else
         isearch = 0
      endif

      end

      subroutine EvalPWHermite(t, st, dst, d2st, d3st, m, x, y, d, n,
     $                         outmode)
*
*     PURPOSE
*        evaluation at the abscissae t(1..m) of the piecewise hermite function
*        define by x(1..n), y(1..n), d(1..n) (d being the derivatives at the
*        x(i)) together with its derivative, second derivative and third derivative
*
*     PARAMETERS
*
*        outmode : define what return in case t(j) not in [x(1), x(n)]

      implicit none
      integer m, n, outmode
      double precision t(m), st(m), dst(m), d2st(m), d3st(m),
     $                 x(n), y(n), d(n)

      include 'constinterp.h'
      integer i, j
      integer  isearch, isanan
      external isearch, isanan
      double precision tt
      double precision return_a_nan
      external         return_a_nan
      logical new_call
      common /INFO_HERMITE/new_call

      new_call = .true.
      i = 0
      do j = 1, m
         tt = t(j)
         call fast_int_search(tt, x, n, i)  ! recompute i only if necessary

         if ( i .ne. 0 ) then
            call EvalHermite(tt, x(i), x(i+1), y(i), y(i+1), d(i),
     $                       d(i+1), st(j), dst(j), d2st(j), d3st(j), i)

         else   ! t(j) is outside [x(1), x(n)] evaluation depend upon outmode

            if (outmode .eq. BY_NAN  .or.  isanan(tt) .eq. 1) then
               st(j) = return_a_nan()
               dst(j) = st(j)
               d2st(j) = st(j)
               d3st(j) = st(j)

            elseif (outmode .eq. BY_ZERO) then
               st(j) = 0.d0
               dst(j) = 0.d0
               d2st(j) = 0.d0
               d3st(j) = 0.d0

            elseif (outmode .eq. C0) then
               dst(j) = 0.d0
               d2st(j) = 0.d0
               d3st(j) = 0.d0
               if ( tt .lt. x(1) ) then
                  st(j) = y(1)
               else
                  st(j) = y(n)
               endif

            elseif (outmode .eq. LINEAR) then
               d2st(j) = 0.d0
               d3st(j) = 0.d0
               if ( tt .lt. x(1) ) then
                  dst(j) = d(1)
                  st(j) = y(1) + (tt - x(1))*d(1)
               else
                  dst(j) = d(n)
                  st(j) = y(n) + (tt - x(n))*d(n)
               endif

            else
               if (outmode .eq. NATURAL) then
                  call near_interval(tt, x, n, i)
               elseif (outmode .eq. PERIODIC) then
                  call coord_by_periodicity(tt, x, n, i)
               endif
               call EvalHermite(tt, x(i), x(i+1), y(i), y(i+1), d(i),
     $                       d(i+1), st(j), dst(j), d2st(j), d3st(j), i)
            endif
         endif
      enddo

      end ! subroutine EvalPWHermite

      subroutine EvalHermite(t, xa, xb, ya, yb, da, db, h, dh, ddh,
     $                       dddh, i)

      implicit none
      double precision t, xa, xb, ya, yb, da, db, h, dh, ddh, dddh
      integer i

      logical new_call
      common /INFO_HERMITE/new_call

      double precision tmxa, dx, p, c2, c3
      integer          old_i
      save             old_i,       c2, c3
      data old_i/0/

      if (old_i .ne. i  .or.  new_call) then
*        compute the following Newton form :
*           h(t) = ya + da*(t-xa) + c2*(t-xa)^2 + c3*(t-xa)^2*(t-xb)
         dx = 1.d0/(xb - xa)
         p = (yb - ya) * dx
         c2 = (p - da) * dx
         c3 = ( (db - p) + (da - p) ) * (dx*dx)
         new_call = .false.
      endif
      old_i = i

*     eval h(t), h'(t), h"(t) and h"'(t), by a generalised Horner 's scheme
      tmxa = t - xa
      h = c2 + c3*(t - xb)
      dh = h + c3*tmxa
      ddh = 2.d0*( dh + c3*tmxa )
      dddh = 6.d0*c3
      h = da + h*tmxa
      dh = h + dh*tmxa
      h = ya + h*tmxa

      end ! subroutine EvalHermite

      subroutine fast_int_search(xx, x, nx, i)

      implicit none
      integer nx, i
      double precision xx, x(nx)

      integer  isearch
      external isearch

      if ( i .eq. 0 ) then
         i = isearch(xx, x, nx)
      elseif ( .not. (x(i) .le. xx  .and.  xx .le. x(i+1))) then
         i = isearch(xx, x, nx)
      endif

      end

      subroutine coord_by_periodicity(t, x, n, i)
*
*     PURPOSE
*        recompute t such that t in [x(1), x(n)] by periodicity :
*        and then the interval i of this new t
*
      implicit none
      integer n, i
      double precision t, x(n)
      integer  isearch
      external isearch

      double precision r, dx

      dx = x(n) - x(1)
      r = (t - x(1)) / dx

      if (r .ge. 0.d0) then
         t = x(1) + (r - aint(r))*dx
      else
         r = abs(r)
         t = x(n) - (r - aint(r))*dx
      endif

      ! some cautions in case of roundoff errors (is necessary ?)
      if (t .lt. x(1)) then
         t = x(1)
         i = 1
      else if (t .gt. x(n)) then
         t = x(n)
         i  = n-1
      else
         i = isearch(t, x, n)
      endif

      end ! subroutine coord_by_periodicity

      subroutine near_grid_point(xx, x, nx, i)
*
*     calcule le point de la grille le plus proche ... a detailler
*
      implicit none
      integer i, nx
      double precision xx, x(nx)

      if (xx .lt. x(1)) then
         i = 1
         xx = x(1)
      else    !  xx > x(nx)
         i = nx-1
         xx = x(nx)
      endif

      end

      subroutine near_interval(xx, x, nx, i)
*
*     idem sans modifier xx
*
      implicit none
      integer i, nx
      double precision xx, x(nx)

      if (xx .lt. x(1)) then
         i = 1
      else    !  xx > x(nx)
         i = nx-1
      endif

      end

      subroutine proj_by_per(t, xmin, xmax)
*
*     PURPOSE
*        recompute t such that t in [xmin, xmax] by periodicity.
*
      implicit none
      double precision t, xmin, xmax
      double precision r, dx

      dx = xmax - xmin
      r = (t - xmin) / dx

      if (r .ge. 0.d0) then
         t = xmin + (r - aint(r))*dx
      else
         r = abs(r)
         t = xmax - (r - aint(r))*dx
      endif

      ! some cautions in case of roundoff errors (is necessary ?)
      if (t .lt. xmin) then
         t = xmin
      else if (t .gt. xmax) then
         t = xmax
      endif

      end ! subroutine proj_by_per

      subroutine proj_on_grid(xx, xmin, xmax)
*
      implicit none
      double precision xx, xmin, xmax

      if (xx .lt. xmin) then
         xx = xmin
      else
         xx = xmax
      endif

      end

      double precision function return_a_nan()

      implicit none

      logical first
      double precision a, b
      save    first
      data    first /.true./

      data    a /1.d0/, b /1.d0/
      save    a

      if (first) then
         first = .false.
         a = (a - b) / (a - b)
      endif

      return_a_nan = a

      end

      subroutine BiCubicSubSpline(x, y, u, nx, ny, C, p, q, r, type)
*
*     PURPOSE
*        compute bicubic subsplines
*
      implicit none
      integer nx, ny, type
      double precision x(nx), y(ny), u(nx, ny), C(4,4,nx-1,ny-1),
     $                 p(nx, ny), q(nx, ny), r(nx, ny)
      integer i, j
      include 'constinterp.h'

      if (type .eq. MONOTONE) then
*        approximation des derivees par SUBROUTINE DPCHIM(N,X,F,D,INCFD)
         ! p = du/dx
         do j = 1, ny
            call dpchim(nx, x, u(1,j), p(1,j), 1)
         enddo
         ! q = du/dy
         do i = 1, nx
            call dpchim(ny, y, u(i,1), q(i,1), nx)
         enddo
         ! r = d2 u/ dx dy  approchee via  dq / dx
         do j = 1, ny
            call dpchim(nx, x, q(1,j), r(1,j), 1)
         enddo

      elseif (type .eq. FAST  .or.  type .eq. FAST_PERIODIC) then
*        approximation des derivees partielles par methode simple

         ! p = du/dx
         do j = 1, ny
            call derivd(x, u(1,j), p(1,j), nx, 1, type)
         enddo
         ! q = du/dy
         do i = 1, nx
            call derivd(y, u(i,1), q(i,1), ny, nx, type)
         enddo
         ! r = d2 u/ dx dy  approchee via  dq / dx
         do j = 1, ny
            call derivd(x, q(1,j), r(1,j), nx, 1, type)
         enddo

      endif

*     calculs des coefficients dans les bases (x-x(i))^k (y-y(j))^l  0<= k,l <= 3
*     pour evaluation rapide via Horner par la suite
      call coef_bicubic(u, p, q, r, x, y, nx, ny, C)

      end ! subroutine BiCubicSubSpline

      subroutine BiCubicSpline(x, y, u, nx, ny, C, p, q, r,
     $                         A_d, A_sd, d, ll, qdu, u_temp, type)
*
*     PURPOSE
*        compute bicubic splines
*
      implicit none
      integer nx, ny, type
      double precision x(nx), y(ny), u(nx, ny), C(4,4,nx-1,ny-1),
     $                 p(nx, ny), q(nx, ny), r(nx, ny), A_d(*),
     $                 A_sd(*), d(ny), ll(*), qdu(*), u_temp(ny)
      include 'constinterp.h'
      integer i, j

      ! compute du/dx
      do j = 1, ny
         call SplineCub(x, u(1,j), p(1,j), nx, type, A_d, A_sd, qdu, ll)
      enddo

      ! compute du/dy
      do i = 1, nx
         call dcopy(ny, u(i,1), nx, u_temp, 1)
         call SplineCub(y, u_temp, d, ny, type, A_d, A_sd, qdu, ll)
         call dcopy(ny, d, 1, q(i,1), nx)
      enddo

      ! compute ddu/dxdy
      call SplineCub(x, q(1,1),  r(1,1),  nx, type, A_d, A_sd, qdu, ll)
      call SplineCub(x, q(1,ny), r(1,ny), nx, type, A_d, A_sd, qdu, ll)

      do i = 1, nx
         call dcopy(ny, p(i,1), nx, u_temp, 1)
         d(1) = r(i,1)
         d(ny) = r(i,ny)
         call SplineCub(y, u_temp, d, ny, CLAMPED, A_d, A_sd, qdu, ll)
         call dcopy(ny-2, d(2), 1, r(i,2), nx)
      enddo

*     calculs des coefficients dans les bases (x-x(i))^k (y-y(j))^l  0<= k,l <= 3
*     pour evaluation rapide via Horner par la suite
      call coef_bicubic(u, p, q, r, x, y, nx, ny, C)

      end  ! subroutine BiCubicSpline

      subroutine derivd(x, u, du, n, inc, type)
*
*     PURPOSE
*        given functions values u(i) at points x(i),  i = 1, ..., n
*        this subroutine computes approximations du(i) of the derivative
*        at the points x(i).
*
*     METHOD
*        For i in [2,n-1], the "centered" formula of order 2 is used :
*            d(i) = derivative at x(i) of the interpolation polynomial
*                   of the points {(x(j),u(j)), j in [i-1,i+1]}
*
*         For i=1 and n, if type = FAST_PERIODIC  (in which case u(n)=u(1)) then
*         the previus "centered" formula is also used else (type = FAST), d(1)
*         is the derivative at x(1) of the interpolation polynomial of
*         {(x(j),u(j)), j in [1,3]} and the same method is used for d(n)
*
*     ARGUMENTS
*      inputs :
*         n       integer : number of point (n >= 2)
*         x, u    double precision : the n points, x must be in strict increasing order
*         type    integer : FAST (the function is non periodic) or FAST_PERIODIC
*                 (the function is periodic), in this last case u(n) must be equal to u(1))
*         inc     integer : to deal easily with 2d applications, u(i) is in fact
*                 u(1,i) with u declared as u(inc,*) to avoid the direct management of
*                 the increment inc (the i th value given with u(1 + inc*(i-1) ...)
*      outputs :
*         d       the derivatives in each x(i) i = 1..n
*
*    NOTES
*         this routine requires (i)   n >= 2
*                               (ii)  strict increasing abscissae x(i)
*                               (iii) u(1)=u(n) if type = FAST_PERIODIC
*         ALL THESE CONDITIONS MUST BE TESTED IN THE CALLING CODE
*
*     AUTHOR
*        Bruno Pincon
*

      implicit none
      integer n, inc, type
      double precision x(n), u(inc,*), du(inc,*)

      include 'constinterp.h'
      double precision dx_l, du_l, dx_r, du_r, w_l, w_r
      integer i

      if (n .eq. 2) then  ! special case used linear interp
         du(1,1) = (u(1,2) - u(1,1))/(x(2)-x(1))
         du(1,2) = du(1,1)
         return
      endif

      if (type .eq. FAST_PERIODIC) then

         dx_r  = x(n)-x(n-1)
         du_r  = (u(1,1) - u(1,n-1)) / dx_r
         do i = 1, n-1
            dx_l = dx_r
            du_l = du_r
            dx_r = x(i+1) - x(i)
            du_r = (u(1,i+1) - u(1,i))/dx_r
            w_l  = dx_r/(dx_l + dx_r)
            w_r = 1.d0 - w_l
            du(1,i) = w_l*du_l + w_r*du_r
         enddo
         du(1,n) = du(1,1)

      else if (type .eq. FAST) then

         dx_l = x(2) - x(1)
         du_l = (u(1,2) - u(1,1))/dx_l
         dx_r = x(3) - x(2)
         du_r = (u(1,3) - u(1,2))/dx_r
         w_l = dx_r/(dx_l + dx_r)
         w_r = 1.d0 - w_l
         du(1,1) = (1.d0 + w_r)*du_l - w_r*du_r
         du(1,2) = w_l*du_l + w_r*du_r
         do i = 3, n-1
            dx_l = dx_r
            du_l  = du_r
            dx_r = x(i+1) - x(i)
            du_r  = (u(1,i+1) - u(1,i))/dx_r
            w_l  = dx_r/(dx_l + dx_r)
            w_r = 1.d0 - w_l
            du(1,i) = w_l*du_l + w_r*du_r
         enddo
         du(1,n) = (1.d0 + w_l)*du_r - w_l*du_l

      endif

      end

      subroutine coef_bicubic(u, p, q, r, x, y, nx, ny, C)
*
*     PURPOSE
*        compute for each polynomial (i,j)-patch (defined on
*        [x(i),x(i+1)]x[y(i),y(i+1)]) the following base
*        representation :
*           i,j        _4_  _4_   i,j       k-1       l-1
*          u   (x,y) = >__  >__  C   (x-x(i))  (y-y(j))
*                      k=1  l=1   k,l
*
*        from the "Hermite" representation (values of u, p = du/dx,
*        q = du/dy, r = ddu/dxdy at the 4 vertices (x(i),y(j)),
*        (x(i+1),y(j)), (x(i+1),y(j+1)), (x(i),y(j+1)).
*
      implicit none

      integer nx, ny
      double precision u(nx, ny), p(nx, ny), q(nx, ny), r(nx, ny),
     $                 x(nx), y(ny), C(4,4,nx-1,ny-1)

      integer i, j
      double precision a, b, cc, d, dx, dy

      do j = 1, ny-1
         dy = 1.d0/(y(j+1) - y(j))

         do i = 1, nx-1
            dx = 1.d0/(x(i+1) - x(i))

            C(1,1,i,j) = u(i,j)
            C(2,1,i,j) = p(i,j)
            C(1,2,i,j) = q(i,j)
            C(2,2,i,j) = r(i,j)

            a = (u(i+1,j) - u(i,j))*dx
            C(3,1,i,j) = (3.d0*a -2.d0*p(i,j) - p(i+1,j))*dx
            C(4,1,i,j) = (p(i+1,j) + p(i,j) - 2.d0*a)*(dx*dx)

            a = (u(i,j+1) - u(i,j))*dy
            C(1,3,i,j) = (3.d0*a -2.d0*q(i,j) - q(i,j+1))*dy
            C(1,4,i,j) = (q(i,j+1) + q(i,j) - 2.d0*a)*(dy*dy)

            a = (q(i+1,j) - q(i,j))*dx
            C(3,2,i,j) = (3.d0*a - r(i+1,j) - 2.d0*r(i,j))*dx
            C(4,2,i,j) = (r(i+1,j) + r(i,j) - 2.d0*a)*(dx*dx)

            a = (p(i,j+1) - p(i,j))*dy
            C(2,3,i,j) = (3.d0*a - r(i,j+1) - 2.d0*r(i,j))*dy
            C(2,4,i,j) = (r(i,j+1) + r(i,j) - 2.d0*a)*(dy*dy)

            a = (u(i+1,j+1)+u(i,j)-u(i+1,j)-u(i,j+1))*(dx*dx*dy*dy)
     $          - (p(i,j+1)-p(i,j))*(dx*dy*dy)
     $          - (q(i+1,j)-q(i,j))*(dx*dx*dy)
     $          + r(i,j)*(dx*dy)
            b = (p(i+1,j+1)+p(i,j)-p(i+1,j)-p(i,j+1))*(dx*dy*dy)
     $          - (r(i+1,j)-r(i,j))*(dx*dy)
            cc = (q(i+1,j+1)+q(i,j)-q(i+1,j)-q(i,j+1))*(dx*dx*dy)
     $          - (r(i,j+1)-r(i,j))*(dx*dy)
            d = (r(i+1,j+1)+r(i,j)-r(i+1,j)-r(i,j+1))*(dx*dy)

            C(3,3,i,j) =  9.d0*a - 3.d0*b - 3.d0*cc + d
            C(3,4,i,j) =(-6.d0*a + 2.d0*b + 3.d0*cc - d)*dy
            C(4,3,i,j) =(-6.d0*a + 3.d0*b + 2.d0*cc - d)*dx
            C(4,4,i,j) =( 4.d0*a - 2.d0*b - 2.d0*cc + d)*dx*dy

         enddo
      enddo
      end

      double precision function EvalBicubic(xx, yy, xk, yk, Ck)

      implicit none
      double precision xx, yy, xk, yk, Ck(4,4)

      double precision dx, dy, u
      integer i

      dx = xx - xk
      dy = yy - yk

      u = 0.d0
      do i = 4, 1, -1
         u = Ck(i,1) + dy*(Ck(i,2) + dy*(Ck(i,3) + dy*Ck(i,4))) + u*dx
      enddo
      EvalBicubic = u

      end ! function EvalBicubic

      subroutine EvalBicubic_with_grad(xx, yy, xk, yk, Ck,
     $                                 u, dudx, dudy)

      implicit none
      double precision xx, yy, xk, yk, Ck(4,4), u, dudx, dudy

      double precision dx, dy
      integer i

      dx = xx - xk
      dy = yy - yk
      u = 0.d0
      dudx = 0.d0
      dudy = 0.d0
      do i = 4, 1, -1
         u = Ck(i,1) + dy*(Ck(i,2) + dy*(Ck(i,3) + dy*Ck(i,4))) + u*dx
         dudx = Ck(2,i)+dx*(2.d0*Ck(3,i) + dx*3.d0*Ck(4,i)) + dudx*dy
         dudy = Ck(i,2)+dy*(2.d0*Ck(i,3) + dy*3.d0*Ck(i,4)) + dudy*dx
      enddo

      end ! subroutine EvalBicubic_with_grad

      subroutine EvalBicubic_with_grad_and_hes(xx, yy, xk, yk, Ck,
     $                                         u, dudx, dudy,
     $                                         d2udx2, d2udxy, d2udy2)

      implicit none
      double precision xx, yy, xk, yk, Ck(4,4), u, dudx, dudy, d2udx2,
     $                 d2udxy, d2udy2

      double precision dx, dy
      integer i

      dx = xx - xk
      dy = yy - yk
      u = 0.d0
      dudx = 0.d0
      dudy = 0.d0
      d2udx2 = 0.d0
      d2udy2 = 0.d0
      d2udxy = 0.d0
      do i = 4, 1, -1
         u = Ck(i,1) + dy*(Ck(i,2) + dy*(Ck(i,3) + dy*Ck(i,4))) + u*dx
         dudx = Ck(2,i)+dx*(2.d0*Ck(3,i) + dx*3.d0*Ck(4,i)) + dudx*dy
         dudy = Ck(i,2)+dy*(2.d0*Ck(i,3) + dy*3.d0*Ck(i,4)) + dudy*dx
         d2udx2 = 2.d0*Ck(3,i) + dx*6.d0*Ck(4,i) + d2udx2*dy
         d2udy2 = 2.d0*Ck(i,3) + dy*6.d0*Ck(i,4) + d2udy2*dx
      enddo
      d2udxy =            Ck(2,2)+dy*(2.d0*Ck(2,3)+dy*3.d0*Ck(2,4))
     .        + dx*(2.d0*(Ck(3,2)+dy*(2.d0*Ck(3,3)+dy*3.d0*Ck(3,4)))
     .        + dx*(3.d0*(Ck(4,2)+dy*(2.d0*Ck(4,3)+dy*3.d0*Ck(4,4)))))
      end ! subroutine EvalBicubic_with_grad_and_hes

      subroutine BiCubicInterp(x, y, C, nx, ny, x_eval, y_eval, z_eval,
     $                         m, outmode)
*
*     PURPOSE
*        bicubic interpolation :
*          the grid is defined by x(1..nx), y(1..ny)
*          the known values are z(1..nx,1..ny), (z(i,j) being the value
*          at point (x(i),y(j)))
*          the interpolation is done on the points x_eval,y_eval(1..m)
*          z_eval(k) is the result of the bicubic interpolation of
*          (x_eval(k), y_eval(k))
*
      implicit none
      integer nx, ny, m, outmode
      double precision x(nx), y(ny), C(4,4,nx-1,ny-1),
     $                 x_eval(m), y_eval(m), z_eval(m)

      double precision xx, yy
      integer i, j, k
      include 'constinterp.h'
      integer  isanan
      double precision return_a_nan, EvalBicubic
      external isanan, return_a_nan, EvalBicubic

      i = 0
      j = 0
      do k = 1, m
         xx = x_eval(k)
         call fast_int_search(xx, x, nx, i)
         yy = y_eval(k)
         call fast_int_search(yy, y, ny, j)

         if (i .ne. 0  .and.  j .ne. 0) then
            z_eval(k) = EvalBicubic(xx, yy, x(i), y(j), C(1,1,i,j))

         elseif (outmode .eq. BY_NAN  .or.  isanan(xx) .eq. 1
     $                                .or.  isanan(yy) .eq. 1) then
            z_eval(k) = return_a_nan()

         elseif (outmode .eq. BY_ZERO) then
            z_eval(k) = 0.d0

         elseif (outmode .eq. PERIODIC) then
            if (i .eq. 0) call coord_by_periodicity(xx, x, nx, i)
            if (j .eq. 0) call coord_by_periodicity(yy, y, ny, j)
            z_eval(k) = EvalBicubic(xx, yy, x(i), y(j), C(1,1,i,j))

         elseif (outmode .eq. C0) then
            if (i .eq. 0) call near_grid_point(xx, x, nx, i)
            if (j .eq. 0) call near_grid_point(yy, y, ny, j)
            z_eval(k) = EvalBicubic(xx, yy, x(i), y(j), C(1,1,i,j))

         elseif (outmode .eq. NATURAL) then
            if (i .eq. 0) call near_interval(xx, x, nx, i)
            if (j .eq. 0) call near_interval(yy, y, ny, j)
            z_eval(k) = EvalBicubic(xx, yy, x(i), y(j), C(1,1,i,j))
         endif

      enddo

      end

      subroutine BiCubicInterpWithGrad(x, y, C, nx, ny, x_eval, y_eval,
     $                                 z_eval, dzdx_eval, dzdy_eval,m,
     $                                 outmode)
*
*     PURPOSE
*        bicubic interpolation :
*          the grid is defined by x(1..nx), y(1..ny)
*          the known values are z(1..nx,1..ny), (z(i,j) being the value
*          at point (x(i),y(j)))
*          the interpolation is done on the points x_eval,y_eval(1..m)
*          z_eval(k) is the result of the bicubic interpolation of
*          (x_eval(k), y_eval(k)) and dzdx_eval(k), dzdy_eval(k) is the gradient
*
      implicit none
      integer nx, ny, m, outmode
      double precision x(nx), y(ny), C(4,4,nx-1,ny-1),
     $                 x_eval(m), y_eval(m), z_eval(m),
     $                 dzdx_eval(m), dzdy_eval(m)

      double precision xx, yy
      integer k, i, j
      include 'constinterp.h'
      integer  isanan
      double precision return_a_nan, EvalBicubic
      external isanan, return_a_nan, EvalBicubic
      logical change_dzdx, change_dzdy

      i = 0
      j = 0
      do k = 1, m
         xx = x_eval(k)
         call fast_int_search(xx, x, nx, i)
         yy = y_eval(k)
         call fast_int_search(yy, y, ny, j)

         if (i .ne. 0  .and.  j .ne. 0) then
            call Evalbicubic_with_grad(xx, yy, x(i), y(j), C(1,1,i,j),
     $                                 z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k))

         elseif ( outmode .eq. BY_NAN  .or.  isanan(xx) .eq. 1
     $                                 .or.  isanan(yy) .eq. 1) then
            z_eval(k) = return_a_nan()
            dzdx_eval(k) = z_eval(k)
            dzdy_eval(k) = z_eval(k)

         elseif (outmode .eq. BY_ZERO ) then
            z_eval(k) = 0.d0
            dzdx_eval(k) = 0.d0
            dzdy_eval(k) = 0.d0

         elseif (outmode .eq. PERIODIC) then
            if (i .eq. 0) call coord_by_periodicity(xx, x, nx, i)
            if (j .eq. 0) call coord_by_periodicity(yy, y, ny, j)
            call Evalbicubic_with_grad(xx, yy, x(i), y(j), C(1,1,i,j),
     $                                 z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k))

         elseif (outmode .eq. C0) then
            if (i .eq. 0) then
               call near_grid_point(xx, x, nx, i)
               change_dzdx = .true.
            else
               change_dzdx = .false.
            endif
            if (j .eq. 0) then
               call near_grid_point(yy, y, ny, j)
               change_dzdy = .true.
            else
               change_dzdy = .false.
            endif
            call Evalbicubic_with_grad(xx, yy, x(i), y(j), C(1,1,i,j),
     $                                 z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k))
            if (change_dzdx) dzdx_eval(k) = 0.d0
            if (change_dzdy) dzdy_eval(k) = 0.d0

         elseif (outmode .eq. NATURAL) then
            if (i .eq. 0) call near_interval(xx, x, nx, i)
            if (j .eq. 0) call near_interval(yy, y, ny, j)
            call Evalbicubic_with_grad(xx, yy, x(i), y(j), C(1,1,i,j),
     $                                 z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k))

         endif

      enddo

      end

      subroutine BiCubicInterpWithGradAndHes(x, y, C, nx, ny,
     $                                       x_eval, y_eval, z_eval,
     $                                         dzdx_eval, dzdy_eval,
     $                        d2zdx2_eval, d2zdxy_eval, d2zdy2_eval,
     $                                                    m, outmode)
*
*     PURPOSE
*        bicubic interpolation :
*          the grid is defined by x(1..nx), y(1..ny)
*          the known values are z(1..nx,1..ny), (z(i,j) being the value
*          at point (x(i),y(j)))
*          the interpolation is done on the points x_eval,y_eval(1..m)
*          z_eval(k) is the result of the bicubic interpolation of
*          (x_eval(k), y_eval(k)), [dzdx_eval(k), dzdy_eval(k)] is the gradient
*          and [d2zdx2(k), d2zdxy(k), d2zdy2(k)] the Hessean
*
      implicit none
      integer nx, ny, m, outmode
      double precision x(nx), y(ny), C(4,4,nx-1,ny-1),
     $                 x_eval(m), y_eval(m), z_eval(m), dzdx_eval(m),
     $   dzdy_eval(m), d2zdx2_eval(m), d2zdxy_eval(m), d2zdy2_eval(m)

      double precision xx, yy
      integer k, i, j
      include 'constinterp.h'
      integer  isanan
      double precision return_a_nan, EvalBicubic
      external isanan, return_a_nan, EvalBicubic
      logical change_dzdx, change_dzdy

      i = 0
      j = 0
      do k = 1, m
         xx = x_eval(k)
         call fast_int_search(xx, x, nx, i)
         yy = y_eval(k)
         call fast_int_search(yy, y, ny, j)

         if (i .ne. 0  .and.  j .ne. 0) then
            call Evalbicubic_with_grad_and_hes(xx, yy, x(i), y(j),
     $                                      C(1,1,i,j), z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k),
     $             d2zdx2_eval(k), d2zdxy_eval(k), d2zdy2_eval(k))

         elseif ( outmode .eq. BY_NAN  .or.  isanan(xx) .eq. 1
     $                                 .or.  isanan(yy) .eq. 1) then
            z_eval(k) = return_a_nan()
            dzdx_eval(k) = z_eval(k)
            dzdy_eval(k) = z_eval(k)
            d2zdx2_eval(k) = z_eval(k)
            d2zdxy_eval(k) = z_eval(k)
            d2zdy2_eval(k) = z_eval(k)

         elseif (outmode .eq. BY_ZERO ) then
            z_eval(k) = 0.d0
            dzdx_eval(k) = 0.d0
            dzdy_eval(k) = 0.d0
            d2zdx2_eval(k) = 0.d0
            d2zdxy_eval(k) = 0.d0
            d2zdy2_eval(k) = 0.d0

         elseif (outmode .eq. PERIODIC) then
            if (i .eq. 0) call coord_by_periodicity(xx, x, nx, i)
            if (j .eq. 0) call coord_by_periodicity(yy, y, ny, j)
            call Evalbicubic_with_grad_and_hes(xx, yy, x(i), y(j),
     $                                      C(1,1,i,j), z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k),
     $             d2zdx2_eval(k), d2zdxy_eval(k), d2zdy2_eval(k))

         elseif (outmode .eq. C0) then
            if (i .eq. 0) then
               call near_grid_point(xx, x, nx, i)
               change_dzdx = .true.
            else
               change_dzdx = .false.
            endif
            if (j .eq. 0) then
               call near_grid_point(yy, y, ny, j)
               change_dzdy = .true.
            else
               change_dzdy = .false.
            endif
            call Evalbicubic_with_grad_and_hes(xx, yy, x(i), y(j),
     $                                      C(1,1,i,j), z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k),
     $             d2zdx2_eval(k), d2zdxy_eval(k), d2zdy2_eval(k))
            if (change_dzdx) then
               dzdx_eval(k) = 0.d0
               d2zdx2_eval(k) = 0.d0
               d2zdxy_eval(k) = 0.d0
            endif
            if (change_dzdy) then
               dzdy_eval(k) = 0.d0
               d2zdxy_eval(k) = 0.d0
               d2zdy2_eval(k) = 0.d0
            endif

         elseif (outmode .eq. NATURAL) then
            if (i .eq. 0) call near_interval(xx, x, nx, i)
            if (j .eq. 0) call near_interval(yy, y, ny, j)
            call Evalbicubic_with_grad_and_hes(xx, yy, x(i), y(j),
     $                                      C(1,1,i,j), z_eval(k),
     $                                 dzdx_eval(k), dzdy_eval(k),
     $             d2zdx2_eval(k), d2zdxy_eval(k), d2zdy2_eval(k))
         endif

      enddo

      end

      subroutine driverdb3val(xp, yp, zp, fp, np, tx, ty, tz,
     $                        nx, ny, nz, kx, ky, kz, bcoef, work,
     $                        xmin, xmax, ymin, ymax, zmin, zmax,
     $                        outmode)
*
*     PURPOSE
*        driver on to db3val
*
      implicit none
      integer np, nx, ny, nz, kx, ky, kz, outmode
      double precision xp(np), yp(np), zp(np), fp(np),
     $                 tx(*), ty(*), tz(*), bcoef(*), work(*),
     $                 xmin, xmax, ymin, ymax, zmin, zmax

      integer k
      logical flag_x, flag_y, flag_z
      double precision x, y, z
      include 'constinterp.h'
      integer  isanan
      double precision return_a_nan, db3val
      external isanan, return_a_nan, db3val

      do k = 1, np
         x = xp(k)
         if ( xmin .le. x .and. x .le. xmax ) then
            flag_x = .true.
         else
            flag_x = .false.
         endif
         y = yp(k)
         if ( ymin .le. y .and. y .le. ymax ) then
            flag_y = .true.
         else
            flag_y = .false.
         endif
         z = zp(k)
         if ( zmin .le. z .and. z .le. zmax ) then
            flag_z = .true.
         else
            flag_z = .false.
         endif

         if ( flag_x .and. flag_y .and. flag_z ) then
            fp(k) = db3val(x, y, z, 0, 0, 0, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)

         elseif (outmode .eq. BY_NAN  .or.  isanan(x) .eq. 1
     $                                .or.  isanan(y) .eq. 1
     $                                .or.  isanan(z) .eq. 1) then
            fp(k) = return_a_nan()

         elseif (outmode .eq. BY_ZERO) then
            fp(k) = 0.d0

         else
            if (outmode .eq. PERIODIC) then
               if (.not. flag_x) call proj_by_per(x, xmin, xmax)
               if (.not. flag_y) call proj_by_per(y, ymin, ymax)
               if (.not. flag_z) call proj_by_per(z, zmin, zmax)
            elseif (outmode .eq. C0) then
               if (.not. flag_x) call proj_on_grid(x, xmin, xmax)
               if (.not. flag_y) call proj_on_grid(y, ymin, ymax)
               if (.not. flag_z) call proj_on_grid(z, zmin, zmax)
            endif
            fp(k) = db3val(x, y, z, 0, 0, 0, tx, ty, tz, nx, ny, nz,
     $                     kx, ky, kz, bcoef, work)
         endif
      enddo

      end

      subroutine driverdb3valwithgrad(xp, yp, zp, fp,
     $                        dfpdx, dfpdy, dfpdz, np, tx, ty, tz,
     $                        nx, ny, nz, kx, ky, kz, bcoef, work,
     $                        xmin, xmax, ymin, ymax, zmin, zmax,
     $                        outmode)
*
*     PURPOSE
*        driver on to db3val with gradient computing
*
      implicit none
      integer np, nx, ny, nz, kx, ky, kz, outmode
      double precision xp(np), yp(np), zp(np), fp(np),
     $                 dfpdx(np), dfpdy(np), dfpdz(np),
     $                 tx(*), ty(*), tz(*), bcoef(*), work(*),
     $                 xmin, xmax, ymin, ymax, zmin, zmax

      integer k
      logical flag_x, flag_y, flag_z
      double precision x, y, z
      include 'constinterp.h'
      integer  isanan
      double precision return_a_nan, db3val
      external isanan, return_a_nan, db3val

      do k = 1, np
         x = xp(k)
         if ( xmin .le. x .and. x .le. xmax ) then
            flag_x = .true.
         else
            flag_x = .false.
         endif
         y = yp(k)
         if ( ymin .le. y .and. y .le. ymax ) then
            flag_y = .true.
         else
            flag_y = .false.
         endif
         z = zp(k)
         if ( zmin .le. z .and. z .le. zmax ) then
            flag_z = .true.
         else
            flag_z = .false.
         endif

         if ( flag_x .and. flag_y .and. flag_z ) then
            fp(k) = db3val(x, y, z, 0, 0, 0, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)
            dfpdx(k) = db3val(x, y, z, 1, 0, 0, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)
            dfpdy(k) = db3val(x, y, z, 0, 1, 0, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)
            dfpdz(k) = db3val(x, y, z, 0, 0, 1, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)

         elseif (outmode .eq. BY_NAN  .or.  isanan(x) .eq. 1
     $                                .or.  isanan(y) .eq. 1
     $                                .or.  isanan(z) .eq. 1) then
            fp(k) = return_a_nan()
            dfpdx(k) = fp(k)
            dfpdy(k) = fp(k)
            dfpdz(k) = fp(k)

         elseif (outmode .eq. BY_ZERO) then
            fp(k) = 0.d0
            dfpdx(k) = 0.d0
            dfpdy(k) = 0.d0
            dfpdz(k) = 0.d0

         elseif (outmode .eq. PERIODIC) then
            if (.not. flag_x) call proj_by_per(x, xmin, xmax)
            if (.not. flag_y) call proj_by_per(y, ymin, ymax)
            if (.not. flag_z) call proj_by_per(z, zmin, zmax)
            fp(k) = db3val(x, y, z, 0, 0, 0, tx, ty, tz, nx, ny, nz,
     $                     kx, ky, kz, bcoef, work)
            dfpdx(k) = db3val(x, y, z, 1, 0, 0, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)
            dfpdy(k) = db3val(x, y, z, 0, 1, 0, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)
            dfpdz(k) = db3val(x, y, z, 0, 0, 1, tx, ty, tz,
     $                     nx, ny, nz, kx, ky, kz, bcoef, work)

         elseif (outmode .eq. C0) then
            if (.not. flag_x) call proj_on_grid(x, xmin, xmax)
            if (.not. flag_y) call proj_on_grid(y, ymin, ymax)
            if (.not. flag_z) call proj_on_grid(z, zmin, zmax)
            fp(k) = db3val(x, y, z, 0, 0, 0, tx, ty, tz, nx, ny, nz,
     $                     kx, ky, kz, bcoef, work)
            if ( flag_x ) then
               dfpdx(k) = 0.d0
            else
               dfpdx(k) = db3val(x, y, z, 1, 0, 0, tx, ty, tz,
     $                           nx, ny, nz, kx, ky, kz, bcoef, work)
            endif
            if ( flag_y ) then
               dfpdy(k) = 0.d0
            else
               dfpdy(k) = db3val(x, y, z, 0, 1, 0, tx, ty, tz,
     $                           nx, ny, nz, kx, ky, kz, bcoef, work)
            endif
            if ( flag_z ) then
               dfpdz(k) = 0.d0
            else
               dfpdz(k) = db3val(x, y, z, 0, 0, 1, tx, ty, tz,
     $                           nx, ny, nz, kx, ky, kz, bcoef, work)
            endif

         endif
      enddo

      end


      SUBROUTINE BMGTNS(CSTM,NCSTM,ECPT,TA)
C/// THIS ROUTINE WAS LIFTED FROM PRETRD AND TRANSD AND CONVERTED
C///// TO HAVE ONE ENTRY POINT
C
C PRETRD SETS UP EVENTUAL CALLS TO TRANSD.  FOR A MODULE TO USE TRANSD
C A CALL TO PRETRD MUST BE INITIATED BY THE MODULE DRIVER ONCE AND ONLY
C ONCE.  CSTM IS ARRAY OF COORDINATE SYSTEM TRANSFORMATION MATRICES
C AND NCSTM IS THE LENGTH OF THIS ARRAY.
C
      DIMENSION          CSTM(1)
C*****
C GIVEN THE ECPT ARRAY OF LENGTH 4, THE FIRST WORD BEING AN INTEGER
C COORDINATE SYSTEM IDENTIFICATION NUMBER AND THE NEXT WORDS BEING THE
C REAL COORDINATES OF A POINT IN BASIC COORDINATES, THIS ROUTINE
C COMPUTES THE TRANSFORMATION (DIRECTION COSINE) MATRIX TA WHICH WILL
C MAP A VECTOR FROM THE LOCAL SYSTEM LABELED ECPT(1) TO BASIC COORDI-
C NATES.  TA IS A DOUBLE PRECISION MATRIX.
C*****
      DIMENSION          ECPT(4)
C
      DOUBLE PRECISION
     1                   TA(9)              ,TL(9)
     2,                  XN(3)              ,X
     3,                  Y                  ,Z
     4,                  R                  ,KE(9)
     5,                  XL
C
      EQUIVALENCE        (FL1,INT1)         ,(FL2,INT2)
C
      FL1 = ECPT(1)
      IF(INT1.EQ.0) GO TO 13
      DO 6 I = 1,NCSTM,14
      FL2 = CSTM(I)
      IF(INT1.NE.INT2) GO TO 6
      KK = I
      FL2 = CSTM(I + 1)
      GO TO (7,10,10),INT2
    6 CONTINUE
C
C THE COORDINATE SYSTEM ID. COULD NOT BE FOUND IN THE CSTM.
C
      CALL MESAGE (-30,25,INT1)
C
C THE COORDINATE SYSTEM IS RECTANGULAR.
C
    7 DO 8 J = 1,9
      K = KK + 4 + J
    8 TA(J) = CSTM(K)
      RETURN
   10 XN(1) = ECPT(2) - CSTM(KK+2)
      XN(2) = ECPT(3) - CSTM(KK+3)
      XN(3) = ECPT(4) - CSTM(KK + 4)
      X = CSTM(KK+5)*XN(1)+CSTM(KK+8)*XN(2)+CSTM(KK+11)*XN(3)
      Y = CSTM(KK+6)*XN(1)+CSTM(KK+9)*XN(2)+CSTM(KK+12)*XN(3)
      Z = CSTM(KK+7)*XN(1)+CSTM(KK+10)*XN(2)+CSTM(KK+13)*XN(3)
      R = DSQRT(X**2+Y**2)
      IF (R .EQ. 0.0D0) GO TO 7
      DO 110 J=1,9
      K=KK+4+J
  110 KE(J)=CSTM(K)
      GO TO (11,11,12),INT2
C
C THE COORDINATE SYSTEM IS CYLINDRICAL.
C
   11 TL(1)=X/R
      TL(2)=-Y/R
      TL(3)=0.0D0
      TL(4)=-TL(2)
      TL(5)=TL(1)
      TL(6)=0.0D0
      TL(7)=0.0D0
      TL(8)=0.0D0
      TL(9)=1.0D0
      GO TO 125
C
C THE COORDINATE SYSTEM IS SPHERICAL.
C
   12 XL=DSQRT(X*X+Y*Y+Z*Z)
      TL(1)=X/XL
      TL(2)=(X*Z)/(R*XL)
      TL(3)=-Y/R
      TL(4)=Y/XL
      TL(5)=(Y*Z)/(R*XL)
      TL(6)=X/R
      TL(7)=Z/XL
      TL(8)=-R/XL
      TL(9)=0.0D0
  125 CALL GMMATD (KE(1),3,3,0, TL(1),3,3,0, TA(1))
      RETURN
C
C THE LOCAL SYSTEM IS BASIC.
C
   13 DO 14 I=1,9
   14 TA(I)=0.0D0
      TA(1)=1.0D0
      TA(5)=1.0D0
      TA(9)=1.0D0
      RETURN
      END