! *************************************************************************************
! Tabulates cooling and UV heating rates.
!
!     Units are CGS, temperature is in K
!
!     Two sets of rates, as in:
!      1) Katz, Weinberg & Hernquist, 1996: Astrophysical Journal Supplement v. 105, p.19
!      2) Lukic et al. 2015: Monthly Notices of the Royal Astronomical Society, v. 446, p.3697
!
!     NOTE: This is executed only once per run, and rates are ugly, thus
!           execution efficiency is not important, but readability of
!           the code is. -- Zarija
!
! *************************************************************************************

module atomic_rates_module

  use amrex_fort_module, only : rt => amrex_real

  implicit none

  ! Routine which acts like a class constructor
  public  :: tabulate_rates, interp_to_this_z

  ! Photo- rates (from file)
  integer   , parameter          , private :: NCOOLFILE=301
  real(rt), dimension(NCOOLFILE), public :: lzr
  real(rt), dimension(NCOOLFILE), public :: rggh0, rgghe0, rgghep
  real(rt), dimension(NCOOLFILE), public :: reh0, rehe0, rehep

  ! Other rates (from equations)
  integer, parameter, public :: NCOOLTAB=2000
  real(rt), dimension(NCOOLTAB+1), public :: AlphaHp, AlphaHep, AlphaHepp, Alphad
  real(rt), dimension(NCOOLTAB+1), public :: GammaeH0, GammaeHe0, GammaeHep
  real(rt), dimension(NCOOLTAB+1), public :: BetaH0, BetaHe0, BetaHep, Betaff1, Betaff4
  real(rt), dimension(NCOOLTAB+1), public :: RecHp, RecHep, RecHepp

  real(rt), public, save :: this_z, ggh0, gghe0, gghep, eh0, ehe0, ehep

  real(rt), parameter, public :: TCOOLMIN = 0.0d0, TCOOLMAX = 9.0d0  ! in log10
  real(rt), parameter, public :: deltaT = (TCOOLMAX - TCOOLMIN)/NCOOLTAB

  real(rt), parameter, public :: MPROTON = 1.6726231d-24, BOLTZMANN = 1.3806e-16

  ! Note that XHYDROGEN can be set by a call to set_xhydrogen which now
  ! lives in set_method_params.
  real(rt), public :: XHYDROGEN = 0.76d0
  real(rt), public :: YHELIUM   = 7.8947368421d-2  ! (1.0d0-XHYDROGEN)/(4.0d0*XHYDROGEN)

  contains

      subroutine tabulate_rates()
      integer :: i
      logical, parameter :: Katz96=.false.
      real(rt), parameter :: t3=1.0d3, t5=1.0d5, t6=1.0d6
      real(rt) :: t, U, E, y, sqrt_t, corr_term
      logical, save :: first=.true.

      !$OMP CRITICAL(TREECOOL_READ)
      if (first) then

         first = .false.

         ! Read in photoionization rates and heating from a file
         open(unit=11,file='TREECOOL_middle',status='old')
         do i = 1, NCOOLFILE
            read(11,*) lzr(i), rggh0(i), rgghe0(i), rgghep(i), &
                                reh0(i),  rehe0(i),  rehep(i)
         end do
         close(11)

         ! Initialize cooling tables
         t = 10.0d0**TCOOLMIN
         if (Katz96) then
            do i = 1, NCOOLTAB+1
               ! Rates are as in Katz et al. 1996
               sqrt_t = dsqrt(t)
               corr_term    = 1.d0 / (1.0d0 + sqrt_t/dsqrt(t5))

               ! Recombination rates
               ! Alphad: dielectronic recombination rate of singly ioniozed helium
               Alphad(i)    = 1.90d-03/(t*sqrt_t) * dexp(-4.7d5/t) * (1.0d0+0.3d0*dexp(-9.4d4/t))
               AlphaHp(i)   = 8.40d-11/sqrt_t * (t/t3)**(-0.2d0) / (1.0d0 + (t/t6)**0.7d0)
               AlphaHep(i)  = 1.50d-10 * t**(-0.6353d0)
               AlphaHepp(i) = 3.36d-10/sqrt_t * (t/t3)**(-0.2d0) / (1.0d0 + (t/t6)**0.7d0)

               ! Collisional ionization rates
               GammaeH0(i)  = 5.85d-11*sqrt_t * dexp(-157809.1d0/t) * corr_term
               GammaeHe0(i) = 2.38d-11*sqrt_t * dexp(-285335.4d0/t) * corr_term
               GammaeHep(i) = 5.68d-12*sqrt_t * dexp(-631515.0d0/t) * corr_term

               ! Collisional ionization & excitation cooling rates
               BetaH0(i)  = 7.5d-19 * dexp(-118348.0d0/t) * corr_term + 2.171d-11*GammaeH0(i)
               BetaHe0(i) = 3.941d-11 * GammaeHe0(i)
               BetaHep(i) = 5.54d-17 * t**(-0.397d0) * dexp(-473638.0d0/t) * corr_term + &
                            8.715d-11 * GammaeHep(i)

               ! Recombination cooling rates
               RecHp(i)   = 1.036d-16 * t * AlphaHp(i)
               RecHep(i)  = 1.036d-16 * t * AlphaHep(i) + 6.526d-11 * Alphad(i)
               RecHepp(i) = 1.036d-16 * t * AlphaHepp(i)

               ! Free-free cooling rate
               Betaff1(i) = 1.42d-27 * sqrt_t * (1.1d0 + 0.34d0*dexp(-(5.5d0 - dlog10(t))**2 / 3.0d0))
               Betaff4(i) = Betaff1(i)

               t = t*10.0d0**deltaT
            enddo
         else
            do i = 1, NCOOLTAB+1
               ! Rates are as in Lukic et al.
               sqrt_t = dsqrt(t)

               ! Recombination rates
               ! Alphad: dielectronic recombination rate of singly ioniozed helium
               Alphad(i)    = 1.90d-03/(t*sqrt_t) * dexp(-4.7d5/t) * (1.0d0+0.3d0*dexp(-9.4d4/t))
               AlphaHp(i)   = 7.982d-11 / (dsqrt(t/3.148d0)* (1.0d0+dsqrt(t/3.148d0))**0.252 * &
                                           (1.0d0+dsqrt(t/7.036d5))**1.748)
               if (t .le. 1.0d6) then
                  AlphaHep(i)  = 3.294d-11 / (dsqrt(t/15.54d0)* (1.0d0+dsqrt(t/15.54d0))**0.309 * &
                                              (1.0d0+dsqrt(t/3.676d7))**1.691)
               else
                  AlphaHep(i)  = 9.356d-10 / (dsqrt(t/4.266d-2)* (1.0d0+dsqrt(t/4.266d-2))**0.2108 * &
                                              (1.0d0+dsqrt(t/4.677d6))**1.7892)
               endif
               AlphaHepp(i) = 1.891d-10 / (dsqrt(t/9.37d0)* (1.0d0+dsqrt(t/9.37d0))**0.2476 * &
                                           (1.0d0+dsqrt(t/2.774d6))**1.7524)

               ! Collisional ionization rates
               E = 13.6d0
               U = 1.16045d4*E/t
               GammaeH0(i)  = 2.91d-8*U**0.39*dexp(-U) / (0.232d0+U)
               E = 24.6d0
               U = 1.16045d4*E/t
               GammaeHe0(i) = 1.75d-8*U**0.35*dexp(-U) / (0.18d0+U)
               E = 54.4d0
               U = 1.16045d4*E/t
               GammaeHep(i) = 2.05d-9*(1.0d0+dsqrt(U))*U**0.25*dexp(-U) / (0.265d0+U)

               ! Collisional ionization & excitation cooling rates
               corr_term = 1.d0 / (1.0d0 + sqrt_t/dsqrt(5.0d7))
               y = dlog(t)
               if (t .le. 1.0d5) then
                  BetaH0(i)  = 1.0d-20 * dexp( 2.137913d2 - 1.139492d2*y + 2.506062d1*y**2 - &
                                               2.762755d0*y**3 + 1.515352d-1*y**4 - &
                                               3.290382d-3*y**5 - 1.18415d5/t )
               else
                  BetaH0(i)  = 1.0d-20 * dexp( 2.7125446d2 - 9.8019455d1*y + 1.400728d1*y**2 - &
                                               9.780842d-1*y**3 + 3.356289d-2*y**4 - &
                                               4.553323d-4*y**5 - 1.18415d5/t )
               endif
               BetaHe0(i) = 9.38d-22 * sqrt_t * dexp(-285335.4d0/t) * corr_term
               BetaHep(i) = (5.54d-17 * t**(-0.397d0) * dexp(-473638.0d0/t) + &
                             4.85d-22 * sqrt_t * dexp(-631515.0d0/t) )*corr_term

               ! Recombination cooling rates
               RecHp(i)   = 2.851d-27 * sqrt_t * (5.914d0-0.5d0*dlog(t)+1.184d-2*t**(1.0d0/3.0d0))
               RecHep(i)  = 1.55d-26 * t**0.3647 + 1.24d-13/(t*sqrt_t) * dexp(-4.7d5/t) * &
                                                                         (1.0d0+0.3d0*dexp(-9.4d4/t))
               RecHepp(i) = 1.14d-26 * sqrt_t * (6.607d0-0.5d0*dlog(t)+7.459d-3*t**(1.0d0/3.0d0))

               ! Free-free cooling rate
               if (t .le. 3.2d5) then
                  Betaff1(i) = 1.426d-27 * sqrt_t * (0.79464d0 + 0.1243d0*dlog10(t))
               else
                  Betaff1(i) = 1.426d-27 * sqrt_t * (2.13164d0 - 0.1240d0*dlog10(t))
               endif

               if (t/4.0d0 .le. 3.2d5) then
                  Betaff4(i) = 1.426d-27 * sqrt_t * 4.0d0*(0.79464d0 + 0.1243d0*dlog10(t))
               else
                  Betaff4(i) = 1.426d-27 * sqrt_t * 4.0d0*(2.13164d0 - 0.1240d0*dlog10(t))
               endif

               t = t*10.0d0**deltaT
            enddo
         endif  ! Katz rates

      end if  ! first_call
      !$OMP END CRITICAL(TREECOOL_READ)

      end subroutine tabulate_rates

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

      subroutine interp_to_this_z(z)

      real(rt), intent(in) :: z
      real(rt) :: lopz, fact
      integer :: i, j

      this_z = z
      lopz   = dlog10(1.0d0 + z)

      if (lopz .ge. lzr(NCOOLFILE)) then
         ggh0  = 0.0d0
         gghe0 = 0.0d0
         gghep = 0.0d0
         eh0   = 0.0d0
         ehe0  = 0.0d0
         ehep  = 0.0d0
         return
      endif

      if (lopz .le. lzr(1)) then
         j = 1
      else
         do i = 2, NCOOLFILE
            if (lopz .lt. lzr(i)) then
               j = i-1
               exit
            endif
         enddo
      endif

      fact  = (lopz-lzr(j))/(lzr(j+1)-lzr(j))

      ggh0  = rggh0(j)  + (rggh0(j+1)-rggh0(j))*fact
      gghe0 = rgghe0(j) + (rgghe0(j+1)-rgghe0(j))*fact
      gghep = rgghep(j) + (rgghep(j+1)-rgghep(j))*fact
      eh0   = reh0(j)   + (reh0(j+1)-reh0(j))*fact
      ehe0  = rehe0(j)  + (rehe0(j+1)-rehe0(j))*fact
      ehep  = rehep(j)  + (rehep(j+1)-rehep(j))*fact

      end subroutine interp_to_this_z

end module atomic_rates_module

! *************************************************************************************
! This must live outside of atomic_rates module so it can be called by the C++
! *************************************************************************************

subroutine fort_init_this_z(comoving_a) &
    bind(C, name="fort_init_this_z")

    use amrex_fort_module, only : rt => amrex_real
    use atomic_rates_module

    implicit none

    real(rt), intent(in   ) :: comoving_a
    real(rt)                :: z

    z = 1.d0/comoving_a - 1.d0
    call interp_to_this_z(z)

end subroutine fort_init_this_z


      SUBROUTINE model_atmosphere(
     $     MAXLAY,  TEMP,    PLAY,
     $     DZ,      DVAIR,   DVO4,
     $     DVO3,    DVNO2)

      IMPLICIT NONE

!      PI
!      GRAV       acceleration due the gravity [m s-2]
!      C_LI       speed of light [m s-1]
!      H_PL       Planck constant [Js]
!      HC       = H_PL*C_LI,
!      RELN2      N2 mixing ratio
!      RELO2      O2 mixing ratio
!      RELAr      Ar mixing ratio
!      AVOGA      Avogadro constant [part. mol-1]
!      RG         molar gas constant [J K-1 mol-1]
!      TEMP_STD   standard temperature [K]
!      P_STD      standard pressure [hPa]
!      V_MOL    = RG *TEMP_STD/P_STD molar volume ideal gas [m3 mol-1]
!      RLOSCH   = AVOGA/V_MOL Loschmidt constant [part. cm-3]
!      DAIR     = RLOSCH*(P/P_STD)*(TEMP_STD/TEMP) mol.nr density air
!                 at T = 288.15 K (15 oC) [part. cm-3]
!      AIR_M    !molar mass of air [kg mol-1]
!      BOLTZ    = RG/AVOGA Boltzmann constant [J K-1]
!      WRAM
!      ZERO
!
      DOUBLE PRECISION,PARAMETER::
     $     PI       = 3.141592653589793115997963468544D0,
     $     GRAV     = 9.81D0,           ![m s-2]
     $     C_LI     = 2.99792458D+08,   ![m s-1]
     $     H_PL     = 6.62606876D-34,   ![Js]
     $     HC       = H_PL*C_LI,
     $     RELN2    = 0.7809D0,
     $     RELO2    = 0.2095D0,
     $     RELAr    = 1.D0-RELN2-RELO2, !0.0093D0
     $     AVOGA    = 6.02214199D+23 ,  ![part. mol-1]
     $     RG       = 8.314472D0,       ![J K-1 mol-1]
     $     TEMP_STD = 273.15D0,         ![K]
     $     P_STD    = 1013.25D0,        ![hPa]
     $     V_MOL    = 22.413996D-3,     ![m3 mol-1]
     $     RLOSCH   = 2.6867775D+19,    ![part. cm-3]
     $     DAIR     = 2.54743D+19,      ![part. cm-3]
     $     AIR_M    = 28.97D-3,         ![kg mol-1]
     $     BOLTZ    = 1.3806504D-23,    ![J K-1]
     $     WRAM     = 500.D0,
     $     ZERO     = 0.D0

c---- inputs ---------------------------------------------------------

      INTEGER::MAXLAY

      DOUBLE PRECISION,PARAMETER::
     $    SCALE_O3  = 347.54D0,           ! [DU] !O3 column to be scaled on
     $    SCALE_NO2 =   5.55D0 * 1.D+15  ! [molec.cm-2] !NO2 column density to be scaled on

      LOGICAL,PARAMETER:: FIX_PTRUNC = .FALSE.

      LOGICAL
     $     SCALING_O3,          !scaling of the ozone column
     $     SCALING_NO2          !scaling of the NO2 column

      DOUBLE PRECISION
     $     ZTRUNC_KM,         !surface height [km]
     $     ZTRUNC,            !surface height [m]
     $     PTRUNC             !surface pressure [hPa]

c---- outputs ---------------------------------------------------------

      DOUBLE PRECISION
     $     TEMP(MAXLAY),   !temperature at the center of the layers [K]
     $     RELHUM(MAXLAY), !relative humidity [1]
     $     RELH2O(MAXLAY), !water vapor mixing ratio
     $     PLEV(MAXLAY),   !pressure at model levels [hPa]
     $     PLAY(MAXLAY),   !pressure at the center of the layers [hPa]
     $     RELO3(MAXLAY),  !O3 volumn mixing ratio inmodel layers [1]
     $     RELNO2(MAXLAY), !NO2 volumn mixing ratio in model layers [1]
     $     ZLEV(MAXLAY),   !height of levels [m]
     $     ZLAY(MAXLAY),   !avaraged height of layers (center) [m]
     $     DZ(MAXLAY),     !height of layers [m]
     $     ZFRAC(MAXLAY),!fraction of layer not filled with mountain [1]
     $     DENSFRAC(MAXLAY) !fraction of layer not filled with mou[1]

      DOUBLE PRECISION
     $     VAIR(MAXLAY),   !air column density [part./cm^2]
     $     DVAIR(MAXLAY),  !diff. air column density [part./cm^2]
     $     VO3(MAXLAY),    !O3 column density [part./cm^2]
     $     DVO3(MAXLAY),     !diff. O3 column density [part./cm^2]
     $     VNO2(MAXLAY),     !NO2 column density [part./cm^2]
     $     DVNO2(MAXLAY),    !diff. NO2 column density [part./cm^2]
     $     DENS_O3(MAXLAY),  !averaged ozone density  [part./cm^3]
     $     DENS_NO2(MAXLAY), !averaged NO2 density  [part./cm^3]
     $     DENS_AIR(MAXLAY),  !averaged air density    [part./cm^3]
     $     DVO4(MAXLAY)!diff. O4 column density [part^2./cm^5] dens^2*dz

c---- internals -------------------------------------------------------

c     model atmosphere (AFGL or US standard)

      DOUBLE PRECISION
     $     Z_M(50),             !altitude [km]
     $     PRESS_M(50),         !pressure [hPa]
     $     TEMP_M(50),          !temperature [K]
     $     DENS_AIR_M(50),      !density of air moelcules [molec./cm^3]
     $     DENS_O3_M(50),       !density of ozone [molec./cm^3]
     $     DENS_O2_M(50),       !density of oxygen [molec./cm^3]
     $     DENS_H2O_M(50),      !density of water vapor [molec./cm^3]
     $     DENS_CO2_M(50),      !density of CO2 [molec./cm^3]
     $     DENS_NO2_M(50),      !density of NO2 [molec./cm^3]
     $     REL_O3_M(50),        !mixing ratio of ozone [1]
     $     REL_H2O_M(50),       !mixing ratio of water vapor [1]
     $     REL_NO2_M(50),       !mixing ratio of NO2 [1]
     $     RELHUM_M(50)         !relative humidity [1]

c     dummy variables
      DOUBLE PRECISION
     $     TEMP_D(MAXLAY),
     $     PSAT,
     $     TE,
     $     DENS_SAT,
     $     PSP,
     $     CONSTANT,
     $     FACTOR,
     $     DZ_LAY,
     $     TEMP_LAY,
     $     X1,X2,X3,X4,X5,X6,X7,X8,X9

      INTEGER
     $     K,KTRUNC

c     spline variables

      DOUBLE PRECISION,PARAMETER::RNR = 1.D32 !needed for natural spline
      DOUBLE PRECISION
     $     PLOG_M(50),
     $     PLOG_LAY(MAXLAY),
     $     DUM3(50)

      CHARACTER
     $     ZFILENAME*3

c-----------------------------------------------------------------

      ZTRUNC = 0.D0
      ZTRUNC = ZTRUNC_KM * 1.D3 ![km] -> [m]

c-----------------------------------------------------------------
c     Fix the model atmosphere here  (AFGL profiles)
c-----------------------------------------------------------------

      OPEN(13, FILE='../data/prof.AFGL.US.std',   STATUS='OLD')
c     OPEN(13, FILE='../data/prof.AFGL.trop',     STATUS='OLD')
c     OPEN(13, FILE='../data/prof.AFGL.midl.sum', STATUS='OLD')
c     OPEN(13, FILE='../data/prof.AFGL.midl.wint',STATUS='OLD')
c     OPEN(13, FILE='../data/prof.AFGL.subp.sum', STATUS='OLD')
c     OPEN(13, FILE='../data/prof.AFGL.subp.wint',STATUS='OLD')

      READ(13,*)
      READ(13,*)
      DO K=1,50
         READ(13,*)X1,X2,X3,X4,X5,X6,X7,X8,X9
         Z_M(K)         = X1
         PRESS_M(K)     = X2
         TEMP_M(K)      = X3
         DENS_AIR_M(K)  = X4
         DENS_O3_M(K)   = X5
         DENS_O2_M(K)   = X6
         DENS_H2O_M(K)  = X7
         DENS_CO2_M(K)  = X8
         DENS_NO2_M(K)  = X9
         REL_O3_M(K)    = X5/X4
         REL_H2O_M(K)   = X7/X4
         REL_NO2_M(K)   = X9/X4
      ENDDO
      CLOSE(13)

c     saturation pressure [Pa]  Ref.: Pruppacher & Klett

      DO K = 1,50
         TE         = MIN(323.D0,MAX(223.D0,TEMP_M(K)))
         PSAT       =   6.982616467D+5
     $              -   1.888612677D+4 * TE
     $              +   2.132971127D+2 * TE**2
     $              -   1.288405237D+0 * TE**3
     $              +   4.393186046D-3 * TE**4
     $              -   8.023554873D-6 * TE**5
     $              +   6.136820929D-9 * TE**6
         DENS_SAT   = PSAT /(RG*TEMP_M(K))*AVOGA
         RELHUM_M(K)= DENS_H2O_M(K)*1.D6/DENS_SAT*100.D0 ![%]
      ENDDO

c----------------------------------------------------------------------
c change the grid refer to altitudes
c----------------------------------------------------------------------

      IF(MAXLAY.EQ. 2) ZFILENAME = 'z02'
      IF(MAXLAY.EQ. 4) ZFILENAME = 'z04'
      IF(MAXLAY.EQ.31) ZFILENAME = 'z31'
      IF(MAXLAY.EQ.36) ZFILENAME = 'z36'
      IF(MAXLAY.EQ.60) ZFILENAME = 'z60'
      IF((MAXLAY.NE.2).AND.(MAXLAY.NE.4).AND.
     $   (MAXLAY.NE.31).AND.
     $   (MAXLAY.NE.36).AND.(MAXLAY.NE.60))THEN
         WRITE(*,*) 'atmstat.f: z??.dat'
         STOP
      ENDIF
      OPEN(14,FILE='../data/'//ZFILENAME//'.dat',STATUS='UNKNOWN')
      READ(14,*)ZLEV
      CLOSE(14)

      ZLAY(1) = ZLEV(1) + 0.5D0 *(ZLEV(1) - ZLEV(2))
      DO K = 2,MAXLAY
         ZLAY(K) = 0.5D0 *(ZLEV(K) + ZLEV(K-1))
      ENDDO

      CALL LINEAR_FIT(MAXLAY, Z_M, ZLAY, TEMP_M,   TEMP_D, 50)
      CALL LINEAR_FIT(MAXLAY, Z_M, ZLAY, RELHUM_M, RELHUM, 50)

      DO K=1,MAXLAY
         ZLEV(K)   = ZLEV(K) * 1000.D0   ![km] -> [m]
         ZLAY(K)   = ZLAY(K) * 1000.D0   ![km] -> [m]
         TEMP(K)   = TEMP_D(K)
      ENDDO

c     ground pressure

      PLEV(MAXLAY) = PRESS_M(50)
cc    PLEV(MAXLAY) = 1013.25D0    !std pressure

c     pressure at ZLAY(MAXLAY)

      DZ_LAY       = ZLAY(MAXLAY)
      TEMP_LAY     = TEMP(MAXLAY)
      PLAY(MAXLAY) = PLEV(MAXLAY) *
     $               DEXP(-(AIR_M*GRAV)/RG* DZ_LAY/TEMP_LAY)

C     pressure at model levels layers [hPa]

      DO K = MAXLAY,2,-1
         DZ(K)     = ZLEV(K-1) - ZLEV(K) !layer thickness [m]
         PLEV(K-1) = PLEV(K) *  !pressure [hPa]
     $               DEXP(-(AIR_M*GRAV)/RG* DZ(K)/TEMP(K))

         DZ_LAY    = ZLAY(K-1) - ZLAY(K)
         TEMP_LAY  = 0.5D0*(TEMP(K-1) + TEMP(K))
         PLAY(K-1) = PLAY(K) *  ! pressure [hPa]
     $               DEXP(-(AIR_M*GRAV)/RG* DZ_LAY/TEMP_LAY)
      ENDDO
      DZ(1) = DZ(2)

c     preform cubic spline interpolation on actual pressure grid
c     first for ozone mixing ratio
      DO K = 1,50
         PLOG_M(K)   = DLOG(PRESS_M(K))
      ENDDO
      DO K = 1,MAXLAY
         PLOG_LAY(K) = DLOG(PLAY(K))
      ENDDO

c     spline fit to ozone data
      CALL SPLINE(PLOG_M,REL_O3_M,50,RNR,RNR,DUM3)

      DO K = 1,MAXLAY
         IF(PLAY(K) .GE. PLOG_M(1)) THEN
            CALL SPLINT(PLOG_M,REL_O3_M,DUM3,50,PLOG_LAY(K),RELO3(K))
         ELSE
            RELO3(K) = 0.D0
         ENDIF
      ENDDO

c     spline fit to H2O data
      CALL SPLINE(PLOG_M,REL_H2O_M,50,RNR,RNR,DUM3)

      DO K = 1,MAXLAY
         IF(PLAY(K) .GE. PLOG_M(1)) THEN
            CALL SPLINT(PLOG_M,REL_H2O_M,DUM3,50,PLOG_LAY(K),RELH2O(K))
         ELSE
            RELH2O(K) = 0.D0
         ENDIF
      ENDDO

c     spline fit to NO2 data
      CALL SPLINE(PLOG_M,REL_NO2_M,50,RNR,RNR,DUM3)

      DO K = 1,MAXLAY
         IF(PLAY(K) .GE. PLOG_M(1)) THEN
            CALL SPLINT(PLOG_M,REL_NO2_M,DUM3,50,PLOG_LAY(K),RELNO2(K))
         ELSE
            RELNO2(K) = 0.D0
         ENDIF
      ENDDO

c--------------------------------------------------------------------
c     Needed for surface elevation
c--------------------------------------------------------------------

      KTRUNC = -1
      DO K=1,MAXLAY
         ZFRAC(K)    = 1.D0
         DENSFRAC(K) = 1.D0
         IF(ZLEV(K).LE.ZTRUNC)THEN
            ZFRAC(K)    = 0.D0
            DENSFRAC(K) = 0.D0
            IF(KTRUNC.EQ.-1) KTRUNC = K
         ENDIF
      ENDDO
      IF(KTRUNC.EQ.-1)   KTRUNC = MAXLAY
      IF(ZTRUNC.GT.0.D0)THEN
         ZFRAC(KTRUNC)=1.D0-(ZTRUNC-ZLEV(KTRUNC))/DZ(KTRUNC)
      ENDIF

      PTRUNC = PLEV(MAXLAY)
      IF(ZTRUNC.GT.0.D0)THEN
         PTRUNC = PLEV(KTRUNC) *
     $           DEXP(-(AIR_M*GRAV)/RG*
     $                 (1.d0-ZFRAC(KTRUNC))*DZ(KTRUNC)/TEMP(KTRUNC))
         DENSFRAC(KTRUNC) = PTRUNC/PLEV(KTRUNC)
      ENDIF

c--------------------------------------------------------------------
c     column and density calculations
c--------------------------------------------------------------------
c     setup

      PSP      = AVOGA/(AIR_M*GRAV)*1.D-2 ![part./cm^2 * 1/hPa]
      CONSTANT = 3.767D-20  !change units: part./cm^2 -> DU

      SCALING_O3  = .FALSE.
      SCALING_NO2 = .FALSE.

c     Air and O3 columns and slant columns above levels and air density at
c     the center of each layer

      VAIR(1) = PSP * (PLEV(1)-0.D0)
      VO3(1)  = VAIR(1)*RELO3(1)
      VNO2(1) = VAIR(1)*RELNO2(1)
      DO K=2,MAXLAY
         IF(K.LT.KTRUNC)THEN
            VAIR(K)= PSP*PLEV(K)
            VO3(K) = VO3(K-1)  + PSP*(PLEV(K)-PLEV(K-1))*RELO3(K)
            VNO2(K)= VNO2(K-1) + PSP*(PLEV(K)-PLEV(K-1))*RELNO2(K)
         ELSE
            VAIR(K)= 1.D-20
            VO3(K) = 1.D-20
            VNO2(K)= 1.D-20
         ENDIF
      ENDDO
      IF(KTRUNC.EQ.1)THEN
         VAIR(KTRUNC) = PSP*PTRUNC
         VO3(KTRUNC)  = PSP*PTRUNC*RELO3(KTRUNC)
         VNO2(KTRUNC) = PSP*PTRUNC*RELNO2(KTRUNC)
      ELSE
         VAIR(KTRUNC) = VAIR(KTRUNC-1)+
     $                  PSP*(PTRUNC-PLEV(KTRUNC-1))
         VO3(KTRUNC)  = VO3(KTRUNC-1) +
     $                  PSP*(PTRUNC-PLEV(KTRUNC-1))*RELO3(KTRUNC)
         VNO2(KTRUNC) = VNO2(KTRUNC-1)+
     $                  PSP*(PTRUNC-PLEV(KTRUNC-1))*RELNO2(KTRUNC)
      ENDIF

c----------------------------------------------------------------------
c     scale the profile for a given total ozone column
c----------------------------------------------------------------------

      IF(SCALING_O3)THEN
         FACTOR = SCALE_O3/(VO3(KTRUNC)*CONSTANT*1.D3)
         DO K=1,MAXLAY
            IF(K.LE.KTRUNC)THEN
               VO3(K) = VO3(K) * FACTOR
            ELSE
               VO3(K) = 0.D0
            ENDIF
         ENDDO
      ENDIF

      IF(SCALING_NO2)THEN
         FACTOR = SCALE_NO2/VNO2(KTRUNC)
         DO K=1,MAXLAY
            IF(K.LE.KTRUNC)THEN
               VNO2(K) = VNO2(K) * FACTOR
            ELSE
               VNO2(K) = 0.D0
            ENDIF
         ENDDO
      ENDIF

c----------------------------------------------------------------------
c     differential O2 and O3 columns and averaged ozone density
c----------------------------------------------------------------------

      DVAIR(1) = VAIR(1)
      DVO3(1)  = VO3(1)
      DVNO2(1) = VNO2(1)
      DO K=2,MAXLAY
         IF(K.LE.KTRUNC)THEN
            DVAIR(K) = VAIR(K) - VAIR(K-1)
            DVO3(K)  = VO3(K)  - VO3(K-1)
            DVNO2(K) = VNO2(K) - VNO2(K-1)
         ELSE
            DVAIR(K) = 1.D-20
            DVO3(K)  = 1.D-20
            DVNO2(K) = 1.D-20
         ENDIF
      ENDDO

      DO K = 1,MAXLAY
         DENS_AIR(K) = DVAIR(K)/DZ(K)*1.D-02
         DENS_O3(K)  = DVO3(K) /DZ(K)*1.D-02
         DENS_NO2(K) = DVNO2(K)/DZ(K)*1.D-02
      ENDDO

!     O2-O2 cross section goes quadratically with O2 density ~ ([O2])^2

      DO K = 1,MAXLAY
         DVO4(K) = (RELO2*DENS_AIR(K))**2 * DZ(K)*1.D+02
         IF(K.GT.KTRUNC) DVO4(K) = 1.D-20
      ENDDO

c      WRITE(*,'(2A16)') 'DVair(Ktrunc)','DVO4(Ktrunc)'
c      WRITE(*,'(2d16.8)') DVair(Ktrunc),DVO4(Ktrunc)

      RETURN
      END SUBROUTINE model_atmosphere

***********************************************************************

      SUBROUTINE LINEAR_FIT(MAXLAY, Z1, Z2, F1, F2, DIM)

      IMPLICIT NONE

      INTEGER
     $     MAXLAY,
     $     DIM,
     $     K1,
     $     K2,
     $     M1,
     $     M2

      DOUBLE PRECISION
     $     A,
     $     B,
     $     Z1(DIM),F1(DIM),Z2(MAXLAY),F2(MAXLAY)

      DOUBLE PRECISION
     $     X1(DIM),Y1(DIM),X2(MAXLAY),Y2(MAXLAY)

c----------------------------------------------------------------------
c     Z1,F1 and Z2,F2 go from top to bottom, X1,Y1 and X2,Y2
c     go from bottom to top
c----------------------------------------------------------------------

      DO K1 =1,DIM
         X1(K1) = Z1(DIM+1-K1)
         Y1(K1) = F1(DIm+1-K1)
      ENDDO

      DO K2 =1,MAXLAY
         X2(K2) = Z2(MAXLAY+1-K2)
      ENDDO

      DO K2=1,MAXLAY
         IF (X2(K2).GE. X1(DIM-1)) THEN
            M1=DIM-1
            M2=DIM
         ELSE
            DO K1=1,DIM-1
               IF (X2(K2).LT.X1(K1+1) .AND. X2(K2).GE.X1(K1)) THEN
                  M1=K1
                  M2=K1+1
               ENDIF
            ENDDO
         ENDIF

         A=(Y1(M1)-Y1(M2))/( X1(M1)-X1(M2) )
         B=Y1(M1)-A*X1(M1)

         Y2(K2)=A*X2(K2) + B
      ENDDO

      DO K2 =1,MAXLAY
         F2(K2) = Y2(MAXLAY+1-K2)
      ENDDO

      RETURN
      END SUBROUTINE LINEAR_FIT

********************************************************************

      SUBROUTINE ATM_OUT(MAXLAY, PLAY, TEMP, ZLAY, RELO3, RELNO2)

      IMPLICIT NONE

      INTEGER
     $     MAXLAY,
     $     K

      DOUBLE PRECISION
     $     PLAY(MAXLAY),     !pressure at center of each layer [hPa]
     $     TEMP(MAXLAY),     !temperature at center of each layer [K]
     $     ZLAY(MAXLAY),     !height of center of each layer [m]
     $     RELO3(MAXLAY),    !O3 volumn mixing ratio [1]
     $     RELNO2(MAXLAY)    !NO2 volumn mixing ratio [1]

 12   FORMAT(1P,6(E8.2,2X))

      OPEN(1,FILE='RESULT/prof.dat',status='unknown')

      WRITE(1,*)'PRESSURE [hPa]'
      WRITE(1,'(1P,6E10.2)')(PLAY(K),K=1,MAXLAY)

      WRITE(1,*)'TEMPERATURE PROFILE [K]'
      WRITE(1,12)(TEMP(K),K=1,MAXLAY)

      WRITE(1,*)'ALTIUDE GRID [m]'
      WRITE(1,12) (ZLAY(K),K=1,MAXLAY)

      WRITE(1,*)'MIXING RATIO OF OZON [1]'
      WRITE(1, 12)(RELO3(K), K=1,MAXLAY)

      WRITE(1,*)'MIXING RATIO OF NO2 [1]'
      WRITE(1,12)(RELNO2(K), K=1,MAXLAY)

      CLOSE(1)

      RETURN
      END SUBROUTINE ATM_OUT


subroutine  HOT (B,BareNetRadn,BareEvapFlux,BareHeatFlux)
  use simsphere_mod, only: lambda, atemp, tt, z, dens, cp, frveg, rnet, heat, &
                           gbl_sum, veghot, eq
  implicit none

!  HOT is called during the day to compute the sensible heat flux HEAT
!  from net all wave radiation and the evaporation.

  real :: BareNetRadn,BareEvapFlux
  real :: BareHeatFlux,VegnHeatFlux,MixedHeatFlux
  real :: A, B

!      INCLUDE 'modvars.h'

  A = ( Lambda * ( Atemp - TT(2) ) ) / Z(2)
  B = Lambda / ( Z(2) * Dens * Cp )

  if (eq(frveg,1.0,1e-4) .and. Rnet > 0.0) then

! Vegetation

    call Veghot(B,VegnHeatFlux)
    Heat = VegnHeatFlux

  else if (Frveg > 0 .and. Frveg < 1 .and. Rnet > 0) then

! Mixed
    BareHeatFlux = (BareNetRadn - BareEvapFlux - A) / (1+B*GBL_sum)
    call Veghot (B,VegnHeatFlux)
    MixedHeatFlux = (1-Frveg) * BareHeatFlux + Frveg * VegnHeatFlux
    Heat = MixedHeatFlux
  else

! Bare Soil

    BareHeatFlux = (BareNetRadn - BareEvapFlux - A) / (1 + B * GBL_sum)
    Heat = BareHeatFlux

  end if
  return
end


C File: arrays-sect-07.f
C Illustrates the use of array sections using the values of another
C array to specify the array elements being referenced.  In this
C example the target elements referenced are contiguous.

      program main
      implicit none

      integer, dimension (5) :: A
      integer, dimension (3) :: B = (/2, 3, 4/)

      integer :: i

      do i = 1, 5
          A(i) = 0
      end do

      write (*,10) A(1), A(2), A(3), A(4), A(5)

 10   format(5(I5,X))

C     Use of a more complex array section to redefine all elements of A
C     This example uses an array as the index.
      A(B) = 17

      write (*,10) A(1), A(2), A(3), A(4), A(5)

      stop
      end program main


!   This module contains some generic physical constants, such as hbarc, pi, masses of particles etc
MODULE constants
  INTEGER,  PARAMETER :: dp = KIND(1.0D0)
  INTEGER, PARAMETER :: dpc = KIND((1.0D0,1.0D0))
  REAL(DP), PARAMETER, PUBLIC ::  bohr_r=0.05291772108_dp  ! Bohr radius in nm
  REAL(DP), PARAMETER, PUBLIC :: hbarc = 197.326968_dp    !  2006 value
  REAL(DP), PUBLIC, PARAMETER :: pi = 3.141592741012573_dp
  REAL(DP), PUBLIC, PARAMETER :: pi_2 = 1.570796370506287_dp
  REAL(DP), PUBLIC, PARAMETER :: pi_4 = 0.7853981852531433_dp
END MODULE constants

!   This module and its submodules allows the user to inherent quantum
!   numbers from lower and more basic objects
MODULE system
  USE constants
  ! This is the basis type used, and contains all quantum numbers necessary
  ! for fermions in one dimension
  TYPE SpQuantumNumbers
     !  n is the principal quantum number taken as number of nodes-1
     !  s is the spin and ms is the spin projection, and parity is obvious
     INTEGER :: TotalOrbits
     INTEGER, DIMENSION(:), POINTER :: n, s, ms, parity
     REAL(DP), DIMENSION(:), POINTER :: masses, energy
  END TYPE SpQuantumNumbers
  ! We add then quantum numbers appropriate for two-dimensional systems,
  ! suitable  for electrons in quantum dots for example
  ! Use as TYPE(TwoDim) :: qdelectrons
  ! n => qdelectrons%n
  TYPE, EXTENDS(SpQuantumNumbers) :: TwoDim
     INTEGER, DIMENSION(:), POINTER :: ml
  END TYPE TwoDim
  ! Then we extends to three dimensions, suitable for atoms and electrons in
  ! 3d traps
  ! Use as TYPE(ThreeDim) :: electrons
  ! n => electrons%n
  TYPE, EXTENDS(TwoDim) :: ThreeDim
     INTEGER, DIMENSION(:), POINTER :: l, j, mj
  END TYPE ThreeDim
  ! Then we extends to nucleons and isobars, note that the masses are in
  ! SpQuantumNumbers. We add isospin and its projections
  ! Use as TYPE(nucleons) :: protons
  ! n => protons%n
  TYPE, EXTENDS(ThreeDim) :: nucleons
     INTEGER, DIMENSION(:), POINTER :: t, tz
  END TYPE nucleons
  ! Finally we allow for studies of hypernuclei, adding strangeness
  ! Use as TYPE(hyperons) :: sigma
  ! n => sigma%n; s => sigma%strange
  TYPE, EXTENDS(nucleons) :: hyperons
     INTEGER, DIMENSION(:), POINTER :: strange
  END TYPE hyperons
END MODULE system


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE SQRLIM (RDMESH, SQMESH)
C=======================================================================

C   --*** SQRLIM *** (MESH) Expand 2D mesh limits to square
C   --   Written by Amy Gilkey - revised 05/23/86
C   --
C   --SQRLIM expands the mesh limits to form a square.
C   --
C   --Parameters:
C   --   RDMESH - IN - the mesh limits
C   --      (left, right, bottom, top)
C   --   SQMESH - OUT - the square mesh limits (may be RDMESH)
C   --      (left, right, bottom, top)

      PARAMETER (KLFT=1, KRGT=2, KBOT=3, KTOP=4, KNEA=5, KFAR=6)

      REAL RDMESH(KTOP), SQMESH(KTOP)

      RNG2 = .5 * MAX (RDMESH(KRGT) - RDMESH(KLFT)
     &   ,             RDMESH(KTOP) - RDMESH(KBOT))
      XCEN = .5 * (RDMESH(KRGT) + RDMESH(KLFT))
      YCEN = .5 * (RDMESH(KTOP) + RDMESH(KBOT))
      SQMESH(KLFT) = XCEN - RNG2
      SQMESH(KRGT) = XCEN + RNG2
      SQMESH(KBOT) = YCEN - RNG2
      SQMESH(KTOP) = YCEN + RNG2

      RETURN
      END


program test_intersection
use iso_fortran_env, only:int8, int16, int32, int64, real32, real64, real128
use mod_testing, only:assert, initialize_tests, report_tests
use mod_functional

implicit none

logical, dimension(:), allocatable :: tests
logical :: test_failed
integer :: n, norder, ntests
integer, parameter :: stdout = 6

n = 1
ntests = 12
call initialize_tests(tests, ntests)

tests(n) = assert(all(intersection([1_int8, 2_int8], [2_int8, 3_int8]) == [2]), &
                  'intersection,  int8')
n = n + 1

tests(n) = assert(all(intersection([1_int16, 2_int16], [2_int16, 3_int16]) == [2]), &
                  'intersection,  int16')
n = n + 1

tests(n) = assert(all(intersection([1_int32, 2_int32], [2_int32, 3_int32]) == [2]), &
                  'intersection,  int32')
n = n + 1

tests(n) = assert(all(intersection([1_int64, 2_int64], [2_int64, 3_int64]) == [2]), &
                  'intersection,  int64')
n = n + 1

tests(n) = assert(all(intersection([1._real32, 2._real32], [2._real32, 3._real32]) == [2]), &
                  'intersection,  real32')
n = n + 1

tests(n) = assert(all(intersection([1._real64, 2._real64], [2._real64, 3._real64]) == [2]), &
                  'intersection,  real64')
n = n + 1

tests(n) = assert(all(intersection([1._real128, 2._real128], [2._real128, 3._real128]) == [2]), &
                  'intersection,  real128')
n = n + 1

tests(n) = assert(all(intersection([cmplx(1._real32, 0._real32), cmplx(2._real32, 0._real32)], &
                                   [cmplx(2._real32, 0._real32), cmplx(3._real32, 0._real32)])&
                       == [cmplx(2._real32, 0._real32)]), &
                  'intersection,  complex real32')
n = n + 1

tests(n) = assert(all(intersection([cmplx(1._real64, 0._real64), cmplx(2._real64, 0._real64)], &
                                   [cmplx(2._real64, 0._real64), cmplx(3._real64, 0._real64)])&
                       == [cmplx(2._real64, 0._real64)]), &
                  'intersection,  complex real64')
n = n + 1

tests(n) = assert(all(intersection([cmplx(1._real128, 0._real128), cmplx(2._real128, 0._real128)], &
                                   [cmplx(2._real128, 0._real128), cmplx(3._real128, 0._real128)])&
                       == [cmplx(2._real128, 0._real128)]), &
                  'intersection,  complex real128')
n = n + 1

tests(n) = assert(intersection('Hello', 'world') == 'lo', &
                  'intersection, character string')
n = n + 1

test_failed = .false.

tests(n) = assert(all(intersection([1, 2], [2, 3]) == ([1, 2].intersection.[2, 3])), &
                  'intersection operator,  x.intersection.y')
n = n + 1

test_failed = .false.
call report_tests(tests, test_failed)
if(test_failed)stop 1

end program test_intersection


SUBROUTINE sedbal_lake(muni,k)

! Code converted using TO_F90 by Alan Miller
! Date: 2005-08-23  Time: 12:57:31

use common_h
use time_h
use reservoir_h
use lake_h
use routing_h

IMPLICIT NONE

INTEGER, INTENT(IN)                  :: muni
INTEGER, INTENT(IN)                  :: k
INTEGER :: n,g,l,nbrsteps !i,
real:: dummy

real :: wat_dens,sed_dens,delta,grav,visc
real :: overflow_rate,diam_equiv,frac_finer,trap_eff
real :: frretent,frrelease !frcum,
real :: cumfrsed_in(n_sed_class),cumfrsed_out(n_sed_class),lower_limit(n_sed_class)
real :: par_a,par_b,par_c
real :: interv(200),setveloc(200),upper_diam(200),lower_diam(200),mean_diam(200),frfiner(200)
real :: frfiner_out(200),cumfrrelease(200)
real :: par_x(200),par_y(200) !,par_z(200)

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
REAL :: tempres(step,muni)

! -----------------------------------------------------------------------
if (lakesedin_hrr(step,muni,k)/=0. .and. lakearea(muni,k)/=0.) then
!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
  tempres(step,muni)=20.

! density of water and density of natural sediments (kg/m3)
  wat_dens=1.*1000.
  sed_dens=2.65*1000.

! specific gravity of sediments in water (-)
  delta=(sed_dens-wat_dens)/wat_dens

! gravitacional acceleration (m2/s)
  grav=9.807

! kinematic viscosity (m2/s)
  visc=(1.14-0.031*(tempres(step,muni)-15.)+  &
      0.00068*((tempres(step,muni)-15.)**2.))*1.e-6

! Overflow rate  Vc (m/s)
  overflow_rate=(lakeoutflow_hrr(step,muni,k)/(86400./nt))/(lakearea(muni,k)*1.e6)
!  overflow_rate=0.00032

! calculation of the corresponding equivalent diameter (mm)
  par_a=1.09*(delta)*grav
  par_b=-(overflow_rate**2)
  par_c=-27.9*overflow_rate*visc

  diam_equiv=1000.*(-par_b+sqrt(((par_b)**2.)-4.*par_a*par_c))/(2.*par_a)

! affluent grain size distribution (-)
  dummy=0.
  DO g=1,n_sed_class
    dummy=dummy+lakefracsedin_hrr(step,muni,k,g)
    cumfrsed_in(g)=dummy
!write(*,'(3I4,3F10.3)')muni,k,g,cumfrsed_in(g)
  enddo

! lower limits of particle size class intervalls (mm)
  lower_limit(1)=upper_limit(1)/2.
  DO g=2,n_sed_class
    lower_limit(g)=upper_limit(g-1)
  enddo
!write(*,*)g,(lower_limit(g),g=1,n_sed_class)

! fraction of particles smaller than equivalent diameter (-)
  DO g=1,n_sed_class
    if (diam_equiv>=lower_limit(g) .and. diam_equiv<=upper_limit(g) .and. g>1) then
      frac_finer=cumfrsed_in(g-1)+(cumfrsed_in(g)-cumfrsed_in(g-1))* &
		(log10(diam_equiv)-log10(lower_limit(g)))/ &
		(log10(upper_limit(g))-log10(lower_limit(g)))
	  exit
	else if (diam_equiv>=lower_limit(1) .and. diam_equiv<=upper_limit(1)) then
      frac_finer=cumfrsed_in(g)* &
		(log10(diam_equiv)-log10(lower_limit(g)))/ &
		(log10(upper_limit(g))-log10(lower_limit(g)))
	  exit
	else if (diam_equiv<lower_limit(1)) then
	  frac_finer=0.
	else if (diam_equiv>upper_limit(n_sed_class)) then
	  frac_finer=1.
	endif
  enddo

  DO g=1,n_sed_class
!write(*,'(I3,5F10.6)')g,frac_finer,cumfrsed_in(g),diam_equiv,lower_limit(g),upper_limit(g)
  enddo
!write(*,*)frac_finer,diam_equiv,lower_limit(1)

  if (frac_finer == 1. .or. frac_finer == 0.) then
    trap_eff=1.-frac_finer
	if (frac_finer == 1.) then
      DO g=1,n_sed_class
	    lakefracsedout_hrr(step,muni,k,g)=lakefracsedin_hrr(step,muni,k,g)
	  enddo
	else
      DO g=1,n_sed_class
	    lakefracsedout_hrr(step,muni,k,g)=0.
	  enddo
    endif
  else
    dummy=0.
    DO g=1,n_sed_class
      if (diam_equiv>=lower_limit(g)) then
	    dummy=dummy+1.
	  else
	    exit
	  endif
	enddo
    nbrsteps=int(10.*dummy)
	lower_diam(1)=lower_limit(1)
!	interv=frac_finer/nbrsteps
    n=0
    DO g=1,n_sed_class
	  if (g>1) then
	    if (frac_finer>=cumfrsed_in(g)) &
		  dummy=(cumfrsed_in(g)-cumfrsed_in(g-1))/10.
	    if (frac_finer<cumfrsed_in(g) .and. frac_finer>cumfrsed_in(g-1)) &
		  dummy=(frac_finer-cumfrsed_in(g-1))/10.
	    if (frac_finer<cumfrsed_in(g) .and. frac_finer<cumfrsed_in(g-1)) exit
	  else
		if (frac_finer>=cumfrsed_in(g)) &
		  dummy=cumfrsed_in(g)/10.
	    if (frac_finer<cumfrsed_in(g)) &
		  dummy=frac_finer/10.
	  endif

      do l=1,10
	    n=n+1
	    interv(n)=dummy
	  enddo
	enddo
    DO n=1,nbrsteps
	  if (n>1) frfiner(n)=frfiner(n-1)+interv(n)
	  if (n==1) frfiner(n)=interv(n)
	enddo
    DO n=1,nbrsteps
!	  frfiner(n)=n*interv
      DO g=1,n_sed_class
        if (frfiner(n)<=cumfrsed_in(1)) then
          upper_diam(n)=10.**(log10(lower_limit(g))+((log10(upper_limit(g))-log10(lower_limit(g)))* &
			frfiner(n)/cumfrsed_in(g)))
		  exit
		else if (frfiner(n)<=cumfrsed_in(g)) then
          upper_diam(n)=10.**(log10(lower_limit(g))+((log10(upper_limit(g))-log10(lower_limit(g)))* &
			(frfiner(n)-cumfrsed_in(g-1))/(cumfrsed_in(g)-cumfrsed_in(g-1))))
		  exit
	    endif
	  enddo
!write(*,'(I3,4F10.6)')n,interv(n),frfiner(n),upper_diam(n)
	enddo

    DO n=2,nbrsteps
	  lower_diam(n)=upper_diam(n-1)
	enddo

	frretent=0.
	frrelease=0.
    DO n=1,nbrsteps
	  mean_diam(n)=sqrt(lower_diam(n)*upper_diam(n))
! settling velocity (m/s)
      setveloc(n)=SQRT((13.95*visc/(mean_diam(n)/1000.))**2.+(1.09*  &
        (delta)*9.807*(mean_diam(n)/1000.)))-(13.95*visc/(mean_diam(n)/1000.))
	  par_x(n)=(setveloc(n)/overflow_rate)*interv(n)
	  par_y(n)=(1.-(setveloc(n)/overflow_rate))*interv(n)
!	  par_x(n)=(setveloc(n)/overflow_rate)*interv
!	  par_y(n)=(1-(setveloc(n)/overflow_rate))*interv
      frretent=frretent+par_x(n)
      frrelease=frrelease+par_y(n)
!write(*,'(I3,6F12.8)')n,mean_diam(n),lower_diam(n),upper_diam(n),setveloc(n),par_x(n),par_y(n)
!write(*,'(I3,6F12.8)')n,mean_diam(n),setveloc(n),par_x(n),par_y(n),frretent,frrelease
	enddo

	trap_eff=(1.-frac_finer)+frretent

	dummy=0.
    DO n=1,nbrsteps
	  frfiner_out(n)=par_y(n)/frrelease
	  dummy=dummy+frfiner_out(n)
	  cumfrrelease(n)=dummy
!write(*,'(I3,4F12.8)')n,upper_diam(n),frfiner_out(n),cumfrrelease(n),trap_eff
	enddo

    DO g=1,n_sed_class
	  if (upper_limit(g)>upper_diam(nbrsteps)) then
	    cumfrsed_out(g)=1.
	  else
	    do n=1,nbrsteps
	      if (upper_limit(g)>=lower_diam(n) .and. upper_limit(g)<=upper_diam(n) .and. n>1) then
            cumfrsed_out(g)=cumfrrelease(n-1)+(cumfrrelease(n)-cumfrrelease(n-1))* &
				(log10(upper_limit(g))-log10(lower_diam(n)))/ &
				(log10(upper_diam(n))-log10(lower_diam(n)))
	        exit
		  else if (upper_limit(g)>=lower_diam(1) .and. upper_limit(g)<=upper_diam(1)) then
            cumfrsed_out(g)=cumfrrelease(n)* &
				(log10(upper_limit(g))-log10(lower_diam(n)))/ &
				(log10(upper_diam(n))-log10(lower_diam(n)))
	        exit
		  endif
		enddo
	  endif
	  if (g==1) lakefracsedout_hrr(step,muni,k,g)=cumfrsed_out(g)
	  if (g>1) lakefracsedout_hrr(step,muni,k,g)=cumfrsed_out(g)-cumfrsed_out(g-1)

!write(*,'(3I4,3F10.3)')muni,k,g,lakefracsedout_hrr(step,muni,k,g),cumfrsed_out(g)
!write(*,'(3I4,3F10.3)')muni,k,g,cumfrsed_in(g),cumfrsed_out(g)
!write(*,'(3I4,3F10.3)')muni,k,g,lakefracsedin_hrr(step,muni,k,g),lakefracsedout_hrr(step,muni,k,g)
	enddo
  endif
  lakesedout_hrr(step,muni,k)=lakesedin_hrr(step,muni,k)*(1.-trap_eff)
else
  lakesedout_hrr(step,muni,k)=0.
endif

!write(*,'(3I4,5F12.2)')step,muni,k,acud(muni,k),lakeoutflow_hrr(step,muni,k),lakesedin_hrr(step,muni,k),lakesedout_hrr(step,muni,k),trap_eff

if (t==tstart .and. step==1) lakecumdep_hrr(muni,k)=0.
lakedep_hrr(step,muni,k)=max(lakesedin_hrr(step,muni,k)-lakesedout_hrr(step,muni,k),0.)
lakecumdep_hrr(muni,k)=lakecumdep_hrr(muni,k)+lakedep_hrr(step,muni,k)

! storage capacity reduction (m3)
lake_vollost(step,muni,k)=lakedep_hrr(step,muni,k)/1.5
!lake_vollost(step,muni,k)=lake_vollost(step,muni,k)*acud(muni,k)

!write(*,'(3I4,2F15.1)')t,d,upstream,sedimentation(step,upstream),cum_sedimentation(upstream)

!write(*,'(3I4,4F15.1)')t,d,upstream,sed_inflow(step,upstream),sed_outflow(step,upstream),sedimentation(step,upstream),sed_susp(step,upstream)

!if (d==2)stop

RETURN
END SUBROUTINE sedbal_lake


! { dg-do compile }
! { dg-options "-O -Warray-temporaries" }
! PR 45744 - this used to ICE because of type mismatch
!            in the generated temporary.
MODULE m
CONTAINS
  FUNCTION rnd(n)
    INTEGER, INTENT(in) :: n
    REAL(8), DIMENSION(n) :: rnd
    CALL RANDOM_NUMBER(rnd)
  END FUNCTION rnd

  SUBROUTINE GeneticOptimize(n)
    INTEGER :: n
    LOGICAL :: mask(n)
    REAL(8) :: popcross=0
    REAL(4) :: foo(n)
    real(4) :: a(n,n), b(n,n)
    real(8) :: c(n,n)
    integer(4) :: x(n,n)
    integer(8) :: bar(n)
    mask = (rnd(n) < popcross)  ! { dg-warning "Creating array temporary" }
    foo = rnd(n)                ! { dg-warning "Creating array temporary" }
    bar = rnd(n)                ! { dg-warning "Creating array temporary" }
    c = matmul(a,b)             ! { dg-warning "Creating array temporary" }
    x = matmul(a,b)             ! { dg-warning "Creating array temporary" }
  END SUBROUTINE GeneticOptimize
END MODULE m


! This test was created from ..\problem-specifications\exercises\grains\canonical-data.json
!

program grains_test_main
  use TesterMain
  use grains

  implicit none

  ! Test 1: grains on square 1
  call assert_equal(1.d0, square(1), "grains on square 1")
  ! Test 2: grains on square 2
  call assert_equal(2.d0, square(2), "grains on square 2")
  ! Test 3: grains on square 3
  call assert_equal(4.d0, square(3), "grains on square 3")
  ! Test 4: grains on square 4
  call assert_equal(8.d0, square(4), "grains on square 4")
  ! Test 5: grains on square 16
  call assert_equal(32768.d0, square(16), "grains on square 16")
  ! Test 6: grains on square 32
  call assert_equal(2147483648.d0, square(32), "grains on square 32")
  ! Test 7: grains on square 64
  call assert_equal(9223372036854775808.d0, square(64), "grains on square 64")
  ! Test 8: square 0 raises an exception
  ! ERROR: square must be between 1 and 64
  call assert_equal(-1.d0, square(0), "square 0 raises an exception")
  ! Test 9: negative square raises an exception
  ! ERROR: square must be between 1 and 64
  call assert_equal(-1.d0, square(-1), "negative square raises an exception")
  ! Test 10: square greater than 64 raises an exception
  ! ERROR: square must be between 1 and 64
  call assert_equal(-1.d0, square(65), "square greater than 64 raises an exception")
  ! Test 11: returns the total number of grains on the board
  call assert_equal(18446744073709551615.d0, total(), "returns the total number of grains on the board")

  call test_report()

end program


        program chkfmt
c----------------------------------------------------------------------c
c                          S P A R S K I T                             c
c----------------------------------------------------------------------c
c test suite for the unary routines.                                   c
c tests some of the routines in the module unary. Still needs to tests c
c many other routines.                                                 c
c Last update: May 2, 1994.
c----------------------------------------------------------------------c
      parameter (nxmax = 10, nmx = nxmax*nxmax, nnzmax=10*nmx)
      implicit real*8 (a-h,o-z)
      integer ia(nmx+1),ja(nnzmax),ia1(nnzmax),ja1(nnzmax),
     *         iwk(nmx*2+1), perm(16), qperm(16) ,
     *         iwork(nnzmax*2)
      real*8 a(nnzmax),a1(nnzmax),dns(20,20),rhs(nnzmax),al(6)
      data ndns/20/
      data qperm /1, 3, 6, 8, 9, 11, 14, 16, 2, 4, 5, 7, 10, 12, 13, 15/
c
c define correct permutation
c
      do 1 i=1, 16
         perm(qperm(i)) = i
 1    continue
c----- open statements ----------------
      open (unit=7,file='unary.mat')
c
c---- dimension of grid
c
c     generate a 16 by 16 matrix (after eliminating boundary)
      nx = 6
      ny = 6
      nz = 1
      al(1) = 0.D0
      al(2) = 0.D0
      al(3) = 0.D0
      al(4) = 0.D0
      al(5) = 0.D0
      al(6) = 0.D0
c
c---- generate grid problem.
c
      call gen57pt (nx,ny,nz,al,0,n,a,ja,ia,iwk,rhs)
c
c---- write out the matrix
c
	iout = 7
	nnz = ia(n+1)-1
	write (iout,*) '-----------------------------------------'
        write (iout,*) '  +++  initial matrix in CSR format +++ '
	write (iout,*) '-----------------------------------------'
        call dump(1,n,.true.,a,ja,ia,iout)
c
c call csrdns
c
	 call csrdns(n,n,a,ja,ia,dns,ndns,ierr)
c
c write it out as a dense matrix.
c
	 write (iout,*) '-----------------------------------------'
         write (iout,*) '  +++ initial matrix in DENSE format+++ '
	 write (iout,*) '-----------------------------------------'
         call dmpdns(n, n, ndns, dns, iout)
c
c red black ordering
c
         job = 1
c
        call dperm (n,a,ja,ia,a1,ja1,ia1,perm,perm,job)
c
	nnz = ia(n+1)-1
	write (iout,*) '-----------------------------------------'
        write (iout,*) '  +++ red-black matrix in CSR format +++ '
	write (iout,*) '-----------------------------------------'
        call dump(1,n,.true.,a1,ja1,ia1,iout)
c
c sort matrix
c
        call csort (n,a1,ja1,ia1,iwork,.true.)
	nnz = ia(n+1)-1
	write (iout,*) '-----------------------------------------'
        write (iout,*) '  +++     matrix after sorting    +++ '
	write (iout,*) '-----------------------------------------'
        call dump(1,n,.true.,a1,ja1,ia1,iout)
c
c
c convert into dense format
c
         call csrdns(n, n, a1,ja1,ia1,dns,ndns,ierr)
	 write (iout,*) '-----------------------------------------'
         write (iout,*) '  +++ red-black matrix in DENSE format+++ '
	 write (iout,*) '-----------------------------------------'
         call dmpdns(n,n, ndns, dns, iout)
         stop
         end
c-----------------------------------------------------------------------
         subroutine dmpdns(nrow, ncol, ndns, dns, iout)
         integer nrow, ncol, ndns, iout
         real*8 dns(ndns,*)
c-----------------------------------------------------------------------
c this subroutine prints out a dense matrix in a simple format.
c the zero elements of the matrix are omitted. The format for the
c nonzero elements is f4.1, i.e., very little precision is provided.
c-----------------------------------------------------------------------
c on entry
c --------
c nrow = row dimension of matrix
c ncol = column dimension of matrix
c ndns = first dimension of array dns.
c dns  = double dimensional array of size n x n containing the matrix
c iout = logical unit where to write matrix
c
c on return
c ---------
c matrix will be printed out on unit output iout.
c------------------------------------------------------------------------
c         local variables
         integer j, j1, j2, last, i
         character*80 fmt
c
c prints out a dense matrix -- without the zeros.
c
	 write (iout,'(4x,16i4)') (j,j=1,ncol)
         fmt(1:5) = '    |'
         j1 = 6
         do 1 j=1, ncol
            j2 = j1+4
            fmt(j1:j2) = '----'
            j1 = j2
 1       continue
         last = j1
         fmt(last:last) = '|'
            write (iout,*) fmt
c
c undo loop 1 ---
c
         j1 = 6
         do 2 j=1,ncol
            j2 = j1+4
            fmt(j1:j2) = '   '
            j1 = j2
 2          continue
c
         do 4  i=1, nrow
         j1 = 6
         write (fmt,101) i
 101     format(1h ,i2,2h |)
         do 3 j=1, ncol
            j2= j1+4
            if (dns(i,j) .ne. 0.0) then
               write (fmt(j1:j2),102) dns(i,j)
 102           format(f4.1)
            endif
           j1 = j2
 3       continue
           fmt(last:last) = '|'
           write (iout,*) fmt
 4       continue
         fmt(1:5) = '    |'
         j1 = 6
         do 5 j=1, ncol
            j2 = j1+4
            fmt(j1:j2) = '----'
            j1 = j2
 5       continue
         fmt(last:last) = '|'
            write (iout,*) fmt
         return
         end


MODULE funciones
  IMPLICIT NONE

CONTAINS

  FUNCTION delta_kr(M,N)
    IMPLICIT NONE
    DOUBLE PRECISION :: M,N
    INTEGER DELTA_KR
    IF(M.EQ.N) DELTA_KR = 1
    IF(M.NE.N) DELTA_KR = 0
  END FUNCTION delta_kr

  FUNCTION delta_kr_int(M,N)
    IMPLICIT NONE
    INTEGER :: M,N
    INTEGER DELTA_KR_INT
    IF(M.EQ.N) DELTA_KR_INT = 1
    IF(M.NE.N) DELTA_KR_INT = 0
  END FUNCTION delta_kr_int

END MODULE funciones


module date_to_numeric_mod

    use global_mod, only: ip
    use logging_mod, only: log_output_unit
    use stop_mod, only: generic_stop
    use iso_c_binding, only: C_DOUBLE

    implicit none

    ! Here we always use double-precision reals
    integer, parameter, private :: rp = C_DOUBLE

    integer, parameter :: julian_day_1970_01_01 = 2440588
        !! the date '1970-01-01' as a julian day
    integer, parameter :: julian_day_1992_01_01 = 8035 + julian_day_1970_01_01
        !! the date '1992-01-01' as a julian day

    integer, parameter :: days_in_month_regular_year(12) = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]
    integer, parameter :: days_in_month_leap_year(12)    = [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]

    contains

    function is_leap_year(yyyy)
        !! Is year yyyy a leap-year?
        integer(ip), intent(in) :: yyyy
        logical :: is_leap_year
        ! Leap years -- note centuries are only leap years if they divide 400, e.g.
        ! 2100, 2200, 2300 are not leap-years, but 2400 is.
        is_leap_year = (mod(yyyy, 4) == 0) .and. ((mod(yyyy, 100) /= 0) .or. (mod(yyyy, 400) == 0))
    end function

    subroutine check_datetime(yyyy, mm, dd, hh, mi, ss)
            !! Check that a date of the form yyyy/mm/dd/hh/mi/ss is valid
            !! The hh/mi/ss are optional.
            !! Because this can throw errors, it is not elemental
        integer(ip), intent(in) :: yyyy, mm, dd
            !! Year/month/day
        integer(ip), optional, intent(in) :: hh, mi, ss
            !! Hour/minute/second

        integer :: max_days

            if(mm < 1 .or. mm > 12) then
                write(log_output_unit,*) 'Month must be from 1-12, but got ', mm
                call generic_stop
            end if

           ! Figure out how many days in the month
            if(is_leap_year(yyyy)) then
                max_days = days_in_month_leap_year(mm)
            else
                max_days = days_in_month_regular_year(mm)
            end if

            if(dd < 1 .or. dd > max_days) then
                write(log_output_unit, *) 'The number of days in month ', mm , &
                    ' should be between 1 and ', max_days, ', but I got ', dd
                call generic_stop
            end if

            if(present(hh)) then
                if(hh < 0 .or. hh > 23) then
                    write(log_output_unit, *) 'The hour should range in 0 to 23, but I got ', hh
                    call generic_stop
                end if
            end if

            if(present(mi)) then
                if(mi < 0 .or. mi > 59) then
                    write(log_output_unit, *) 'The minute should range in 0 to 59, but I got ', mi
                    call generic_stop
                end if
            end if

            if(present(ss)) then
                if(ss < 0 .or. ss > 59) then
                    write(log_output_unit, *) 'The second should range in 0 to 59, but I got ', ss
                    call generic_stop
                end if
            end if

    end subroutine

    elemental subroutine ymd_to_julian_day(yyyy, mm, dd, julian)
        !! Converts a calendar date to a Julian date (i.e. integer number of days since start of Julian calendar)
        !! Fliegel and Van Flandern (1968) CACM 11(10):657
        !! Various discussions of this online, e.g.
        !! https://software.intel.com/en-us/forums/intel-fortran-compiler/topic/271933
        !! https://stackoverflow.com/questions/17354100/date-time-difference-in-fortran
        integer, intent(in) :: yyyy, mm, dd
            !! year, month, day
        integer, intent(out) :: julian
            !! Number of days since start of julian calendar

        julian = dd-32075+1461*(yyyy+4800+(mm-14)/12)/4 + 367*(mm-2-((mm-14)/12)*12)/12- &
            3*((yyyy + 4900 + (mm - 14)/12)/100)/4

    end subroutine

    elemental subroutine julian_day_to_ymd (jd, yyyy, mm, dd)
        !! Convert a julian date (days since start of julian calendar) into year/month/day
        !! Fliegel and Van Flandern (1968) CACM 11(10):657
        !! See discussion at:
        !! https://software.intel.com/en-us/forums/intel-fortran-compiler/topic/271933
        integer,intent(in) :: jd
            !! Number of days since start of julian calendar
        integer,intent(out) :: yyyy,mm,dd
            !! year, month, day

        integer :: l,n

        l = jd + 68569
        n = 4*l/146097
        l = l - (146097*n + 3)/4
        yyyy = 4000*(l + 1)/1461001
        l = l - 1461*yyyy/4 + 31
        mm = 80*l/2447
        dd = l - 2447*mm/80
        l = mm/11
        mm = mm + 2 - 12*l
        yyyy = 100*(n - 49) + yyyy + l

    end subroutine

    elemental subroutine datetime_to_days(yyyy, mm, dd, hh, mi, ss, days, julian_origin)
        !! Get the "real number of days" since an origin date (default origin = 1970-01-01)
        !!
        integer(ip), intent(in) :: yyyy, mm, dd, hh, mi, ss
            !! Date in yyyy/mm/dd/hh/mm/ss format, where the hours is in 24hr format
        real(rp), intent(out) :: days
            !! Real "number of days since the julian_origin"
        integer(ip), optional, intent(in) :: julian_origin
            !! Optional origin for 'days' (as an integer number of days). Defaults to the
            !! julian calendar date of 1970-01-01 (=2440588) -- like R's julian() function

        integer(ip):: yyyy_l, mm_l, dd_l, hh_l, mi_l, ss_l, jd_l, jo_l

        if(present(julian_origin)) then
            jo_l = julian_origin
        else
            jo_l = julian_day_1970_01_01
        end if

        call ymd_to_julian_day(yyyy, mm, dd, jd_l)

        days = (jd_l - jo_l)

        days = days + (1.0_rp/24.0_rp)*hh + (1.0_rp/(24.0_rp*60.0_rp))*mi + &
            (1.0_rp/(24.0_rp*3600.0_rp))*ss

    end subroutine

    elemental subroutine days_to_datetime(days, yyyy, mm, dd, hh, mi, ss, julian_origin)
        !! Get the date (yyyy/mm/dd HH:MI:SS) for a given 'real number of days' from an origin date (default origin = 1970-01-01)
        !!
        real(rp), intent(in) :: days
            !! Real "number of days since the julian_origin"
        integer(ip), intent(out) :: yyyy, mm, dd, hh, mi, ss
            !! Date in yyyy/mm/dd/hh/mm/ss format, where the hours is in 24hr format
        integer(ip), optional, intent(in) :: julian_origin
            !! Optional origin for 'days' (as an integer number of days). Defaults to the
            !! julian calendar date of 1970-01-01 (=2440588) -- like R's julian() function

        integer(ip):: jo_l
        real(rp) :: fractional_days
        integer(ip) :: integer_days

        if(present(julian_origin)) then
            jo_l = julian_origin
        else
            jo_l = julian_day_1970_01_01
        end if

        integer_days = floor(days) + jo_l
        fractional_days = days - floor(days)

        if(1.0_rp - fractional_days <= 0.5_rp/(3600.0_rp*24.0_rp)) then
            ! We are within 0.5 seconds of having an extra day. This will round up
            integer_days = integer_days + 1
            fractional_days = 0.0_rp
        end if

        call julian_day_to_ymd(integer_days, yyyy, mm, dd)

        hh = floor(fractional_days*24.0_rp)
        mi = floor( (fractional_days*24.0_rp - hh)*60.0_rp )
        ss = nint(fractional_days*24.0_rp*60.0_rp*60.0_rp - hh*60.0_rp*60.0_rp - mi*60.0_rp)

        ! Deal with rounding
        if(ss == 60) then
            ss = 0
            mi = mi + 1
        end if

        if(mi == 60) then
            mi = 0
            hh = hh+1
        end if

    end subroutine

    subroutine test_date_to_numeric_mod

        integer(ip) :: yyyy, mm, dd, jd
        integer(ip) :: yyyy2(2), mm2(2), dd2(2), jd2(2)  ! Test vectorized versions
        integer(ip) :: hh2(2), mi2(2), ss2(2)
        integer(ip) :: yyyy2b(2), mm2b(2), dd2b(2), jd2b(2)  ! Test vectorized versions
        integer(ip) :: hh2b(2), mi2b(2), ss2b(2)
        real(rp) :: days(2), expected_days(2)

        ! Check leap years -- noting centuries that do not divide 400 are not leap years
        if(is_leap_year(1992) .and. is_leap_year(2000) .and. &
            (.not. is_leap_year(2100)) .and. is_leap_year(2400)) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

        ! Check start of 1970
        yyyy = 1970; mm = 01; dd = 01
        call ymd_to_julian_day(yyyy, mm, dd, jd)

        if(jd == julian_day_1970_01_01) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__
        end if

        ! Check start of 1992
        yyyy = 1992; mm = 01; dd = 01
        call ymd_to_julian_day(yyyy, mm, dd, jd)

        if(jd == julian_day_1992_01_01) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__
        end if

        ! Check vectorized versions
        yyyy2 = [1970, 1992]; mm2 = 01; dd2= 01
        call ymd_to_julian_day(yyyy2, mm2, dd2, jd2)
        if(all(jd2 == [julian_day_1970_01_01, julian_day_1992_01_01])) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__
        end if

        ! Check inverse
        call julian_day_to_ymd(jd2, yyyy2, mm2, dd2)
        if(all(yyyy2 == [1970, 1992] .and. mm2 == 01 .and. dd2 == 01)) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__
        end if

        ! Check some ad-hoc julian days, with comparison values from R's julian
        yyyy2 = [2020, 1900]
        mm2 = [07, 02]
        dd2 = [20, 15]
        hh2 = [16, 23]
        mi2 = [20, 59]
        ss2 = [31, 59]
        call datetime_to_days(yyyy2, mm2, dd2, hh2, mi2, ss2, days)
        expected_days = [18463.680914351851243_rp, -25521.000011574073142_rp] ! From R's julian()
        ! Should agree to nearest second
        if(all(abs(days - expected_days) < 0.5_rp/(24.0_rp*3600.0_rp))) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__, days, (days - expected_days)
        end if

        ! Check the inverse
        call days_to_datetime(days, yyyy2b, mm2b, dd2b, hh2b, mi2b, ss2b)
        if(all(yyyy2b == yyyy2 .and. mm2b == mm2 .and. dd2b == dd2 .and. hh2b == hh2 .and. mi2b == mi2 .and. ss2b == ss2)) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__, &
                yyyy2b, mm2b, dd2b, hh2b, mi2b, ss2b
        end if

        ! Check the dates
        call check_datetime(yyyy2(1), mm2(1), dd2(1), hh2(1), mi2(1), ss2(1))
        call check_datetime(yyyy2(1), mm2(1), dd2(1))
        call check_datetime(yyyy2(2), mm2(2), dd2(2), hh2(2), mi2(2), ss2(2))
        call check_datetime(yyyy2(2), mm2(2), dd2(2))

        ! More ad-hoc checks -- large/small dates
        yyyy2 = [3000, 0001]
        call datetime_to_days(yyyy2, mm2, dd2, hh2, mi2, ss2, days)
        expected_days = [376400.68091435183305_rp, -719116.00001157412771_rp]

        ! Should agree to nearest second
        if(all(abs(days - expected_days) < 0.5_rp/(24.0_rp*3600.0_rp))) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__, days, (days - expected_days)
        end if

        ! Check rounding -- take a day within < 1/2 second of 1970-01-01.
        days = julian_day_1970_01_01 - 0.4_rp/(3600.0_rp * 24.0_rp)
        call days_to_datetime(days, yyyy2, mm2, dd2, hh2, mi2, ss2, julian_origin = [0, 0])
        if(all(yyyy2 == 1970 .and. dd2 == 01 .and. mm2 == 01 .and. hh2 == 00 .and. mi2 == 00 .and. ss2 == 00)) then
            print*, 'PASS'
        else
            print*, 'FAIL', __LINE__, yyyy2, dd2, mm2, hh2, mi2, ss2
        end if

    end subroutine

end module


*$ Section 3: Map utlitity routines
*  --------------------------------

*+ invtan

       real function invtan(x,y)
C      -------------------------
C
C Do an Inverse Tangent taking care of zeros and quadrants
C
C Input
C   X,Y        -      R*4       -    two values for arctan(X/Y)
C
C Returned
C   INVTAN     -      via routine name - arctan(X/Y)
C
*-
       real*4    x, y
       real*4    eps, half_pi

       eps = 1.0e-05
       half_pi = 1.5707963268e+00
       if (abs(y).gt.eps) then
         invtan = atan2(x,y)
       else
         invtan = sign(half_pi,x)
       end if

       end


	FUNCTION PT_PATN  ( actp )
C************************************************************************
C* PT_PATN								*
C*									*
C* This function converts a PIREP alphanumeric aircraft type (up to four*
C* characters in length) to a real number, ATPN:                        *
C*                                                                      *
C*			ATPN = PT_PATN ( ACTP )                         *
C*                                                                      *
C* If the aircraft type is more than four characters long, the first    *
C* four characters will be used, unless the type contains an embedded   *
C* '/'.  If the type contains an embedded '/', the longer of the fields *
C* on either side of the '/' (to a maximum of four characters) is used. *
C* The range of values which might result is 0 to 2559999.              *
C*									*
C* REAL PT_PATN  ( ACTP )                                                    *
C*									*
C* Input parameters:                                                    *
C*	ACTP		CHAR*		Character aircraft type string  *
C*									*
C* Output parameters:							*
C*	PT_PATN     	REAL 		GEMPAK aircraft type number     *
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 1/00	                                        *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	actp
C*
	REAL		fnum (4)
C-----------------------------------------------------------------------
	PT_PATN  = RMISSD
C
	DO i = 1, 4
	    fnum ( i ) = 0.
	END DO
	ich = 1
	ist = 1
C
	CALL ST_LSTR ( actp, lens, ier )
	IF ( lens .gt. 4 ) THEN
	    islsh = INDEX ( actp ( :lens ), '/' )
	    IF ( islsh .eq. 0 ) THEN
		lens = 4
	      ELSE
C
C*		Choose the longer of 2 fields separated by '/'.
C
	        len1  = islsh - 1
	        len2  = lens - islsh
		IF ( len1 .eq. len2 ) THEN
		    lens = len1
		  ELSE
		    IF ( len1 .gt. len2 ) THEN
			lens = len1
			ioff = 0
		      ELSE
			lens = len2
			ioff = islsh
		    END IF
		    IF ( lens .gt. 4 ) lens = 4
		    ist  = ioff + 1
		    lens = ioff + lens
		END IF
	    END IF
	END IF
C
	DO ii = ist, lens
	    iv = ICHAR ( actp ( ii:ii ) )
	    IF ( ( iv .ge. 45 ) .and. ( iv .le. 57 ) ) THEN
C
C*	        The character is '-', '.', '/', or '0' through '9'.
C*	        Map it to 1 to 13.
C
	        fnum ( ich ) = iv - 44
	      ELSE IF ( ( iv .ge. 65 ) .and. ( iv .le. 90 ) ) THEN
C
C*	        The character is 'A' through 'Z'.
C*	        Map it to 14 to 39.
C
	        fnum ( ich ) = iv - 51
	      ELSE
C
C*	        The character is not in the valid subset.
C*	        Map it to 3 ('/').
C
	        fnum ( ich ) = 3.
	    END IF
	    ich = ich + 1
C
	    IF ( ii .eq. lens ) THEN
	        PT_PATN  = fnum ( 4 ) * 40 * 40 * 40 +
     +		           fnum ( 3 ) * 40 * 40 +
     +	                   fnum ( 2 ) * 40 + fnum ( 1 )
	    END IF
	END DO
C*
	RETURN
	END


!*******************************************************************************
!>  @file siesta_pressure.f90
!>  @brief Contains module @ref siesta_pressure
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Updates pressure.
!*******************************************************************************

      MODULE siesta_pressure
      USE v3_utilities, ONLY: assert
      USE stel_kinds
      USE stel_constants
      USE quantities
      USE nscalingtools, ONLY: startglobrow, endglobrow
      USE utilities, ONLY: GradientHalf, to_half_mesh

      IMPLICIT NONE

      CONTAINS

!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief advance pressure on the half radial grid from t to t + delta_t.
!>
!>  Changes in pressure are governed by the continuity equation.
!>
!>     dn/dt + Div(nv) = dn/dt + n*Div(v) + v.Grad(n) = 0                    (1)
!>
!>  where n is the density and v is the velocity. From the adiabatic principle,
!>
!>     pV^gamma = Constant                                                   (2)
!>
!>  where p is the pressure and V is the volume. From the ideal gas law V scales
!>  as V ~ 1/n. Using this equation (2) can be rewritten in terms of
!>
!>     p/n^gamma = Constant                                                  (3)
!>
!>  Putting equation (3) into equation (1), the continuty equation can be
!>  written in terms of the pressure.
!>
!>     dp/dt + gamma*p*Div(v) + v.Grad(p) = 0                                (4)
!>
!>  Using the idenity
!>
!>     Div(fA) = f*Div(A) + A.Grad(f)                                        (5)
!>
!>  equation (4) can be written as.
!>
!>     dp/dt = (gamma - 1)v.Grad(p) - gamma*Div(pv)                          (6)
!>
!>  This leads to equation (2.3) in Hirshman et. al. doi:10.1063/1.3597155.
!>  Expanding out equation (6) gives
!>
!>     dp/dt = (gamma - 1)*(v^s*dp/ds + v^u*dp/du + v^v*dp/dv)               (7)
!>           - gamma/J*(dJpv^s/ds + dJpv^u/du + dJpv^v/dv)
!-------------------------------------------------------------------------------
      SUBROUTINE update_pres
      USE timer_mod, ONLY: time_update_pres
      USE fourier, ONLY: f_cos, f_sin, f_sum, f_du, f_dv
      USE quantities, ONLY: gvsupumnsf => fsupumnsf, gvsupvmnsf => fsupvmnsf,  &
                            gvsupumncf => fsupumncf, gvsupvmncf => fsupvmncf
      USE utilities, ONLY: set_bndy_fouier_m0, m0
      USE shared_data, ONLY: delta_t
      USE island_params, ONLY: fourier_context

      IMPLICIT NONE

!  local variables
      INTEGER                                  :: istat
      REAL (dp)                                :: ton
      REAL (dp)                                :: toff
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: jvsupuijh
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: jvsupvijh
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: workij1
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: workij2
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: workij3
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: workmn4
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: workmn5
      REAL (dp), DIMENSION(:,:,:), ALLOCATABLE :: vgradph
      INTEGER                                  :: nsmin
      INTEGER                                  :: nsmax

!  local parameters
!  Does not work well, keep it off.
      LOGICAL, PARAMETER                       :: l_upwind = .FALSE.

!  Start of executable code
      CALL second0(ton)
      nsmin = MAX(1, startglobrow - 1)
      nsmax = MIN(ns, endglobrow + 1)

!  Compute first term ~(gamma-1)V * grad(p) on r.h.s. of pressure equation the
!  u,v derivatives should be consistent with div(pv) term and combine to cancel
!  if div(V) = 0
      ALLOCATE(workij1(ntheta,nzeta,nsmin:nsmax),                              &
               workij2(ntheta,nzeta,nsmin:nsmax),                              &
               workij3(ntheta,nzeta,nsmin:nsmax),                              &
               vgradph(ntheta,nzeta,nsmin:nsmax),  stat=istat)
      CALL assert_eq(0, istat, 'Allocation1 failed in update_pres')

      ALLOCATE(workmn4(0:mpol,-ntor:ntor,nsmin:nsmax),                         &
               workmn5(0:mpol,-ntor:ntor,nsmin:nsmax))
      CALL assert_eq(0, istat, 'Allocation2 failed in update_pres')

      ALLOCATE (jvsupuijh(ntheta,nzeta,nsmin:nsmax),                           &
                jvsupvijh(ntheta,nzeta,nsmin:nsmax), stat=istat)
      CALL assert_eq(0, istat, 'Allocation3 failed in update_pres')

!  On exit, jsupXh valid on [nsmin+1:nsmax]
      CALL to_half_mesh(jvsupuijf, jvsupuijh)
      CALL to_half_mesh(jvsupvijf, jvsupvijh)

!  On exit, vgradph is valid on [nsmin+1:nsmax]. Mixed half/full form: Diagonal
!  in angular derivatives. Exactly cancel Div(pV) term when div(V) = 0.
      workij1 = pijf0_ds(:,:,nsmin:nsmax)*jvsupsijf(:,:,nsmin:nsmax)
      CALL to_half_mesh(workij1, vgradph)
      vgradph = vgradph                                                        &
              + jvsupuijh(:,:,nsmin:nsmax)*pijh0_du(:,:,nsmin:nsmax)           &
              + jvsupvijh(:,:,nsmin:nsmax)*pijh0_dv(:,:,nsmin:nsmax)

!  d/ds Jv^s
      workij2(:,:,nsmin:nsmax) = jvsupsijf(:,:,nsmin:nsmax)

!      IF (nsmin .EQ. 1) THEN
!  Enforce bc at origin in Div(pv) term.
!         workij2(:,:,1) = 0
!      END IF

      CALL GradientHalf(workij1, workij2)

!  Get djvsupudu and djvsupvdv. d/du Jv^u and d/dv Jv^v
      CALL to_half_mesh(gvsupumnsf, workmn4)
      CALL to_half_mesh(gvsupvmnsf, workmn5)

      CALL set_bndy_fouier_m0(workmn4, f_sin)
      CALL set_bndy_fouier_m0(workmn5, f_sin)

      CALL fourier_context%toijsp(workmn4(:,:,nsmin:nsmax),                    &
                                  workij2(:,:,nsmin:nsmax), f_du, f_sin)
      CALL fourier_context%toijsp(workmn5(:,:,nsmin:nsmax),                    &
                                  workij3(:,:,nsmin:nsmax), f_dv, f_sin)
      IF (lasym) THEN
         CALL to_half_mesh(gvsupumncf, workmn4)
         CALL to_half_mesh(gvsupvmncf, workmn5)

         CALL set_bndy_fouier_m0(workmn4, f_cos)
         CALL set_bndy_fouier_m0(workmn5, f_cos)

         CALL fourier_context%toijsp(workmn4(:,:,nsmin:nsmax),                 &
                                     workij2(:,:,nsmin:nsmax),                 &
                                     IOR(f_du, f_sum), f_cos)
         CALL fourier_context%toijsp(workmn5(:,:,nsmin:nsmax),                 &
                                     workij3(:,:,nsmin:nsmax),                 &
                                     IOR(f_dv, f_sum), f_cos)
      END IF

      nsmin = MAX(2, startglobrow)

!  First half of the pressure variation.
!  gamma*p*d/ds Jv^s + gamma*p*d/du Jv^u + gamma*p*d/dv Jv^v
      workij1(:,:,nsmin:nsmax) = gamma*pijh0(:,:,nsmin:nsmax)                  &
                               * (workij1(:,:,nsmin:nsmax) +                   &
                                  workij2(:,:,nsmin:nsmax) +                   &
                                  workij3(:,:,nsmin:nsmax))

!  Second half the the pressure variation.
!  J dp/dt = -Jv^s d/ds p - Jv^u d/du -Jv^v d/dv
!          - gamma*p*d/ds Jv^s + gamma*p*d/du Jv^u + gamma*p*d/dv Jv^v
      workij1(:,:,nsmin:nsmax) = -vgradph(:,:,nsmin:nsmax)                     &
                               - workij1(:,:,nsmin:nsmax)

!  Convert to Fourier space.
      CALL fourier_context%tomnsp(workij1(:,:,nsmin:nsmax),                    &
                                  djpmnch(:,:,nsmin:nsmax), f_cos)
      djpmnch(:,:,nsmin:nsmax) = delta_t*djpmnch(:,:,nsmin:nsmax)
      IF (lasym) THEN
         CALL fourier_context%tomnsp(workij1(:,:,nsmin:nsmax),                 &
                                     djpmnsh(:,:,nsmin:nsmax), f_sin)
         djpmnsh(:,:,nsmin:nsmax) = delta_t*djpmnsh(:,:,nsmin:nsmax)
      END IF

      IF (startglobrow .eq. 1) THEN
         djpmnch(:,:,1) = 0

         IF (lasym) THEN
            djpmnsh(:,:,1) = 0
         END IF
      END IF

      DEALLOCATE(workij1, workij2, workij3, vgradph)
      DEALLOCATE(workmn4, workmn5)

      CALL second0(toff)
      time_update_pres = time_update_pres + (toff - ton)

      END SUBROUTINE update_pres

      END MODULE


      SUBROUTINE fft99b(work, a, trigs, inc, jump, n, lot)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER inc, jump, n, lot
      REAL(rprec), DIMENSION(*) :: work, a, trigs
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER::nh,nx,ink,ia,ib,ja,jb,l,iabase,ibbase,jabase,jbbase,k
      REAL(rprec) :: scale, c, s
C-----------------------------------------------
c
c     SUBROUTINE fft99b - postprocessing step for fft99, isign=-1
c     (gridpoint to spectral transform)
c
      nh=n/2
      nx=n+1
      ink=inc+inc
c
c     a(0) and a(n/2)
      scale = one/n
      ia=1
      ib=2
      ja=1
      jb=n*inc+1
cdir$ ivdep
      DO 10 l=1,lot
      a(ja)=scale*(work(ia)+work(ib))
      a(jb)=scale*(work(ia)-work(ib))
      a(ja+inc) = zero
      a(jb+inc) = zero
      ia=ia+nx
      ib=ib+nx
      ja=ja+jump
      jb=jb+jump
   10 CONTINUE
c
c     remaining wavenumbers
      scale=0.5_dp*scale
      iabase=3
      ibbase=n-1
      jabase=2*inc+1
      jbbase=(n-2)*inc+1
c
      DO 30 k=3,nh,2
      ia=iabase
      ib=ibbase
      ja=jabase
      jb=jbbase
      c=trigs(n+k)
      s=trigs(n+k+1)
cdir$ ivdep
      DO 20 l=1,lot
      a(ja)=scale*((work(ia)+work(ib))
     *   +(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
      a(jb)=scale*((work(ia)+work(ib))
     *   -(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
      a(ja+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1)))
     *    +(work(ib+1)-work(ia+1)))
      a(jb+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1)))
     *    -(work(ib+1)-work(ia+1)))
      ia=ia+nx
      ib=ib+nx
      ja=ja+jump
      jb=jb+jump
   20 CONTINUE
      iabase=iabase+2
      ibbase=ibbase-2
      jabase=jabase+ink
      jbbase=jbbase-ink
   30 CONTINUE
c
      IF (iabase.ne.ibbase) GOTO 50
c     wavenumber n/4 (IF it exists)
      ia=iabase
      ja=jabase
      scale=2*scale
cdir$ ivdep
      DO 40 l=1,lot
      a(ja)=scale*work(ia)
      a(ja+inc)=-scale*work(ia+1)
      ia=ia+nx
      ja=ja+jump
   40 CONTINUE
c
   50 CONTINUE

      END SUBROUTINE fft99b


module intersect_bbox
use math, only: norm
implicit none

private
public :: dummy_bi
public :: bboxes_intersect, bbox_intersects_plane

contains

subroutine dummy_bi()
    !> Dummy routine for f2py.
end subroutine dummy_bi

function bboxes_intersect(k, bbox1, bbox2, tol) result(intersects)
    !> Test if the bounding boxes intersect.
    !> k - Dimensions of bounding box.
    !> bbox1 - Bounding box 1.
    !> bbox2 - Bounding box 2.
    !> tol - Tolerance for bounding boxes.
    !> intersects - True is boxes intersect, False if not.

    ! Input
    integer, intent(in) :: k
    double precision, intent(in) :: tol
    double precision, intent(in) :: bbox1(k, 2), bbox2(k, 2)

    ! Output
    logical :: intersects

    ! Working
    integer :: i
    double precision :: bbox1_(k, 2), bbox2_(k, 2)

    ! Adjust bounding boxes by the tolerance.
    do i = 1, k
        bbox1_(i, 1) = bbox1(i, 1) - tol
        bbox1_(i, 2) = bbox1(i, 2) + tol
        bbox2_(i, 1) = bbox2(i, 1) - tol
        bbox2_(i, 2) = bbox2(i, 2) + tol
    end do

    intersects = .true.
    do i = 1, k
        if ((bbox1_(i, 1) .gt. bbox2_(i, 2)) .or. (bbox2_(i, 1) .gt. bbox1_(i, 2))) then
            intersects = .false.
            return
        end if
    end do

end function bboxes_intersect

function bbox_intersects_plane(bbox, p0, pnorm, tol) result(intersects)
    !> Test if the bounding box intersects a plane.
    !> bbox - Bounding box.
    !> p0 - Origin point of plane.
    !> pnorm - Unit normal vector of plane.
    !> tol - Tolerance for bounding boxes.
    !> intersects - True if box is intersected by plane, False if not.

    ! Input
    double precision, intent(in) :: tol
    double precision, intent(in) :: bbox(0:2, 0:1)
    double precision, intent(in) :: p0(0:2)
    double precision, intent(in) :: pnorm(0:2)

    ! Output
    logical :: intersects

    ! Working
    integer :: i
    double precision :: d, r
    double precision :: cg(0:2), v(0:2)
    double precision :: bbox_(0:2, 0:1)

    ! Adjust bounding boxes by the tolerance.
    do i = 0, 2
        bbox_(i, 0) = bbox(i, 0) - tol
        bbox_(i, 1) = bbox(i, 1) + tol
        ! Centroid and diameter vector.
        cg(i) = (bbox_(i, 0) + bbox_(i, 1)) / 2.0d0
        v(i) = bbox_(i, 1) - bbox_(i, 0)
    end do

    ! Radius of bounding box.
    r = norm(v) / 2.0d0

    ! Distance from cg to plane.
    d = dabs(dot_product(pnorm, cg - p0))

    intersects = .false.
    if (d .le. r) then
        intersects = .true.
    end if

end function bbox_intersects_plane

end module intersect_bbox


      subroutine confun(x, n, m, res, a, la, user, iuser, flag)

      use nonlin_types
      implicit none

        INCLUDE 'SLPCOMM.INC'

      integer n, m, iuser(*), la(0:*)
      double precision x(n), res(m), a(*), user(*)
      integer flag

      integer i, j
      integer n_lt, n_nt, p_lti, p_nti, p_ltd, p_ntd, pcsi, pcsu,
     &     ix1, ix2

      include 'pusr.inc'

c     for all constraints apart of the nonlinear ones
      do i=1,m-NLD%n_cs
         res(i) = 0.d0

         pcsi = iuser(pi_cs_pi+i)
         pcsu = iuser(pi_cs_pu+i)

         n_lt  = iuser(pcsi)
         n_nt  = iuser(pcsi+1)
         p_lti = iuser(pcsi+2)
         p_nti = iuser(pcsi+3)
         p_ltd = iuser(pcsi+4)
         p_ntd = iuser(pcsi+5)

         do j=1,n_lt
            ix1 = iuser(p_lti+j-1)
            res(i) = res(i) + user(p_ltd+j-1)*x(ix1)
         end do

         do j=1,n_nt
            ix1 = iuser(p_nti+2*j-2)
            ix2 = iuser(p_nti+2*j-1)
            res(i) = res(i) + user(p_ntd+j-1)*x(ix1)*x(ix2)
         end do

      end do

      do i=1,NLD%n_cs
         res(m-NLD%n_cs+i) = eval_nl_cs(NLD%root(i)%p, x)
      end do

c      do i=1,m
c         print *, i, res(i)
c      end do

      end


C
C $Id: radddp.f,v 1.5 2008-07-27 00:17:12 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE RADDDP (RAD,SGNA,DEGS,MINS,SECS)
C
C SUBROUTINE TO CONVERT ANGLE FROM RADIANS TO SIGNED DMS
C SGNA : SIGN OF ANGLE
C DEGS : DEGREES PORTION OF ANGLE
C MINS : MINUTES PORTION OF ANGLE
C SECS : SECONDS PORTION OF ANGLE
C
      DOUBLE PRECISION RAD,CON,RADSEC,ZERO,TOL
      REAL SECS
      INTEGER DEGS,MINS
      CHARACTER*1 SGNA,BLANK,NEG
      DATA RADSEC /206264.806247D0/
      DATA ZERO,TOL /0.0D0,1.0D-4/
      DATA BLANK,NEG /' ','-'/
C
C CONVERT THE ANGLE TO SECONDS.
C
      CON = ABS(RAD) * RADSEC
      ISEC = INT(CON + TOL)
C
C DETERMINE THE SIGN OF THE ANGLE.
C
      SGNA = BLANK
      IF (RAD .LT. ZERO .AND. CON .GE. 0.00005D0) SGNA = NEG
      IF (CON .LT. 0.00005D0) CON = ZERO
C
C COMPUTE DEGREES PART OF THE ANGLE.
C
      INTG = ISEC / 3600
      DEGS = INTG
      ISEC = INTG * 3600
      CON = CON - ISEC
      ISEC = INT(CON + TOL)
C
C COMPUTE MINUTES PART OF THE ANGLE.
C
      MINS = ISEC / 60
      ISEC = MINS * 60
      CON = CON - ISEC
C
C COMPUTE SECONDS PART OF THE ANGLE.
C
      SECS = CON
C
C     INCREASE MINS IF SECS CLOSE TO 60.000
C
      IF(SECS .LT. 59.9995D0) RETURN
      MINS = MINS + 1
      SECS = 0.0
C
C     INCREASE DEGS IF MINS EQUAL 60
C
      IF(MINS .LE. 59) RETURN
      MINS = 0
      DEGS = DEGS + 1
C
      RETURN
      END


        program matrix_gen
        integer*4 i, k
        double precision amat(8,8), xvec(8), bvec(8)
        integer *4 irow(8), icol(8*8)
        integer*4 timeArray(3), ei,sf;
        open (unit = 8, file = "matrix.bin")
        ei = 8
        sf = 64
        do i = 1, 8
          do k = 1, 8
            do n=1,100000
              call itime(timeArray)
              amat(i,k) = amat(i,k) + 1212.12*
     &              rand(timeArray(1)/(timeArray(2)+timeArray(3)))
            end do
            call itime(timeArray)
            amat(i,k) = amat(i,k)+rand ( timeArray(1)+timeArray(2)+
     &                      timeArray(3))
          end do
          call itime(timeArray)
          xvec(i) = rand ( timeArray(1)+timeArray(2)+timeArray(3) )
        end do
        do i = 1,8
          bvec(i)=0D0
          irow(i)=(i-1)*8+1
          do k =1, 8
            bvec(i) = bvec(i)+xvec(k)*amat(i,k)
            icol((i-1)*8+k)=i
          end do
        end do
        write(8,*) ei
        write(8,*) sf
        write(8,*) amat
        write(8,*) irow
        write(8,*) icol
        write(8,*) xvec
        close(8)
        write(6,*) 'amat =', amat
        write(6,*) 'xvec =', xvec
        write(6,*) 'bvec=', bvec
        write(6,*) 'irow=', irow
        write(6,*) 'icol=', icol
        stop
        end


      SUBROUTINE INTX (EL1,EL2,B,IJ,SGR,SGI)
C
C     INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF
C     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION.  THE INTEGRAND VALUE
C     IS SUPPLIED BY SUBROUTINE GF.
C
      DATA NX,NM,NTS,RX/1,65536,4,1.E-4/
      Z=EL1
      ZE=EL2
      IF (IJ.EQ.0) ZE=0.
      S=ZE-Z
      FNM=NM
      EP=S/(10.*FNM)
      ZEND=ZE-EP
      SGR=0.
      SGI=0.
      NS=NX
      NT=0
      CALL GF (Z,G1R,G1I)
1     FNS=NS
      DZ=S/FNS
      ZP=Z+DZ
      IF (ZP-ZE) 3,3,2
2     DZ=ZE-Z
      IF (ABS(DZ)-EP) 17,17,3
3     DZOT=DZ*.5
      ZP=Z+DZOT
      CALL GF (ZP,G3R,G3I)
      ZP=Z+DZ
      CALL GF (ZP,G5R,G5I)
4     T00R=(G1R+G5R)*DZOT
      T00I=(G1I+G5I)*DZOT
      T01R=(T00R+DZ*G3R)*0.5
      T01I=(T00I+DZ*G3I)*0.5
      T10R=(4.0*T01R-T00R)/3.0
      T10I=(4.0*T01I-T00I)/3.0
C
C     TEST CONVERGENCE OF 3 POINT ROMBERG RESULT.
C
      CALL TEST (T01R,T10R,TE1R,T01I,T10I,TE1I,0.)
      IF (TE1I-RX) 5,5,6
5     IF (TE1R-RX) 8,8,6
6     ZP=Z+DZ*0.25
      CALL GF (ZP,G2R,G2I)
      ZP=Z+DZ*0.75
      CALL GF (ZP,G4R,G4I)
      T02R=(T01R+DZOT*(G2R+G4R))*0.5
      T02I=(T01I+DZOT*(G2I+G4I))*0.5
      T11R=(4.0*T02R-T01R)/3.0
      T11I=(4.0*T02I-T01I)/3.0
      T20R=(16.0*T11R-T10R)/15.0
      T20I=(16.0*T11I-T10I)/15.0
C
C     TEST CONVERGENCE OF 5 POINT ROMBERG RESULT.
C
      CALL TEST (T11R,T20R,TE2R,T11I,T20I,TE2I,0.)
      IF (TE2I-RX) 7,7,14
7     IF (TE2R-RX) 9,9,14
8     SGR=SGR+T10R
      SGI=SGI+T10I
      NT=NT+2
      GO TO 10
9     SGR=SGR+T20R
      SGI=SGI+T20I
      NT=NT+1
10    Z=Z+DZ
      IF (Z-ZEND) 11,17,17
11    G1R=G5R
      G1I=G5I
      IF (NT-NTS) 1,12,12
12    IF (NS-NX) 1,1,13
C
C     DOUBLE STEP SIZE
C
13    NS=NS/2
      NT=1
      GO TO 1
14    NT=0
      IF (NS-NM) 16,15,15
15    PRINT 20, Z
      GO TO 9
C
C     HALVE STEP SIZE
C
16    NS=NS*2
      FNS=NS
      DZ=S/FNS
      DZOT=DZ*0.5
      G5R=G3R
      G5I=G3I
      G3R=G2R
      G3I=G2I
      GO TO 4
17    CONTINUE
      IF (IJ) 19,18,19
C
C     ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM
C
18    SGR=2.*(SGR+ALOG((SQRT(B*B+S*S)+S)/B))
      SGI=2.*SGI
19    CONTINUE
      RETURN
C
20    FORMAT (24H STEP SIZE LIMITED AT Z=,F10.5)
      END


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine genprp                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.3
!  Written by Gordon A. Fenton, DalTech, Jan 31, 2001
!  Latest Update: Feb 22, 2005
!
!  PURPOSE  generates final soil property fields
!
!  DESCRIPTION
!  This routine sets the final soil property fields. In the event that
!  the soil property field follows a normal, lognormal, or bounded
!  distribution, this involves a transformation from the underlying
!  normally distributed field. If the soil property is deterministic,
!  this routine sets the entire field to the provided `mean' value. If
!  the soil property is a function of phi, this routine sets the field
!  to the required function.
!
!  ARGUMENTS
!
!    pfld	real array of size at least (nxe x nye) which, on output,
!		will contain the final soil property field. (output)
!
!       p	real vector of length at least 7 containing the statistics
!		of the soil property field. In particular,
!		   p(1) = soil property mean
!		   p(2) = soil property standard deviation,
!		   p(3) = soil property distribution type;
!			  = 0.0 if property is deterministic (at mean value)
!			  = 1.0 if property is normally distributed
!			  = 2.0 if property is lognormally distributed (logn)
!			  = 3.0 if property is bounded
!			  = 4.0 if property is a function of phi
!		   p(4) = lower bound (bounded), or mean log-property (logn),
!			  or constant in functional relationship (f(phi))
!		   p(5) = upper bound (bounded), or sd of log-property (logn),
!			  or slope in functional relationship (f(phi))
!		   p(6) = m parameter (if bounded), or function type (f(phi))
!			  where in the last case,
!				p(6) = 0.0 for 1*phi
!				p(6) = 1.0 for sin(phi)
!				p(6) = 2.0 for tan(phi)
!		   p(7) = s parameter (if bounded)
!         If the soil property is bounded or functional, then p(1) and
!		p(2) are ignored and the parameters c(4) through c(7)
!		completely describe the distribution (or function). (input)
!
!  phifld	real array of size at least (nxe x nye) which is assumed to
!		contain the friction angle soil property field. Ensure that
!		this is set before calling this routine since it is used
!		here in the event that the soil property is a function
!		of phi. (input)
!
!    nrfx	integer giving the number of elements describing the random
!		fields pfld and phifld in the x-direction (horizontally).
!		(input)
!
!    nrfy	integer giving the number of elements describing the random
!		fields pfld and phifld in the y-direction (vertically).
!		(input)
!
!  ltanfi	logical flag which is true if phifld contains the tan(phi)
!		random field, rather than phi directly. (input)
!
!  REVISION HISTORY:
!  1.1	correctly set twopt5 = 2.5 (Sep 12/01)
!  1.2	allow for phifld to contain tan(phi) field (Aug 14/02)
!  1.3	reordered numbering of f(phi) function types (0=1,1=sin,2=tan)
!	(Feb 22/05)
!-------------------------------------------------------------------------
      subroutine genprp(pfld,p,phifld,nrfx,nrfy,ltanfi)
      real pfld(nrfx,*), p(*), phifld(nrfx,*)
      integer nrfx, nrfy
      logical ltanfi
      data half/0.5/, one/1.0/, onept5/1.5/, twopt5/2.5/, thrpt5/3.5/
      data twopi/6.2831853071795864769/		! 2*pi
      data deg2rad/0.0174532925199/		! pi/180

      if( p(3) .lt. half ) then			! deterministic
         do 10 j = 1, nrfy
         do 10 i = 1, nrfx
            pfld(i,j) = p(1)
  10     continue
      elseif( p(3) .lt. onept5 ) then		! normal
         do 20 j = 1, nrfy
         do 20 i = 1, nrfx
            pfld(i,j) = p(1) + p(2)*pfld(i,j)
  20     continue
      elseif( p(3) .lt. twopt5 ) then		! lognormal
         do 30 j = 1, nrfy
         do 30 i = 1, nrfx
            pfld(i,j) = exp( p(4) + p(5)*pfld(i,j) )
  30     continue
      elseif( p(3) .lt. thrpt5 ) then		! bounded
         do 40 j = 1, nrfy
         do 40 i = 1, nrfx
            pfld(i,j) = p(4) + half*(p(5)-p(4))                           &
                *( one + tanh((p(6)+p(7)*pfld(i,j))/twopi) )
  40     continue
      else					! f(phi)
         if( p(6) .lt. half ) then		! prop = p(4)+p(5)*phi
            do 50 j = 1, nrfy
            do 50 i = 1, nrfx
               if( ltanfi ) then
                  ang = atan(phifld(i,j))/deg2rad ! angle in degrees
               else
                  ang = phifld(i,j)
               endif
               pfld(i,j) = p(4) + p(5)*ang
  50        continue
         elseif( p(6) .lt. onept5 ) then	! prop = p(4)+p(5)*sin(phi)
            do 60 j = 1, nrfy
            do 60 i = 1, nrfx
               if( ltanfi ) then
                  ang = atan(phifld(i,j))	! angle in radians
               else
                  ang = deg2rad*phifld(i,j)
               endif
               pfld(i,j) = p(4) + p(5)*sin(ang)
  60        continue
         elseif( p(6) .lt. twopt5 ) then	! prop = p(4)+p(5)*tan(phi)
            do 70 j = 1, nrfy
            do 70 i = 1, nrfx
               if( ltanfi ) then
                  ang = phifld(i,j)
               else
                  ang = tan(deg2rad*phifld(i,j))
               endif
               pfld(i,j) = p(4) + p(5)*ang
  70        continue
         endif
      endif

      return
      end