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

*   Test implicit type conversions between numerical types
*   in DATA statements:

      BLOCK DATA
      implicit double precision (d-f)
      implicit complex (r-t)

      common /ic/ i, j, k, x, y, z, d, e, f, r , s, t

      data i, j, k / 2.3, 5D2, (3.2, 1.0) / ,
     =     x, y, z / 15, -3.2d-5, (-3.2, -1.0) / ,
     a     d, e, f / -3, 2.3, (3.2, 1.0) / ,
     Z     r, s, t / 99999, -2.3, 5d2    /
      end

      program p

      common /ic/ rslts(18)

      integer expect(18)
      real    rexpect(15)
      equivalence (expect(4), rexpect(1))
      double precision  dexpect(3)
      equivalence (expect(7), dexpect(1))

c  set up expected results for tests 1 - 3 (integer):

      data (expect(i), i = 1, 3) / 2, 500, 3/

c  set up expected results for tests 4 - 6 (real):

      data (rexpect(i), i = 1, 3) /15.0, -3.2e-5, -3.2 /

c  set up expected results for tests 7 - 12 (double):

      data x, y, z / -3.0e0, 2.3e0, 3.2e0 /
      dexpect(1) = x
      dexpect(2) = y
      dexpect(3) = z

c  set up expected results for tests 13 - 18 (complex):

      data (rexpect(i), i = 10, 15) /
     +        99999.0, 0.0,     -2.3, 0.0,     5e2, 0.0 /

c  compare results and expected arrays:

      call check(rslts, expect, 18)
      end


module randmod

contains

	double precision function random(seed, iseed)

		! This function generates a random real number
		! between 0 and 1.

		implicit none

		integer, dimension(8) :: values
		integer :: iseed, t

		logical :: seed
		logical, save :: init = .false.

		if (.not. init) then
			init = .true.

			call date_and_time(values = values)

			!print *, 'values = ', values

			t = values(8) + 1000 * (values(7) + 60 * (values(6) + 60 &
			 * (values(5) + 24 * values(3))))

			!print *, 't = ', t

			if (seed) then
				call srand(iseed)
			else
				call srand(t)
			end if

		end if

		random = rand()

	end function random

end module randmod


program test_parse_ants
use iso_fortran_env
use parse_ants, only: process_line
use common, only: pi
implicit none

integer, parameter :: maxlen = 4096
character(len=maxlen) :: line
integer :: unit, iostat
real(8) :: v_par, v_perp, u, v, s

open(newunit=unit, file='launch_0.3')

read(unit, '(A)', iostat=iostat) line  ! Skip header
do  ! Read and parse every line
    read(unit, '(A)', iostat=iostat) line
    call process_line(line, v_par, v_perp, u, v, s)
    if(is_iostat_end(iostat)) exit
    print *, s, 2d0*pi*u, 2d0*pi*v, v_par, v_perp
end do

close(unit)
end program test_parse_ants


program copy_test
    implicit none
    integer, parameter :: v_size = 10
    integer :: i
    real, dimension(v_size) :: vector1 = [ (real(i), i=1, v_size) ], vector2
    real, dimension(2*v_size) :: large_vector

    print '(A20, *(F5.1))', 'original: ', vector1
    vector2 = 0.0
    large_vector = 0.0
    call scopy(size(vector1), vector1, 1, vector2, 1)
    print '(A20, *(F5.1))', 'copy N 1 1: ', vector2

    vector2 = 0.0
    call scopy(size(vector1), vector1, 1, vector2, 2)
    print '(A20, *(F5.1))', 'copy N 1 2: ', vector2

    vector2 = 0.0
    call scopy(size(vector1), vector1, 2, vector2, 1)
    print '(A20, *(F5.1))', 'copy N 2 1`: ', vector2

    vector2 = 0.0
    call scopy(size(vector1), vector1, 2, vector2, 2)
    print '(A20, *(F5.1))', 'copy N 2 2`: ', vector2

    large_vector = 0.0
    call scopy(size(vector1), vector1, 1, large_vector, 2)
    print '(A20, *(F5.1))', 'copy N 1 2`: ', large_vector
    call scopy(size(vector1), 3.0*vector1, 1, large_vector(2), 2)
    print '(A20, *(F5.1))', 'shift copy N 1 2`: ', large_vector

end program copy_test


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for ARG2
C     ----------------------------------------------
      INTEGER I
      DOUBLE PRECISION ANGLE_REF(11), ANGLE(11)
      DATA (ANGLE_REF(I),I=1,11) /
     .   2.849663065753787805D0,
     .   6.28318080000000023D0,
     .   4.926040134021299366D0,
     .   1.608450491115348768D0,
     .   2.375021572352622456D0,
     .   0.4746414933980958040D0,
     .   3.908159227647345801D0,
     .   2.551018561669245344D0,
     .   5.041990012540757959D0,
     .   4.206816878908014701D0,
     .   1.608463638294885811D0/

C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> ARG2 Results'
      PRINT *, '----------------------------------------'

      CALL ARG2(2008, 311.5D0, ANGLE)
      DO 500 I = 1, 11
        WRITE(*, FMT1) DABS(ANGLE_REF(I)-ANGLE(I))
  500 CONTINUE

C     ALL DONE
      END


C
C
C       $Id: search.f,v 1.2 1997-05-05 21:45:43 boote Exp $
C
C This subprogram is used by subroutines TERP1 and TERP2 in
C library ncarm.  It is lower-level, i.e. not called by users.
C **********************************************************
      SUBROUTINE SEARCH (XBAR,X,N,I)
      DIMENSION       X(N)
      SAVE
      DATA B/.69314718/
C
C IF XBAR IS OUTSIDE RANGE OF X TABLE EXTRAPOLATE
C
      IF (XBAR .GT. X(2)) GO TO 101
      I = 1
      RETURN
  101 CONTINUE
      IF (XBAR .LT. X(N-1)) GO TO 102
      I = N-1
      RETURN
  102 CONTINUE
C
C FIND MAXIMUM POWER OF TWO LESS THAN N
C
      M = INT((ALOG(FLOAT(N)))/B)
      I = 2**M
      IF (I .GE. N) I = I/2
      K = I
      NM1 = N-1
C
C CONDUCT BINARY SEARCH.
C
  103 CONTINUE
      K = K/2
      IF (XBAR .GE. X(I)) GO TO 104
      I = I-K
      GO TO 103
  104 CONTINUE
      IF (XBAR .LE. X(I+1)) RETURN
      I = MIN0(I+K,NM1)
      GO TO 103
      END


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Relational operators (EQ - LT) for numeric types,
*   character, and logical, used outside of IF conditions.
*   Constant folding and expressions
*   requiring type conv. of one operand are not tested.

	parameter (N = 36)
	implicit logical(F, l-W), double precision (d), complex (c)
	integer TRUE
	parameter (TRUE = -1)
	dimension rslts(N)
	integer expect(N)
	character cab*2, cabx*3, ca*1, cb*1, cabb*3, cabc*3,
     +            cabdd*4, cabcdxx*6, cabcdef*6, cabcdefy*7

	data expect / TRUE, 0, TRUE, 0, TRUE, 0, TRUE, TRUE,
     +                0, TRUE, 0, 0, TRUE, TRUE,
     +                0, TRUE, 0, 0, 0, 0,
     +                TRUE, 0, 0, TRUE,
     +                0, TRUE, 0, TRUE, 0, 0, TRUE, TRUE,
     +                TRUE, TRUE, 0, 0               /

C  --- tests 1 - 8:     integer comparisons.

	data i2, i3, i4, in3, in1, i0, i99999, i1/
     +        2,  3,  4,  -3,  -1,  0,  99999,  1/

	rslts(1) = i2 .eq. i1 + 1
	rslts(2) = i3 .gt. i4
	rslts(3) = i2 + i2 .ge. i3
	rslts(4) = ior(i4, 0) .le. or(i3, 0)
	rslts(5) = 3 .ne. in3
	rslts(6) = i3 .lt. in3
	rslts(7) = in1.lt.i0
	rslts(8) = i99999.ge.99999

C  --- tests 9 - 14:    real comparisons.

	data x2, x201, x31, x3, x523, xn25, x25,  x0, xnp1/
     +      2.0, 2.01, 3.1,3.0, 5.23, -2.5, 2.5, 0.0, -.1   /

	rslts(9) = x3 - 1.0 .eq. x201
	rslts(10) = x31 .ge. x3 + x0
	rslts(11) = x523 .lt. 5.23
	rslts(12) = xn25 .ne. xn25
	rslts(13) = 2.5 .gt. x0
	rslts(14) = xnp1. le .x0

C  --- tests 15 - 20:   double precision comparisons.

	data d50,  d5,   d25,  dp25,  d0,   dn2111,  dn25 /
     +       5d1, 5d0, 2.5d0, 25d-2, 0d0, -2.1d-11, -2.5d0 /

	rslts(15) = d50 .ne. d50
	rslts(16) = d5 + d0 .lt. d50
	rslts(17) = d25 .eq. dp25
	rslts(18) = -1.0D0 .ge. d0 * 2
	rslts(19) = dn2111 .gt. -2.1D-11
	rslts(20) = d25 .le. - d25

C  --- tests 21 - 24:   complex comparisons (only EQ, NE allowed).

	data c10, c11 / (1.0, 0.0), (1.0, 1.0) /

        rslts(21) = c11 .eq. c11
        rslts(22) = (1.0, 1.0) .eq. c10
        rslts(23) = c10 .ne. (1.0, 0.0)
        rslts(24) = c10 .ne. c11

C  --- tests 25 - 32:   character comparisons.

	data cab,  cabx,  ca,  cb,  cabb,  cabc,  cabdd,  cabcdxx /
     +       'ab', 'ab ', 'a', 'b', 'abb', 'abc', 'abdd', 'abcd  ' /
	data cabcdef, cabcdefy / 'abcdef', 'abcdef!' /

	rslts(25) = cab .ne. cab
	rslts(26) = cab .eq. cabx
	rslts(27) = ca.gt.cb
	rslts(28) = cabx .le. cab
	rslts(29) = cabb .ge. 'abc'
	rslts(30) = 'ab' .lt. ca
	rslts(31) = cabdd .gt. cabcdxx
	rslts(32) = cabcdef .lt. cabcdefy

C  --- tests 33 - 36:   logical comparisons, EQ and NE (extension to
C                       f77 standard).

	data t, f / .true., .false. /

	rslts(33) = t .eq. t
	rslts(34) = (t .or. t) .ne. f
	rslts(35) = f .eq. .true.
	rslts(36) = .false. .ne. (f .and. t)

C  --- check results:

	call check(rslts, expect, N)
	end


! ==============================================================================
! Subroutine: ELOOP (ISEQ,IBSP,I,J,N,EL)
!
! Purpose: Computes the energy of an RNA loop using the emperical
!          MFOLD 3.0 energy function.
!
! Method: Uses the MFOLD 3.0 energy function for RNA @ T=37 given by:
!
!            EL = EHAIR                --> FOR k = 1
!            EL = EBULGE               --> FOR k = 2
!                                      --> FOR k > 2
!
!            EL = a + b*NS + c*NH + GS               IF NS <= 6
!               = a + b *6 + c*NH + GS + d*LOG(NS/6) IF NS  > 6
!
!            where k = number of helices in loop
!                  a = Multi-loop Penality
!                  b = Single Stranded Penalty
!                  c = Helix Penality
!                  d = 1.75 KT
!                  GS= Stacking Energy of Dangling Bases
!
! Arguments:
!
!          ISEQ - Array of length N containing the sequence
!                 in numerical code (A=1,C=2,G=3,U=4)
!          IBSP - Array of dimension (N) containing the information
!                 on base pairs in the RNA fold.
!                 IBSP(i) = j [i base pairs with j]
!                 IBSP(i) = 0 [i is single stranded]
!             I - Nucleotide position of the 5' most nucleotide.
!             J - Nucleotide position of the 3' most nucleotide.
!             N - Number of nucleotides in the sequence.
!            EL - (OUTPUT) MFOLD 3.0 energy of the RNA loop.
!
! History:
!
! Version    Date         Comment
! --------   ----------   -----------------------
!            01/01/2015   Original Code
!
! Dependencies:
!
! Modules - RNAvar
! Functions -
! Subroutines - EDANGLE
!
! Author(s): Eric Dykeman
!            Copyright (c) 2015 (Please Refer to LICENCE)
!
! ==============================================================================

      SUBROUTINE ELOOP (ISEQ,IBSP,I,J,N,EL)

        USE RNAvar, ONLY : em,eh,es,eaup,beta

        IMPLICIT NONE

        !=== ARGUMENTS ===!

        INTEGER, INTENT(IN) :: i,j,n
        INTEGER, INTENT(IN) :: iseq(n),ibsp(n)

        REAL, INTENT(OUT) :: el

        !=== VARIABLES ===!

        INTEGER :: k,ip,jp,kp,ks,ke
        INTEGER :: nh,ns,iloop,ilast

        REAL :: x,c,ed,e3,e5

        el = 0.0e0

        nh = 0
        ns = 0

        c = 1.750e0 / REAL(beta)

        !=== Internal Loop iloop = 1 ===!
        !=== External Loop iloop = 0 ===!

        IF ( i < j ) iloop = 1
        IF ( i > j ) iloop = 0

        ks = MIN(i,j)
        ke = MAX(i,j)

        !=== Count number of Helices in Loop ===!

        k = ks

        DO WHILE ( k <= ke )

          IF ( ibsp(k) == 0 ) ns = ns + 1
          IF ( ibsp(k) >  k ) nh = nh + 1

          IF ( ibsp(k) > k ) THEN
          IF ( iloop == 0 .or. k /= ks ) THEN
            k = ibsp(k)
          ENDIF
          ENDIF

          k = k + 1

        ENDDO

        !=== Compute Loop Energy ===!

        IF ( nh == 1 .and. iloop == 1 ) THEN

          CALL EHAIR (iseq,i,j,n,el)

        ELSEIF ( nh == 2 .and. iloop == 1 ) THEN

          ip = i + 1
          DO WHILE ( ibsp(ip) == 0 )
          ip = ip + 1
          ENDDO

          jp = ibsp(ip)

          CALL EBULGE (iseq,i,j,ip,jp,n,el)

        ELSE

          e3 = 0.0e0

          IF ( iloop == 0 ) THEN

            k = ks
            ilast = 0

          ELSEIF ( iloop == 1 ) THEN

            ip = i
            jp = ibsp(i)

            k = ip + 1
            ilast = k

            IF ( k >= 1 .and. k <= n ) THEN
            IF ( ibsp(k) == 0 ) THEN
              CALL EDANGLE (iseq,ip,jp,k,n,e3)
            ENDIF
            ENDIF

            IF ( ns <= 6 ) THEN
              el = em + es * REAL(ns) + eh * REAL(nh)
            ELSE
              x = REAL(ns) / 6.0e0
              el = em + es * 6.0e0 + eh * REAL(nh)
              el = el + c * LOG(x)
            ENDIF

          ENDIF

          DO WHILE ( k <= ke )

            IF ( ibsp(k) /= 0 ) THEN

              ip = k
              jp = ibsp(k)

              kp = ip - 1

              e5 = 0.0e0

              IF ( kp >= 1 .and. kp <= n ) THEN
              IF ( ibsp(kp) == 0 ) THEN
                CALL EDANGLE (iseq,ip,jp,kp,n,e5)
              ENDIF
              ENDIF

              IF ( ilast == kp ) THEN
                ed = MIN(e3,e5)
              ELSE
                ed = e3 + e5
              ENDIF

              el = el + ed + eaup(iseq(ip),iseq(jp))

              kp = jp + 1
              ilast = kp

              e3 = 0.0e0

              IF ( kp >= 1 .and. kp <= n ) THEN
              IF ( ibsp(kp) == 0 ) THEN
                CALL EDANGLE (iseq,ip,jp,kp,n,e3)
              ENDIF
              ENDIF

              IF ( k /= ke ) THEN
                k = ibsp(k)
              ENDIF

            ENDIF

            k = k + 1

          ENDDO

          IF ( iloop == 0 ) THEN
            el = el + e3
          ENDIF

        ENDIF

        RETURN

      END SUBROUTINE ELOOP


! # Projected-process approximation to full GP.
!
! We loosely follow the notation of [1].  Given n observations, we
! construct an approximation to the covariance matrix of rank m.  To
! do this, we must choose m distinguished `support points' from amoung
! the training data.  Here, they are simply taken to be the first m
! inputs in the array of training points passed to the constructor.
!
! The full covariance matrix C is represented as
!
!   C = Knm * inv(Kmm) * Kmn
!
! where 'n' and 'm' are subscripts and represent the size along the
! indicated dimension (e.g. Kmn is an m by n matrix).  This is never
! computed explicitly.
!
! * Knm is the n by m covariance matrix of the inputs in the training
! set with each support point.
!
! * Kmn is the transpose of Knm.
!
! * Kmm is the m by m covariance matrix of the support points.
!
! We also define
!
!   Q = nu**2 * Kmm + Kmn * Knm
!
! where nu**2 is the variance of the input-independent noise, and I is
! the m by m identity matrix.  The matrix Q is useful when making
! predictions and computing the liklihood.  This is not to be confused
! with the \tilde{Q} term defined in reference [2].
!
! ## References
!
! [1] C. Rasmussen and C. Williams. Gaussian Processes for Machine
! Learning. Adaptative Computation and Machine Learning Series. MIT
! Press, 2006.
!
! [2] J. Quinonero and C. Rasmussen. Analysis of Some Methods for
! Reduced Rank Gaussian Process Regression, in Switching and Learning
! in Feedback Systems: European Summer School on Multi-Agent Control,
! Maynooth, Ireland, September 8-10, 2003, Revised Lectures and
! Selected Papers, Springer, 2005

module m_GP_sparse
  use m_gp
  use m_util
  use m_cov_all
  use m_noise_all
  implicit none

  private
  public SparseGP, read_SparseGP

  type, extends(BaseGP) :: SparseGP
     ! Number of sparse points (and the rank of the covariance matrix
     ! under this approximation)
     integer :: m

     ! See the above description for definitions of Kmn, Kmm, Q etc.

     ! The reduced observations. Kmn_t = Kmn * t, where t is the
     ! vector of training observations
     real(dp), dimension(:), allocatable :: Kmn_t
     ! inv(Q) * Kmn * t
     real(dp), dimension(:), allocatable :: invQKmn_t
     ! inv(Kmm)
     real(dp), dimension(:,:), allocatable :: invKmm
     ! Q as described above: the sparsified covariance matrix and its inverse
     real(dp), dimension(:,:), allocatable :: Q, invQ
   contains
     procedure log_lik
     procedure update_matrices
     procedure predict
     procedure write_out
  end type SparseGP

  interface SparseGP
     module procedure make_SparseGP
     module procedure read_SparseGP
  end interface SparseGP

contains

  subroutine alloc_SparseGP(gp, n, m, ntheta, d, CovFunction, NoiseModel)
    type(SparseGP), intent(inout) :: gp
    integer, intent(in) :: n, m, ntheta, d
    class(cov_fn) :: CovFunction
    class(noise_model) :: NoiseModel

    if (m>n) then
       print *, "Error: Active data set larger than total data set."
       stop
    end if

    allocate(real(dp) :: gp%nu(NoiseModel%nparams_required(d)))
    allocate(real(dp) :: gp%theta(ntheta))
    allocate(real(dp) :: gp%x(n, d))
    allocate(integer :: gp%obs_type(n))
    allocate(real(dp) :: gp%t(n))
    allocate(real(dp) :: gp%Kmn_t(m))
    allocate(real(dp) :: gp%invQKmn_t(m))
    allocate(real(dp) :: gp%invKmm(m, m))
    allocate(real(dp) :: gp%Q(m, m))
    allocate(real(dp) :: gp%invQ(m, m))
    allocate(gp%covariance, mold=CovFunction)
    allocate(gp%noise_model, mold=NoiseModel)
  end subroutine alloc_SparseGP

  subroutine update_matrices(this)
    class(SparseGP), intent(inout) :: this
    real(dp), dimension(:, :), allocatable :: Knm
    real(dp), dimension(:, :), allocatable :: noise
    integer :: i,j,m,n

    n = size(this%t)
    m = this%m

    allocate(real(dp) :: noise(m,m))
    allocate(real(dp) :: Knm(n,m))

    noise = 0.0_dp
    do i=1,m
       noise(i,i) = this%noise_model%noise(this%obs_type(i), this%nu)
    end do

    do i=1,n
       do j=1,m
          Knm(i,j) = this%covariance%cov(this%obs_type(i), this%obs_type(j), &
               this%x(i,:), this%x(j,:), this%theta)
          ! add a small diagonal term to stabilise the inversion
          if (i.eq.j) then
             Knm(i,i) = Knm(i,i) + 1e-9
          end if
       end do
    end do

    this%Kmn_t = matmul(this%t, Knm)

    this%Q = matmul(Knm(1:m,:), noise) + matmul(transpose(Knm), Knm)
    do i=1,m
       this%Q(i,i) = this%Q(i,i) + 1e-9
    end do

    this%invQ = this%Q
    call ninv(this%invQ)

    this%invQKmn_t = solve(this%Q, this%Kmn_t)
    this%invKmm = Knm(1:m,:)
    call ninv(this%invKmm)
  end subroutine update_matrices

  function make_SparseGP(m, nu, theta, x, obs_type, t, CovFunction, NoiseModel) result(gp)
    type(SparseGP) :: gp
    integer, intent(in) :: m
    real(dp), dimension(:), intent(in) :: nu
    real(dp), dimension(:), intent(in) :: theta
    real(dp), dimension(:,:), intent(in) :: x
    integer,  dimension(:), intent(in) :: obs_type
    real(dp), dimension(:), intent(in) :: t

    class(cov_fn) :: CovFunction
    class(noise_model) :: NoiseModel

    integer :: n, d
    n = size(t)
    d = size(x,2)

    if (size(theta) /= CovFunction%ntheta_required(d)) then
       print *, "size of theta does not match number of hyperparameters required by the covariance function"
       stop 1
    end if

    if (size(nu) /= NoiseModel%nparams_required(d)) then
       print *, "size of nu (noise params) does not match number required by the noise model"
       stop 1
    end if

    call alloc_SparseGP(gp, n, m, size(theta), d, CovFunction, NoiseModel)

    gp%m = m
    gp%nu = nu
    gp%theta = theta
    gp%x = x
    gp%obs_type = obs_type
    gp%t = t

    call update_matrices(gp)

  end function make_SparseGP

  subroutine write_out(this, filename)
    class(SparseGP), intent(in) :: this
    character(len=*), intent(in) :: filename
    character(len=max_name_len) :: cov_fn_name
    character(len=max_name_len) :: noise_model_name
    integer :: u ! unit number for output

    cov_fn_name = cov_fn_to_string(this%covariance)
    noise_model_name = noise_model_to_string(this%noise_model)

    open(newunit=u, file=filename)

    write (u,'(A)') "SparseGP"
    write (u,'(I10)') size(this%t), this%m, size(this%theta), size(this%nu), size(this%x,2)
    write (u,'(A)') trim(cov_fn_name)
    write (u,'(A)') trim(noise_model_name)
    write (u,'(es24.15)') this%nu, this%theta, this%x
    write (u,'(I4)') this%obs_type
    write (u,'(es24.15)') this%Kmn_t, this%invQKmn_t, this%Q, this%invQ

    close(u)
  end subroutine write_out

  function read_SparseGP(filename) result(gp)
    character(len=*), intent(in) :: filename
    type(SparseGP) :: gp
    integer n, ntheta, nnu, d, u
    character(len=max_name_len) :: label
    character(len=max_name_len) :: cov_fn_name
    character(len=max_name_len) :: noise_model_name
    class(cov_fn), allocatable :: CovFunction
    class(noise_model), allocatable :: NoiseModel
    open(newunit=u, file=filename)
    read (u,'(A)') label

    if (trim(label) /= "SparseGP") then
       print *, "read_SparseGP: Incompatible data file"
       stop 1
    end if

    read (u,'(I10)') n, gp%m, ntheta, nnu, d

    read (u,'(A)') cov_fn_name
    call string_to_cov_fn(cov_fn_name, CovFunction)
    if (ntheta /= CovFunction%ntheta_required(d)) then
       print *, "read_SparseGP: ntheta does not match number required by the covariance function"
       stop 1
    end if

    read (u,'(A)') noise_model_name
    call string_to_noise_model(noise_model_name, NoiseModel)
    if (nnu /= NoiseModel%nparams_required(d)) then
       print *, "read_SparseGP: size of nu (noise params) does not match number required by the noise model"
       stop 1
    end if

    call alloc_SparseGP(gp, n, gp%m, ntheta, d, CovFunction, NoiseModel)

    read (u,'(es24.15)') gp%nu, gp%theta, &
         gp%x
    read (u,'(I4)') gp%obs_type
    read (u,'(es24.15)') gp%Kmn_t, gp%invQKmn_t, &
         gp%Q, gp%invQ
    close(u)
  end function read_SparseGP

  pure function predict(this, xnew, obs_type_new)
    real(dp) :: predict
    class(SparseGP), intent(in) :: this
    real(dp), dimension(:), intent(in) :: xnew
    integer, optional, intent(in) :: obs_type_new

    integer :: obs_type_new1, i

    ! covariance vector of the desired input with each support point
    real(dp), dimension(this%m) :: km

    ! Treatment of the optional obs_type_new. Default: a value
    ! observation.
    if (present(obs_type_new)) then
       obs_type_new1 = obs_type_new
    else
       obs_type_new1 = 0
    endif

    do i=1,this%m
       km(i) = this%covariance%cov(obs_type_new1, this%obs_type(i), xnew, this%x(i,:), this%theta)
    end do

    ! equation (8.26) in ref. [1]
    predict = dot_product(km, this%invQKmn_t)

  end function predict

  function log_lik(this)
    class(SparseGP), intent(in) :: this
    real(dp) :: log_lik

    integer m,n
    m = this%m
    n = size(this%t)

    ! See equations (24--25) in ref. [2]
    log_lik = -0.5 * ((n-m)*log(this%nu(1)) + logdet(this%Q) + (dot_product(this%t, this%t) &
         - dot_product(this%Kmn_t, this%invQKmn_t))/this%nu(1))
  end function log_lik
end module m_GP_sparse


      subroutine newton(time,ffpast,aveks,avesm,ffnow)
c
c     + + + PURPOSE + + +
c     Calculates cumulative infiltration via Newton's method.
c
c     Called from GRNA.
c     Author(s): Stone
c     Reference in User Guide:
c
c     Changes:
c          1) Local variables: NU1, DEL, & XX deleted.
c          2) 3rd parameter moved to end of list, since it is an
c             "output" parameter, and the others are "input" ones.
c             Corresponding changes required in GRNA and KOSTIA.
c          3) Calculation for TEST simplified.  This caused the
c             familiar annoying changes in the predicted location
c             of max. detach. with a nearly-constant detach. rate.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/24/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real time, ffpast, aveks, avesm, ffnow
c
c     + + + ARGUMENT DEFINITIONS + + +
c     time   - current time
c     ffpast - infiltration depth of last time
c     aveks  - average KS
c     avesm  - average SM
c     ffnow  - infiltration depth of current time
c
c     + + + LOCAL VARIABLES + + +
      real test, yy
c
c     + + + LOCAL DEFINITIONS + + +
c     test   - value which tells when to exit loop.
c     yy     - current computed value for FFNOW.
c
c     + + + END SPECIFICATIONS + + +
c
c     Solution for sm=0.0
c
      if (avesm.le.0.0) then
        yy = time * aveks
      else
c
c       setting the initial yy value to prevent divide by zero
c
        if (ffpast.gt.0.0) then
          yy = ffpast
        else
          yy = 0.1
        end if
c
c       Keep reevaluating test until it becomes very small (<.000001)
c
        test = 0.1
   10   if (abs(test).gt.0.000001) then
          test = (time*aveks+avesm*log(1.0+yy/avesm)-yy) * (1.0+avesm/yy
     1        )
          yy = yy + test
          go to 10
        end if
      end if
c
      ffnow = yy
c
      return
      end


      subroutine dqawoe (f,a,b,omega,integr,epsabs,epsrel,limit,icall,
     *  maxp1,result,abserr,neval,ier,last,alist,blist,rlist,elist,iord,
     *   nnlog,momcom,chebmo)
c***begin prologue  dqawoe
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a1
c***keywords  automatic integrator, special-purpose,
c             integrand with oscillatory cos or sin factor,
c             clenshaw-curtis method, (end point) singularities,
c             extrapolation, globally adaptive
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  the routine calculates an approximation result to a given
c            definite integral
c            i = integral of f(x)*w(x) over (a,b)
c            where w(x) = cos(omega*x) or w(x)=sin(omega*x),
c            hopefully satisfying following claim for accuracy
c            abs(i-result).le.max(epsabs,epsrel*abs(i)).
c***description
c
c        computation of oscillatory integrals
c        standard fortran subroutine
c        double precision version
c
c        parameters
c         on entry
c            f      - double precision
c                     function subprogram defining the integrand
c                     function f(x). the actual name for f needs to be
c                     declared e x t e r n a l in the driver program.
c
c            a      - double precision
c                     lower limit of integration
c
c            b      - double precision
c                     upper limit of integration
c
c            omega  - double precision
c                     parameter in the integrand weight function
c
c            integr - integer
c                     indicates which of the weight functions is to be
c                     used
c                     integr = 1      w(x) = cos(omega*x)
c                     integr = 2      w(x) = sin(omega*x)
c                     if integr.ne.1 and integr.ne.2, the routine
c                     will end with ier = 6.
c
c            epsabs - double precision
c                     absolute accuracy requested
c            epsrel - double precision
c                     relative accuracy requested
c                     if  epsabs.le.0
c                     and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c                     the routine will end with ier = 6.
c
c            limit  - integer
c                     gives an upper bound on the number of subdivisions
c                     in the partition of (a,b), limit.ge.1.
c
c            icall  - integer
c                     if dqawoe is to be used only once, icall must
c                     be set to 1.  assume that during this call, the
c                     chebyshev moments (for clenshaw-curtis integration
c                     of degree 24) have been computed for intervals of
c                     lengths (abs(b-a))*2**(-l), l=0,1,2,...momcom-1.
c                     if icall.gt.1 this means that dqawoe has been
c                     called twice or more on intervals of the same
c                     length abs(b-a). the chebyshev moments already
c                     computed are then re-used in subsequent calls.
c                     if icall.lt.1, the routine will end with ier = 6.
c
c            maxp1  - integer
c                     gives an upper bound on the number of chebyshev
c                     moments which can be stored, i.e. for the
c                     intervals of lengths abs(b-a)*2**(-l),
c                     l=0,1, ..., maxp1-2, maxp1.ge.1.
c                     if maxp1.lt.1, the routine will end with ier = 6.
c
c         on return
c            result - double precision
c                     approximation to the integral
c
c            abserr - double precision
c                     estimate of the modulus of the absolute error,
c                     which should equal or exceed abs(i-result)
c
c            neval  - integer
c                     number of integrand evaluations
c
c            ier    - integer
c                     ier = 0 normal and reliable termination of the
c                             routine. it is assumed that the
c                             requested accuracy has been achieved.
c                   - ier.gt.0 abnormal termination of the routine.
c                             the estimates for integral and error are
c                             less reliable. it is assumed that the
c                             requested accuracy has not been achieved.
c            error messages
c                     ier = 1 maximum number of subdivisions allowed
c                             has been achieved. one can allow more
c                             subdivisions by increasing the value of
c                             limit (and taking according dimension
c                             adjustments into account). however, if
c                             this yields no improvement it is advised
c                             to analyze the integrand, in order to
c                             determine the integration difficulties.
c                             if the position of a local difficulty can
c                             be determined (e.g. singularity,
c                             discontinuity within the interval) one
c                             will probably gain from splitting up the
c                             interval at this point and calling the
c                             integrator on the subranges. if possible,
c                             an appropriate special-purpose integrator
c                             should be used which is designed for
c                             handling the type of difficulty involved.
c                         = 2 the occurrence of roundoff error is
c                             detected, which prevents the requested
c                             tolerance from being achieved.
c                             the error may be under-estimated.
c                         = 3 extremely bad integrand behaviour occurs
c                             at some points of the integration
c                             interval.
c                         = 4 the algorithm does not converge.
c                             roundoff error is detected in the
c                             extrapolation table.
c                             it is presumed that the requested
c                             tolerance cannot be achieved due to
c                             roundoff in the extrapolation table,
c                             and that the returned result is the
c                             best which can be obtained.
c                         = 5 the integral is probably divergent, or
c                             slowly convergent. it must be noted that
c                             divergence can occur with any other value
c                             of ier.gt.0.
c                         = 6 the input is invalid, because
c                             (epsabs.le.0 and
c                              epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
c                             or (integr.ne.1 and integr.ne.2) or
c                             icall.lt.1 or maxp1.lt.1.
c                             result, abserr, neval, last, rlist(1),
c                             elist(1), iord(1) and nnlog(1) are set
c                             to zero. alist(1) and blist(1) are set
c                             to a and b respectively.
c
c            last  -  integer
c                     on return, last equals the number of
c                     subintervals produces in the subdivision
c                     process, which determines the number of
c                     significant elements actually in the
c                     work arrays.
c            alist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the left
c                     end points of the subintervals in the partition
c                     of the given integration range (a,b)
c
c            blist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the right
c                     end points of the subintervals in the partition
c                     of the given integration range (a,b)
c
c            rlist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the integral
c                     approximations on the subintervals
c
c            elist  - double precision
c                     vector of dimension at least limit, the first
c                      last  elements of which are the moduli of the
c                     absolute error estimates on the subintervals
c
c            iord   - integer
c                     vector of dimension at least limit, the first k
c                     elements of which are pointers to the error
c                     estimates over the subintervals,
c                     such that elist(iord(1)), ...,
c                     elist(iord(k)) form a decreasing sequence, with
c                     k = last if last.le.(limit/2+2), and
c                     k = limit+1-last otherwise.
c
c            nnlog  - integer
c                     vector of dimension at least limit, containing the
c                     subdivision levels of the subintervals, i.e.
c                     iwork(i) = l means that the subinterval
c                     numbered i is of length abs(b-a)*2**(1-l)
c
c         on entry and return
c            momcom - integer
c                     indicating that the chebyshev moments
c                     have been computed for intervals of lengths
c                     (abs(b-a))*2**(-l), l=0,1,2, ..., momcom-1,
c                     momcom.lt.maxp1
c
c            chebmo - double precision
c                     array of dimension (maxp1,25) containing the
c                     chebyshev moments
c
c***references  (none)
c***routines called  d1mach,dqc25f,dqelg,dqpsrt
c***end prologue  dqawoe
c
      double precision a,abseps,abserr,alist,area,area1,area12,area2,a1,
     *  a2,b,blist,b1,b2,chebmo,correc,dabs,defab1,defab2,defabs,dmax1,
     *  domega,d1mach,dres,elist,epmach,epsabs,epsrel,erlarg,erlast,
     *  errbnd,errmax,error1,erro12,error2,errsum,ertest,f,oflow,
     *  omega,resabs,reseps,result,res3la,rlist,rlist2,small,uflow,width
      integer icall,id,ier,ierro,integr,iord,iroff1,iroff2,iroff3,
     *  jupbnd,k,ksgn,ktmin,last,limit,maxerr,maxp1,momcom,nev,neval,
     *  nnlog,nres,nrmax,nrmom,numrl2
      logical extrap,noext,extall
c
      dimension alist(limit),blist(limit),rlist(limit),elist(limit),
     *  iord(limit),rlist2(52),res3la(3),chebmo(maxp1,25),nnlog(limit)
c
      external f
c
c            the dimension of rlist2 is determined by  the value of
c            limexp in subroutine dqelg (rlist2 should be of
c            dimension (limexp+2) at least).
c
c            list of major variables
c            -----------------------
c
c           alist     - list of left end points of all subintervals
c                       considered up to now
c           blist     - list of right end points of all subintervals
c                       considered up to now
c           rlist(i)  - approximation to the integral over
c                       (alist(i),blist(i))
c           rlist2    - array of dimension at least limexp+2
c                       containing the part of the epsilon table
c                       which is still needed for further computations
c           elist(i)  - error estimate applying to rlist(i)
c           maxerr    - pointer to the interval with largest
c                       error estimate
c           errmax    - elist(maxerr)
c           erlast    - error on the interval currently subdivided
c           area      - sum of the integrals over the subintervals
c           errsum    - sum of the errors over the subintervals
c           errbnd    - requested accuracy max(epsabs,epsrel*
c                       abs(result))
c           *****1    - variable for the left subinterval
c           *****2    - variable for the right subinterval
c           last      - index for subdivision
c           nres      - number of calls to the extrapolation routine
c           numrl2    - number of elements in rlist2. if an appropriate
c                       approximation to the compounded integral has
c                       been obtained it is put in rlist2(numrl2) after
c                       numrl2 has been increased by one
c           small     - length of the smallest interval considered
c                       up to now, multiplied by 1.5
c           erlarg    - sum of the errors over the intervals larger
c                       than the smallest interval considered up to now
c           extrap    - logical variable denoting that the routine is
c                       attempting to perform extrapolation, i.e. before
c                       subdividing the smallest interval we try to
c                       decrease the value of erlarg
c           noext     - logical variable denoting that extrapolation
c                       is no longer allowed (true  value)
c
c            machine dependent constants
c            ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c           oflow is the largest positive magnitude.
c
c***first executable statement  dqawoe
      epmach = d1mach(4)
c
c         test on validity of parameters
c         ------------------------------
c
      ier = 0
      neval = 0
      last = 0
      result = 0.0d+00
      abserr = 0.0d+00
      alist(1) = a
      blist(1) = b
      rlist(1) = 0.0d+00
      elist(1) = 0.0d+00
      iord(1) = 0
      nnlog(1) = 0
      if((integr.ne.1.and.integr.ne.2).or.(epsabs.le.0.0d+00.and.
     *  epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)).or.icall.lt.1.or.
     *  maxp1.lt.1) ier = 6
      if(ier.eq.6) go to 999
c
c           first approximation to the integral
c           -----------------------------------
c
      domega = dabs(omega)
      nrmom = 0
      if (icall.gt.1) go to 5
      momcom = 0
    5 call dqc25f(f,a,b,domega,integr,nrmom,maxp1,0,result,abserr,
     *  neval,defabs,resabs,momcom,chebmo)
c
c           test on accuracy.
c
      dres = dabs(result)
      errbnd = dmax1(epsabs,epsrel*dres)
      rlist(1) = result
      elist(1) = abserr
      iord(1) = 1
      if(abserr.le.0.1d+03*epmach*defabs.and.abserr.gt.errbnd) ier = 2
      if(limit.eq.1) ier = 1
      if(ier.ne.0.or.abserr.le.errbnd) go to 200
c
c           initializations
c           ---------------
c
      uflow = d1mach(1)
      oflow = d1mach(2)
      errmax = abserr
      maxerr = 1
      area = result
      errsum = abserr
      abserr = oflow
      nrmax = 1
      extrap = .false.
      noext = .false.
      ierro = 0
      iroff1 = 0
      iroff2 = 0
      iroff3 = 0
      ktmin = 0
      small = dabs(b-a)*0.75d+00
      nres = 0
      numrl2 = 0
      extall = .false.
      if(0.5d+00*dabs(b-a)*domega.gt.0.2d+01) go to 10
      numrl2 = 1
      extall = .true.
      rlist2(1) = result
   10 if(0.25d+00*dabs(b-a)*domega.le.0.2d+01) extall = .true.
      ksgn = -1
      if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1
c
c           main do-loop
c           ------------
c
      do 140 last = 2,limit
c
c           bisect the subinterval with the nrmax-th largest
c           error estimate.
c
        nrmom = nnlog(maxerr)+1
        a1 = alist(maxerr)
        b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
        a2 = b1
        b2 = blist(maxerr)
        erlast = errmax
        call dqc25f(f,a1,b1,domega,integr,nrmom,maxp1,0,
     *  area1,error1,nev,resabs,defab1,momcom,chebmo)
        neval = neval+nev
        call dqc25f(f,a2,b2,domega,integr,nrmom,maxp1,1,
     *  area2,error2,nev,resabs,defab2,momcom,chebmo)
        neval = neval+nev
c
c           improve previous approximations to integral
c           and error and test for accuracy.
c
        area12 = area1+area2
        erro12 = error1+error2
        errsum = errsum+erro12-errmax
        area = area+area12-rlist(maxerr)
        if(defab1.eq.error1.or.defab2.eq.error2) go to 25
        if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12)
     *  .or.erro12.lt.0.99d+00*errmax) go to 20
        if(extrap) iroff2 = iroff2+1
        if(.not.extrap) iroff1 = iroff1+1
   20   if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1
   25   rlist(maxerr) = area1
        rlist(last) = area2
        nnlog(maxerr) = nrmom
        nnlog(last) = nrmom
        errbnd = dmax1(epsabs,epsrel*dabs(area))
c
c           test for roundoff error and eventually set error flag.
c
        if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2
        if(iroff2.ge.5) ierro = 3
c
c           set error flag in the case that the number of
c           subintervals equals limit.
c
        if(last.eq.limit) ier = 1
c
c           set error flag in the case of bad integrand behaviour
c           at a point of the integration range.
c
        if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)
     *  *(dabs(a2)+0.1d+04*uflow)) ier = 4
c
c           append the newly-created intervals to the list.
c
        if(error2.gt.error1) go to 30
        alist(last) = a2
        blist(maxerr) = b1
        blist(last) = b2
        elist(maxerr) = error1
        elist(last) = error2
        go to 40
   30   alist(maxerr) = a2
        alist(last) = a1
        blist(last) = b1
        rlist(maxerr) = area2
        rlist(last) = area1
        elist(maxerr) = error2
        elist(last) = error1
c
c           call subroutine dqpsrt to maintain the descending ordering
c           in the list of error estimates and select the subinterval
c           with nrmax-th largest error estimate (to bisected next).
c
   40   call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
c ***jump out of do-loop
      if(errsum.le.errbnd) go to 170
      if(ier.ne.0) go to 150
        if(last.eq.2.and.extall) go to 120
        if(noext) go to 140
        if(.not.extall) go to 50
        erlarg = erlarg-erlast
        if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12
        if(extrap) go to 70
c
c           test whether the interval to be bisected next is the
c           smallest interval.
c
   50   width = dabs(blist(maxerr)-alist(maxerr))
        if(width.gt.small) go to 140
        if(extall) go to 60
c
c           test whether we can start with the extrapolation procedure
c           (we do this if we integrate over the next interval with
c           use of a gauss-kronrod rule - see subroutine dqc25f).
c
        small = small*0.5d+00
        if(0.25d+00*width*domega.gt.0.2d+01) go to 140
        extall = .true.
        go to 130
   60   extrap = .true.
        nrmax = 2
   70   if(ierro.eq.3.or.erlarg.le.ertest) go to 90
c
c           the smallest interval has the largest error.
c           before bisecting decrease the sum of the errors over
c           the larger intervals (erlarg) and perform extrapolation.
c
        jupbnd = last
        if (last.gt.(limit/2+2)) jupbnd = limit+3-last
        id = nrmax
        do 80 k = id,jupbnd
          maxerr = iord(nrmax)
          errmax = elist(maxerr)
          if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 140
          nrmax = nrmax+1
   80   continue
c
c           perform extrapolation.
c
   90   numrl2 = numrl2+1
        rlist2(numrl2) = area
        if(numrl2.lt.3) go to 110
        call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres)
        ktmin = ktmin+1
        if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5
        if(abseps.ge.abserr) go to 100
        ktmin = 0
        abserr = abseps
        result = reseps
        correc = erlarg
        ertest = dmax1(epsabs,epsrel*dabs(reseps))
c ***jump out of do-loop
        if(abserr.le.ertest) go to 150
c
c           prepare bisection of the smallest interval.
c
  100   if(numrl2.eq.1) noext = .true.
        if(ier.eq.5) go to 150
  110   maxerr = iord(1)
        errmax = elist(maxerr)
        nrmax = 1
        extrap = .false.
        small = small*0.5d+00
        erlarg = errsum
        go to 140
  120   small = small*0.5d+00
        numrl2 = numrl2+1
        rlist2(numrl2) = area
  130   ertest = errbnd
        erlarg = errsum
  140 continue
c
c           set the final result.
c           ---------------------
c
  150 if(abserr.eq.oflow.or.nres.eq.0) go to 170
      if(ier+ierro.eq.0) go to 165
      if(ierro.eq.3) abserr = abserr+correc
      if(ier.eq.0) ier = 3
      if(result.ne.0.0d+00.and.area.ne.0.0d+00) go to 160
      if(abserr.gt.errsum) go to 170
      if(area.eq.0.0d+00) go to 190
      go to 165
  160 if(abserr/dabs(result).gt.errsum/dabs(area)) go to 170
c
c           test on divergence.
c
  165 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le.
     * defabs*0.1d-01) go to 190
      if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03
     * .or.errsum.ge.dabs(area)) ier = 6
      go to 190
c
c           compute global integral sum.
c
  170 result = 0.0d+00
      do 180 k=1,last
        result = result+rlist(k)
  180 continue
      abserr = errsum
  190 if (ier.gt.2) ier=ier-1
  200 if (integr.eq.2.and.omega.lt.0.0d+00) result=-result
  999 return
      end


      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(1),INFO
      DOUBLE PRECISION A(LDA,1)
C
C     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
C
C     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,IDAMAX
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      INTEGER IDAMAX,J,K,KP1,L,NM1
C
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
      END


      IMPLICIT NONE
      INTEGER nyrs,yr0,no_files
      REAL*8 latres,lonres
      CHARACTER stinput*60,stoutput*60

      PARAMETER(nyrs=100,yr0=1901)
      PARAMETER(stinput  = '/data/SDGVM/output/newnew/')
      PARAMETER(stoutput = '/data/SDGVM/output/newnew/sums_41/')
      PARAMETER(latres=0.5d0,lonres=0.5d0)
      PARAMETER(no_files=18)

      real*8 lat,lon,npp,pi,rad,circ,x,y,area,xx,scale,sum,out2
      real*8 sum1(500),sum2(500),sum3(500),nppt(500),ans,out1
      integer i,j,k,blank,file_no,av,n_poly
      character  stvar(no_files)*60,st*60
      logical pll
      PARAMETER(n_poly=5)
      real*8 plats(n_poly),plons(n_poly)
* 41
      DATA plats/   2.5,   1.0, -15.0, -15.0,   2.5/
      DATA plons/ -59.0, -50.0, -51.5, -59.0, -59.0/

* 42
*      DATA plats/ -13.40, -2.67, -15.00, -20.50, -13.00/
*      DATA plons/ -71.12, -59.0, -59.50, -63.50, -71.12/

* 43
*      DATA plats/   4.00, -4.00, -15.50,  -6.00,   4.00/
*      DATA plons/ -76.50, -60.5, -73.50, -80.00, -76.50/

* 44
*      DATA plats/   2.50,  5.00,  -2.67,  -4.00,   2.50/
*      DATA plons/ -73.40, -59.0, -59.00, -60.50, -73.40/

* 45
*      DATA plats/  -8.00, -1.80,  -4.00, -13.32,  -8.00/
*      DATA plons/ -73.30, -65.0, -60.50, -71.02, -73.30/

      DATA stvar/'gpp.dat','npp.dat','nbp.dat','nbpsum.dat',
     &'lai.dat','evt.dat','trn.dat','rof.dat',
     &'biot.dat','stembio.dat','rootbio.dat','nppstore.dat',
     &'scn.dat','snn.dat','sresp.dat','fcn.dat','prc.dat','tmp.dat'/

      pi = 3.1415926D0
      circ = 40008.0D0
      rad = circ/(2.0D0*pi)
      y = circ*latres/360.0D0

      open(21,file=stoutput(1:blank(stoutput))//'all_sums.dat')
      open(22,file=stoutput(1:blank(stoutput))//'lat_lon.dat')

      do file_no=1,no_files

      scale = 1.0d0

      if (stvar(file_no).eq.'nbpsum.dat') then
        sum = 1.0d0
        k = 3
      else
        sum = 0.0d0
        k = file_no
      endif

      if ((stvar(file_no).eq.'lai.dat').or.
     &(stvar(file_no).eq.'tmp.dat')) then
        av = 1
      else
        av = 0
      endif

      st = stinput
      open(10,file=st(1:blank(st))//stvar(k))

      DO i=1,nyrs
        sum1(i) = 0.0D0
        sum2(i) = 0.0D0
        sum3(i) = 0.0D0
      ENDDO

      j = 0

10    continue

        read(10,*,end = 90) lat,lon,(nppt(i),i=1,nyrs)
        CALL POLYGON(lat,lon,plats,plons,n_poly,pll)
        if (file_no.eq.1) then
          if (pll) then
            write(22,'(f7.3,f9.3)') lat,lon
          endif
        endif

        j = j + 1
*        if (mod(j,1000).eq.0.0d0)  print*,j

          if (pll) then

          do i=1,nyrs

            npp = nppt(i)

* Put npp in units of tonnes per kilometer squared.
            npp = npp*scale
            x = 2.0D0*pi*rad*cos(lat*pi/180.0D0)*lonres/360.0D0
            area = x*y
            sum1(i) = sum1(i)+ npp*area
            sum2(i) = sum2(i) + area
            sum3(i) = sum3(i) + area
          enddo

        endif

      goto 10
90    continue

      close(unit=10)

* Areas are in mega KM and npp is in giga tonnes.
      DO i=1,nyrs
        sum1(i) = sum1(i)/1.0e9
        sum2(i) = sum2(i)/1.0e6
        sum3(i) = sum3(i)/1.0e6
      ENDDO

      print'(''Total npp       = '',F9.3,'' giga tonnes'')',
     &sum1(nyrs)
      print'(''Vegetation area = '',F9.4,'' mega Km^2'')', sum2(nyrs)
      print'(''Land area       = '',F9.4,'' mega Km^2'')', sum3(nyrs)

      open(11,file=stoutput(1:blank(stoutput))//stvar(file_no))

      av = 1
      ans = 0.0d0
      do i=1,nyrs
        xx = 1.0d0
        if (av.EQ.1)  xx = sum2(i)/1000.0d0
        write(11,1000) yr0-1+i,sum1(i)/xx + ans*sum
        if (i.EQ.1) out1 = sum1(i)/xx + ans*sum
        if (i.EQ.nyrs) out2 = sum1(i)/xx + ans*sum
        ans = ans + sum1(i)
1000    format(i6,f12.5)
      enddo

      if (file_no.eq.1) write(21,'(''Area'',f8.3,'' mega Km^2'')')
     &sum3(nyrs)

      write(21,'(A15,2f12.5)') stvar(file_no),out1,out2

      if (av.eq.1)  write(*,'(''Average         = '',f9.3)')
     &sum1(nyrs)/xx

      close(unit=11)

      enddo

      stop
      end

*----------------------------------------------------------------------*
*                                                                      *
*                          FUNCTION blank                              *
*                          **************                              *
*                                                                      *
* 'blank' returns the number of characters before the space in the     *
* string which is its argument.                                        *
*                                                                      *
*----------------------------------------------------------------------*
      FUNCTION blank(st1)
*----------------------------------------------------------------------*
      CHARACTER st1*60
      INTEGER blank

      blank = 0
10    CONTINUE
      blank = blank + 1
      IF ((ichar(st1(blank:blank)).NE.32).AND.(blank.LE.60))  GOTO 10
      blank = blank - 1

      RETURN
      END

      SUBROUTINE POLYGON(lat,lon,plats,plons,n_poly,pll)
      integer n_poly
      real*8 lat,lon,pi,x1,x2,y1,y2,angle,dtheta,theta1,theta2
      real*8 plats(n_poly),plons(n_poly)
      logical pll

      pi = 3.1415926

      angle = 0.0

      do i=1,n_poly-1

        x1 = plats(i) - lat
        y1 = plons(i) - lon
        x2 = plats(i+1) - lat
        y2 = plons(i+1) - lon

        theta1 = atan2(y1,x1)
        theta2 = atan2(y2,x2)
        dtheta = theta2 - theta1
        IF (dtheta.GT. pi) dtheta = dtheta - 2.0*pi
        IF (dtheta.LT.-pi) dtheta = dtheta + 2.0*pi
        angle = angle + dtheta
*        print*,angle,dtheta

      enddo

*      print*,angle*180/pi,angle,angle

      IF (abs(angle).LT.pi) THEN
        pll = .false.
      ELSE
        pll = .true.
      ENDIF
*      print*,pll

      RETURN
      END


module neutron_conductivity
    use conductivity_def
    implicit none

    ! for the integration over structure factors
    integer, parameter, private :: int_default_max_steps = 1000
    real(dp), parameter, private :: int_default_max_step_size = 0.0_dp
    real(dp), parameter, private :: int_default_starting_step = 1.0e-10_dp

contains

    function sPh(nn, nion, temperature, ionic)
        ! neutron superfluid phonon conductivity
        ! Implements formalism described in
        ! Aguilera et al. (2009), PRL 102: 091101
        !
        use nucchem_def, only: composition_info_type
        use constants_def
        real(dp), intent(in) :: nn, nion, temperature
        type(composition_info_type), intent(in) :: ionic
        real(dp) :: sPh
        real(dp) :: K_n
        real(dp) :: etwo
        real(dp) :: Mu_n
        real(dp), parameter :: anl = 10.0
        real(dp) :: T,ai,kFn,kFe,vs,Cv,omega_p,TUm,anlt,gmix,cs,qTFe,alpha,tau_lph,wt
        real(dp) :: Llphn,Llphu,Llph,Lsph,fu,omega

        K_n = boltzmann*clight*fm_to_cm/(hbarc_n*fm_to_cm)**3
        etwo = finestructure*hbarc_n
        Mu_n = amu*clight2*ergs_to_mev

        ! convert to nuclear units
        T = temperature*boltzmann*ergs_to_mev
        ai = (3.0/fourpi/nion)**onethird
        kFn = (threepisquare*nn)**onethird
        kFe = (threepisquare*nion*ionic%Z)**onethird
        ! phonon speed
        vs = hbarc_n*kFn/Mn_n/sqrt(3.0)
        ! specific heat, phonon gas
        Cv = 2.0*pi**2*T**3/15.0/vs**3
        ! ion plasma freq
        omega_p = sqrt(fourpi*etwo*ionic%Z2*nion/ionic%A/Mu_n)
        ! Thomas-Fermi wavevector
        qTFe = sqrt(4.0*finestructure/pi)*kFe
        ! sound speed
        cs = omega_p/qTFe
        alpha = cs/vs
        ! mixing parameter
        anlt = anl/(1.0+0.4*kFn*anl + 0.5*2.0*anl*kFn**2)
        gmix = 2.0*anlt*hbarc_n*sqrt(nion*kFn/ionic%A/Mu_n**2)
        ! Umklapp temperature
        TUm = onethird*etwo*omega_p*(ionic% Z)**onethird
        ! thermal phonon frequency
        omega = 3.0*T/hbarc_n
        ! interpolation fmla.
        fu = exp(-TUm/T)
        ! mean-free path, normal; fu interpolates to Umklapp scattering
        Llphn = 2.0/pi/omega
        Llphu = 100.0*ai
        Llph = 1.0/(fu/Llphu + (1.0-fu)/Llphn)
        tau_lph = Llph/cs
        wt = tau_lph*omega
        Lsph = Llph*(vs/gmix)**2*(1.0+(1.0-alpha**2)**2 * wt**2)/alpha/wt**2
        sPh = onethird*Cv*vs*Lsph * K_n
    end function sPh

    function n_imp(nn, nion, temperature, ionic, ierr) result(nu)
        ! neutron-impurity scattering
        ! implements formalism described in Appendix of
        ! Deibel et al. (2017), ApJ 839: 95
        use exceptions_lib
        use nucchem_def, only: composition_info_type
        use constants_def
        use num_lib

        real(dp), intent(in) :: nn, nion, temperature
        type(composition_info_type), intent(in) :: ionic
        integer, intent(out) :: ierr
        real(dp) :: nu      ! neutron-impurity scattering frequency

        integer, parameter :: num_integration_variables = 1
        integer, parameter :: num_ipar = 0
        integer, parameter :: num_rpar = 6

        real(dp) :: ne      ! number density of electrons
        real(dp) :: kFn     ! neutron Fermi wavevector
        real(dp) :: EFn     ! neutron Fermi energy
        real(dp) :: V       ! effective neutron-impurity potential
        real(dp) :: Lambda_n_imp    ! Coulomb logarithm (Potekhin et al. 1999)
        real(dp) :: fac, sf_frac, Tc, xFn
        real(dp) :: gamma, vFn, v2, s, L1
        real(dp) :: pfn
        real(dp) :: R_a, mnstar
        real(dp) :: isospin, n_0, n_2, n_l, n_in
        real(dp), dimension(:), pointer :: y
        integer ,dimension(:), pointer :: iwork => null()
        real(dp), dimension(:), pointer :: work => null()
        real(dp), dimension(num_integration_variables) :: rtol, atol
        integer, dimension(:), pointer :: ipar => null()
        real(dp), dimension(:), pointer :: rpar => null()
        real(dp) :: h, kn_end, kn_start, kn, kfi
        integer :: liwork, lwork, itol, lipar, lrpar, idid, lout, iout, npts
        character(len=128) :: msg
        type(alert) :: status=alert(scope='n_imp')

        ierr = 0
        allocate(y(num_integration_variables))

        kFn = (threepisquare*nn)**onethird
        kfi = (threepisquare*nn/ionic%Yn*(1.0-ionic%Yn)/ionic%A)**onethird

        call dop853_work_sizes( &
        &   num_integration_variables,num_integration_variables,liwork,lwork)
        allocate(iwork(liwork), work(lwork),ipar(num_ipar), rpar(num_rpar))
        iwork = 0
        iwork(5) = num_integration_variables
        work = 0.0

        itol = 0
        rtol = 1.0e-4
        atol = 1.0e-5
        iout = 0    ! solout is never called for output
        lout = error_unit
        lipar = num_ipar
        lrpar = num_rpar

        !calculate n_in and R_a using Sly4 model for now
        isospin = 1.0 - 2.0*ionic%Z/ionic%A
        n_0 = 0.1740/(fm_to_cm)**3
        n_2 = -0.0157/(fm_to_cm)**3
        n_l = n_0+n_2*isospin**2
        n_in = n_l/2.0*(1.0+0.9208*isospin)
        R_a = (3.0*(ionic%A-ionic%Z)/4.0/pi/n_in)**onethird

        y(1) = 0.0
        kn_start = int_default_starting_step
        kn_end = 2.0*kFn*R_a
        h = 0.0

        rpar(1) = temperature
        rpar(2) = ionic% Z
        rpar(3) = ionic% A
        rpar(4) = ionic% Yn
        rpar(5) = kfn
        rpar(6) = R_a

        call dop853(num_integration_variables, &
        &   structure_factor_impurity,kn_start,y,kn_end,h, &
        &   int_default_max_step_size,int_default_max_steps, &
        &   rtol,atol,itol, null_solout, iout, work, lwork, iwork, liwork,  &
        &   num_rpar, rpar, num_ipar, ipar, lout, idid)

        if (idid < 0) then
            write(msg,'(a,i0)') 'dop853 returned with error ',idid
            call status% report(msg)
            ierr = idid
        end if

        deallocate(work, iwork)

        Lambda_n_imp = y(1)
        fac = 4.0/27.0/pi/hbar**3/clight**2
        V = neutron_potential(nn,n_in,ionic%Z,ionic%A)
        kFn = (threepisquare*nn)**onethird
        xFn = hbar*kFn/Mneutron/clight
        mnstar = Mneutron
        Efn = 15.1*mev_to_ergs*(ionic% Yn)**(2.0/3.0)* &
        &   (nn*amu/ionic% Yn/1.0E14)**(2.0/3.0)* &
        &   (2.0*Mneutron/mnstar) + Mneutron*clight**2

        nu = fac*EFn*(nion/nn)*(V*R_a)**2*ionic%Q/(ionic%Z)**2*Lambda_n_imp
    end function n_imp

    function n_phonon(nn, nion, temperature, ionic, ierr) result(nu)
        ! neutron-phonon scattering
        ! implements formalism described in Appendix of
        ! Deibel et al. (2017), ApJ 839: 95
        use exceptions_lib
        use nucchem_def, only: composition_info_type
        use constants_def
        use num_lib

        real(dp), intent(in) :: nn, nion, temperature
        type(composition_info_type), intent(in) :: ionic
        integer, intent(out) :: ierr
        real(dp) :: nu              ! neutron-impurity scattering frequency

        integer, parameter :: num_integration_variables = 1
        integer, parameter :: num_ipar = 0
        integer, parameter :: num_rpar = 6

        real(dp) :: ne              ! electron number density
        real(dp) :: kFn             ! neutron Fermi wavevector
        real(dp) :: EFn             ! neutron Fermi energy
        real(dp) :: V               ! effective neutron-impurity potential
        real(dp) :: Lambda_n_phonon ! Coulomb logarithm (Potekhin et al. 1999)
        real(dp) :: fac, sf_frac, Tc, xFn
        real(dp) :: kfe, xr_e, eta, R_a, mnstar
        real(dp) :: qD, qi, ktf, beta, qs, wf, sf, L2, eta_n_0, G_k, Tp, eta_n
        real(dp) :: isospin, n_0, n_2, n_l, n_in
        real(dp), dimension(:), pointer :: y
        integer ,dimension(:), pointer :: iwork => null()
        real(dp), dimension(:), pointer :: work => null()
        real(dp), dimension(num_integration_variables) :: rtol, atol
        integer, dimension(:), pointer :: ipar => null()
        real(dp), dimension(:), pointer :: rpar => null()
        real(dp) :: h, kn_end, kn_start, kn, kfi
        integer :: liwork, lwork, itol, lipar, lrpar,idid, lout, iout, npts
        character(len=128) :: msg
        type(alert) :: status=alert(scope='n_phonon')

        ierr = 0
        allocate(y(num_integration_variables))

        kFn = (threepisquare*nn)**onethird
        kfi = (threepisquare*nn/ionic%Yn*(1.0-ionic%Yn)/ionic%A)**onethird

        call dop853_work_sizes( &
        &   num_integration_variables,num_integration_variables,liwork,lwork)
        allocate(iwork(liwork), work(lwork),ipar(num_ipar), rpar(num_rpar))
        iwork = 0
        iwork(5) = num_integration_variables
        work = 0.0

        itol = 0
        rtol = 1.0e-4
        atol = 1.0e-5
        iout = 0 ! solout is never called
        lout = error_unit
        lipar = num_ipar
        lrpar = num_rpar

        y(1) = 0.0

        !calculate n_in and R_a using Sly4 model for now
        isospin = 1.0 - 2.0*ionic%Z/ionic%A
        n_0 = 0.1740/(fm_to_cm)**3
        n_2 = -0.0157/(fm_to_cm)**3
        n_l = n_0+n_2*isospin**2
        n_in = n_l/2.0*(1.0+0.9208*isospin)
        R_a = (3.0*(ionic%A-ionic%Z)/4.0/pi/n_in)**onethird

        kn_start = int_default_starting_step
        kn_end = 2.0*kFn*R_a
        h = 0.0
        rpar(1) = temperature
        rpar(2) = ionic% Z
        rpar(3) = ionic% A
        rpar(4) = ionic% Yn
        rpar(5) = kfn
        rpar(6) = R_a

        call dop853(num_integration_variables, &
        &   structure_factor_phonon,kn_start,y,kn_end,h, &
        &   int_default_max_step_size,int_default_max_steps, &
        &   rtol,atol,itol, null_solout, iout, work, lwork, iwork, liwork,  &
        &   num_rpar, rpar, num_ipar, ipar, lout, idid)

        if (idid < 0) then
            write(msg,'(a,i0)') 'dop853 returned with error ',idid
            call status% report(msg)
            ierr = idid
        end if

        deallocate(work, iwork)

        Lambda_n_phonon = y(1)
        fac = 4.0/27.0/pi/hbar**3/clight**2
        V = neutron_potential(nn,n_in,ionic%Z,ionic%A) ! V in [ergs]
        kFn = (threepisquare*nn)**onethird
        xFn = hbar*kFn/Mneutron/clight
        mnstar = Mneutron
        Efn = 15.1*mev_to_ergs* &
        &   (ionic% Yn)**(2.0/3.0)*(nn*amu/ionic%Yn/1.0E14)**(2.0/3.0)* &
        &   (2.0*Mneutron/mnstar) + Mneutron*clight**2

        nu = fac*EFn*(nion/nn)*(V*R_a)**2*Lambda_n_phonon
    end function n_phonon

    function neutron_potential(nn,n_in,Z,A) result(V)
        ! eq. (23), Deibel et al. (2017)
        use constants_def
        real(dp), intent(in) :: nn, n_in, Z, A
        real(dp) :: V
        V = hbar**2*(threepisquare*n_in)**(2.0/3.0)/2.0/Mneutron &
        &   *(1.0 - (nn/n_in)**(2.0/3.0))
    end function neutron_potential

    subroutine structure_factor_phonon(n,x,h,y,dy,lrpar,rpar,lipar,ipar,ierr)
        ! integrand for eq. (16), Deibel et al. (2017)
        use constants_def

        integer, intent(in) :: n, lrpar, lipar
        real(dp), intent(in) ::  x,h
        real(dp), intent(inout) :: y(:)
        real(dp), intent(inout) :: dy(:)
        real(dp), intent(inout), pointer :: rpar(:)
        integer, intent(inout), pointer :: ipar(:)
        integer, intent(out) :: ierr
        real(dp) :: Yn, nn, nion, kfn
        real(dp) :: mion, omegaP, eta, Gamma, T, aion, A, Z, q, formfac
        real(dp) :: a1, um1, um2, w, w1, ssig, dskappa2, dskappa4, dskappa
        real(dp) :: R_a

        ierr = 0
        T = rpar(1)
        Z = rpar(2)
        A = rpar(3)
        Yn = rpar(4)
        kfn = rpar(5)
        R_a = rpar(6)

        nn = kfn**3/threepisquare
        nion = nn/Yn*(1.0-Yn)/A
        aion = (3.0/(4.0*pi*nion))**onethird
        mion = (A-Z)*Mneutron+Z*Mproton
        omegaP=(hbar*clight*4.*pi*Z**2*finestructure*nion/mion)**(1./2.)
        eta = boltzmann*T/(hbar*omegaP)
        Gamma = hbar*clight*Z**2*finestructure/(boltzmann*T*aion)
        a1= (x/R_a*aion)**2/(3.*Gamma*eta)
        um1=2.8
        um2=13.0
        w = a1*(um1*exp(-9.1*eta)+2.*eta*um2)/4.
        w1= a1*um2*eta**2/(2.*(eta**2+(um2/117.)**2)**(1./2.))
        ssig=exp(-2.*(w-w1))*(1.0-exp(-2.*w1))
        dskappa2 = a1*91.*eta**2*exp(-2.*w)/(1.+111.4*eta**2)**2
        dskappa4 = a1*0.101*eta**4/((0.06408+eta**2)*(0.001377+eta**2)**1.5)
        dskappa = dskappa2+dskappa4
        formfac = abs(3.0*(dsin(x)-(x)*dcos(x))/(x)**3)

        dy(1) = x**3*formfac**2*(ssig+(3.*(kfn*R_a/x)**2-0.5)*dskappa)

    end subroutine structure_factor_phonon

    subroutine structure_factor_impurity(n,x,h,y,dy,lrpar,rpar,lipar,ipar,ierr)
        ! integrand for eq. (20), Deibel et al. (2017)
        use constants_def

        integer, intent(in) :: n, lrpar, lipar
        real(dp), intent(in) ::  x,h
        real(dp), intent(inout) :: y(:)
        real(dp), intent(inout) :: dy(:)
        real(dp), intent(inout), pointer :: rpar(:)
        integer, intent(inout), pointer :: ipar(:)
        integer, intent(out) :: ierr
        real(dp) :: Yn, nn, nion, kfn
        real(dp) :: mion, omegaP, eta, Gamma, T, aion, A, Z, q, formfac
        real(dp) :: a1, um1, um2, w, w1, ssig, dskappa2, dskappa4, dskappa
        real(dp) :: R_a

        ierr = 0

        T = rpar(1)
        Z = rpar(2)
        A = rpar(3)
        Yn = rpar(4)
        kfn = rpar(5)
        R_a = rpar(6)

        nn = kfn**3/threepisquare
        nion = nn/Yn*(1.0-Yn)/A
        aion = (3.0/(4.0*pi*nion))**onethird
        mion = (A-Z)*Mneutron+Z*Mproton
        omegaP=(hbar*clight*4.*pi*Z**2*finestructure*nion/mion)**(1./2.)
        eta = boltzmann*T/(hbar*omegaP)
        Gamma = hbar*clight*Z**2*finestructure/(boltzmann*T*aion)
        a1= (x/R_a*aion)**2/(3.*Gamma*eta)
        um1=2.8
        um2=13.0
        w = a1*(um1*exp(-9.1*eta)+2.*eta*um2)/4.
        w1= a1*um2*eta**2/(2.*(eta**2+(um2/117.)**2)**(1./2.))
        ssig=exp(-2.*(w-w1))*(1.0-exp(-2.*w1))
        dskappa2 = a1*91.*eta**2*exp(-2.*w)/(1.+111.4*eta**2)**2
        dskappa4 = a1*0.101*eta**4/((0.06408+eta**2)*(0.001377+eta**2)**1.5)
        dskappa = dskappa2+dskappa4
        formfac = abs(3.0*(dsin(x)-(x)*dcos(x))/(x)**3)

        dy(1) = x**3*formfac**2
    end subroutine structure_factor_impurity

    function core_neutron_conductivity(nn,np,mneff,mpeff,T,Tcs) result (Kn)
        use constants_def
        use superfluid_def, only: max_number_sf_types, proton_1S0, neutron_1S0, neutron_3P2
        ! input nn, np: densities (fm**-3)
        ! T is temperature in K, Tcs are critical temperatures in K
        ! mneff = effective mass of neutron/neutron rest mass
        ! mpeff = effective mass of proton/proton rest mass
        real(dp), intent(in) :: nn,np,mneff,mpeff,T,Tcs(max_number_sf_types)
        real(dp) :: Kn
        real(dp) :: T8,tps,tns,tnt,istps,istns,vps,vns,vnt,yn,yp
        real(dp), parameter :: n0 = 0.16_dp  ! fm**-3
        real(dp) :: y, Sn1, Sn2, Sp1, Sp2
        real(dp) :: kFn, kFp, kFn2, kFp2
        real(dp) :: Kn1, Kn2, Kp1, Kp2, un1, un2, up1, up2
        real(dp) :: nu_nn, nu_np
        real(dp) :: mneffinv2, mpeffinv2

        mneffinv2 = 1.0/mneff**2
        mpeffinv2 = 1.0/mpeff**2

        tps = T/Tcs(proton_1S0)
        tns = T/Tcs(neutron_1S0)
        tnt = T/Tcs(neutron_3P2)

        istps = 1./sqrt(tps)
        istns = 1./sqrt(tns)
        vps = 0.0
        if(tps < 1.0) vps = sqrt(1.-tps)*(1.456+istps*(-0.157+istps*1.764))
        vns = 0.0
        if(tns < 1.0) vns = sqrt(1.-tns)*(1.456+istns*(-0.157+istns*1.764))
        vnt = 0.0
        if(tnt < 1.0) vnt = sqrt(1.-tnt)*(0.7893+1.188/tnt)

        yn = max(vns,vnt)
        yp = vps

        kFn = (threepisquare*nn)**onethird
        kFp = (threepisquare*np)**onethird
        kFn2 = kFn**2
        kFp2 = kFp**2

        Sn1 = 14.57/kFn**1.5 * (1.0-0.0788*kFn+0.0883*kFn2)/(1.0-0.1114*kFn)
        Sn2 = 7.880/kFn2 * (1.0-0.2241*kFn+0.2006*kFn2)/(1.0-0.1742*kFn)
        Sp1 = 0.8007*kFp/kFn**2 *  &
        &   (1.0+31.28*kFp-0.0004285*kFp**2 + 26.85*kFn + 0.08012*kFn**2)/ &
        &   (1.0-0.5898*kFn+0.2368*kFn**2+0.5838*kFp**2+0.884*kFn*kFp)
        Sp2 = 0.3830*kFp**4/kFn**5.5*(1.0+102.0*kFp+53.91*kFn)/ &
        &   (1.0-0.7087*kFn+0.2537*kFn**2+9.404*kFp**2-1.589*kFn*kFp)

        ! in-medium corrections
        !       un1 = kFn-1.665
        ! Kn1 = mneffinv2 * (0.4583+0.892*un1**2-0.5497*un1**3-0.06205*kFp+0.04022*kFp**2+0.2122*un1*kFp)
        ! un2 = kFn-1.556
        ! Kn2 = mneffinv2 * (0.4891+1.111*un2**2-0.2283*un2**3+0.01589*kFp-0.02099*kFp**2+0.2773*un2*kFp)
        !       up1 = kFn-2.126
        ! Kp1 = mpeffinv2 * (0.04377+1.1*up1**2+0.1180*up1**3+0.1626*kFp+0.3871*up1*kFp-0.2990*up1**4)
        ! up2 = kFn-2.116
        ! Kp2 = mpeffinv2 * (0.0001313+1.248*up2**2+0.2403*up2**3 &
        !    & +0.3257*kFp+0.5536*up2*kFp-0.3237*up2**4+0.09786*up2**2*kFp)

        Kn1 = 1.0_dp
        Kn2 = 1.0_dp
        Kp1 = 1.0_dp
        Kp2 = 1.0_dp

        ! put the whole thing together
        T8 = T*1.0e-8_dp
        nu_nn = 3.48e15*T8**2 *mneff**3 * &
        &      (Sn2*Kn2*Rn2(yn)+3.0*Sn1*Kn1*(Rn1(yn)-Rn2(yn)))
        nu_np = 3.48e15*T8**2*mneff*mpeff**2* &
        &      (Sp2*Kp2*Rp2(yn,yp)+0.5*Kp1*Sp1*(3.0*Rp1(yn,yp)-Rp2(yn,yp)))

        Kn = 7.2e23*T8*RC(yn)**2 /mneff * (1.0e15/(nu_nn+nu_np)) * nn/n0

    contains
        function RC(y)
            real(dp), intent(in) :: y
            real(dp) :: RC,y2
            y2 = y**2
            RC = (0.647+sqrt(0.353**2 + 0.109*y2))**1.5 &
            &       * exp(1.39-sqrt(1.39**2+y2))
        end function RC
        function Rn1(y)
            real(dp), intent(in) :: y
            real(dp) :: Rn1, y2
            y2 = y**2
            Rn1 = twothird*(0.9468+sqrt(0.0532**2+0.5346*y2))**3 &
            & * exp(0.377-sqrt(0.377**2 + 4.0*y2)) &
            & + onethird*(1.0+1.351*y2)**2 &
            & * exp(0.169-sqrt(0.169**2+9.0*y2))
        end function Rn1
        function Rn2(y)
            real(dp), intent(in) :: y
            real(dp) :: Rn2,y2
            y2 = y**2
            Rn2 = 0.5*(0.6242+sqrt(0.3758**2 + 0.07198*y2))**2  &
            & * exp(3.6724 - sqrt(3.6724**2+4.0*y2))  &
            & + 0.5*(1.0+0.01211*y2)**9 &
            & * exp(7.5351-sqrt(7.5351**2+9.0*y2))
        end function Rn2
        function Rp1(yn,yp)
            real(dp), intent(in) :: yn,yp
            real(dp) :: Rp1
            real(dp) :: yn2,yp2,uplus, uminus, un, up, yminus, yplus
            yn2 = yn**2
            yp2 = yp**2
            if (yn2 > 0.0 .and. yp2 == 0.0) then
                Rp1 = (0.4459 + sqrt(0.5541**2 + 0.03016*yn2))**2 &
                & * exp(2.1178-sqrt(2.1178**2 + yn2))
            else if (yn2 == 0.0 .and. yp2 > 0.0) then
                Rp1 = 0.5*(0.3695+sqrt(0.6305**2+0.01064*yp2)) &
                & * exp(2.4451-sqrt(2.4451**2+yp2)) &
                & + 0.5*(1.0+0.1917*yp2)**1.4 &
                & * exp(4.6627-sqrt(4.6627**2+4.0*yp2))
            else if (yn2 > 0.0 .and. yp2 > 0.0) then
                yminus = min(yn, yp)
                yplus = max(yn, yp)
                uplus = sqrt(yplus**2+1.485**2)-1.485
                uminus = sqrt(yminus**2+1.485**2)-1.485
                un = sqrt(yn2+1.485**2)-1.485
                up = sqrt(yp2+1.485**2)-1.485
                Rp1 = exp(-uplus-uminus)*(0.7751+0.4823*un+0.1124*up &
                & + 0.04991*un**2+0.08513*un*up+0.01284*un**2*up) &
                & + exp(-2.0*uplus) *(0.2249+0.3539*uplus &
                &       -0.2189*uminus-0.6069*un*uminus + 0.7362*up*uplus)
            else
                Rp1 = 1.0
            end if
        end function Rp1
        function Rp2(yn,yp)
            real(dp), intent(in) :: yn,yp
            real(dp) :: Rp2, yn2, yp2
            real(dp) :: uplus,uminus,un,up,yminus,yplus
            yn2 = yn**2
            yp2 = yp**2
            if (yn2>0.0 .and. yp2 == 0.0) then
                Rp2 = (0.801+sqrt(0.199**2+0.04645*yn2))**2  &
                & * exp(2.3569-sqrt(2.3569**2+yn2))
            else if (yn2 == 0.0 .and. yp2 > 0.0) then
                Rp2 = 0.0436*(sqrt(4.345**2+19.55*yp2)-3.345) &
                & * exp(2.0247-sqrt(2.0247**2 + yp2)) &
                & + 0.0654*exp(8.992-sqrt(8.992**2+1.5*yp2)) &
                & + 0.891*exp(9.627-sqrt(9.627**2+9.0*yp2))
            else if (yn2 > 0.0 .and. yp2 > 0.0) then
                yplus = max(yn,yp)
                yminus = min(yn,yp)
                uplus = sqrt(yplus**2+1.761**2)-1.761
                uminus = sqrt(yminus**2+1.761**2)-1.761
                un  = sqrt(yn2+1.761**2)-1.761
                up = sqrt(yp2+1.761**2)-1.761
                Rp2 = exp(-uplus-uminus)*(1.1032+0.8645*un+0.2042*up &
                & + 0.07937*un**2+0.1451*un*up+0.01333*un**2*up) &
                & + exp(-2.0*uplus)*(-0.1032-0.2340*uplus+0.06152*un*uplus  &
                & + 0.7533*un*uminus-1.007*up*uplus)
            else
                Rp2 = 1.0
            end if
        end function Rp2
    end function core_neutron_conductivity

end module neutron_conductivity


! =========================================================================
elemental function gsw_gibbs_ice (nt, np, t, p)
! =========================================================================
!
!  Ice specific Gibbs energy and derivatives up to order 2.
!
!  nt  =  order of t derivative                      [ integers 0, 1 or 2 ]
!  np  =  order of p derivative                      [ integers 0, 1 or 2 ]
!  t   =  in-situ temperature (ITS-90)                            [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!
!  gibbs_ice = Specific Gibbs energy of ice or its derivatives.
!            The Gibbs energy (when nt = np = 0) has units of:     [ J/kg ]
!            The temperature derivatives are output in units of:
!                                                      [ (J/kg) (K)^(-nt) ]
!            The pressure derivatives are output in units of:
!                                                     [ (J/kg) (Pa)^(-np) ]
!            The mixed derivatives are output in units of:
!                                           [ (J/kg) (K)^(-nt) (Pa)^(-np) ]
!  Note. The derivatives are taken with respect to pressure in Pa, not
!    withstanding that the pressure input into this routine is in dbar.
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_t0, db2pa

use gsw_mod_gibbs_ice_coefficients

use gsw_mod_kinds

implicit none

integer, intent(in) :: nt, np
real (r8), intent(in) :: t, p

real (r8) :: gsw_gibbs_ice

real (r8) :: dzi, g0, g0p, g0pp, sqrec_pt
complex (r8) :: r2, r2p, r2pp, g, sqtau_t1, sqtau_t2, tau, tau_t1, tau_t2

real (r8), parameter :: s0 = -3.32733756492168e3_r8

tau = (t + gsw_t0)*rec_tt

dzi = db2pa*p*rec_pt

if (nt.eq.0 .and. np.eq.0) then

    tau_t1 = tau/t1
    sqtau_t1 = tau_t1*tau_t1
    tau_t2 = tau/t2
    sqtau_t2 = tau_t2*tau_t2

    g0 = g00 + dzi*(g01 + dzi*(g02 + dzi*(g03 + g04*dzi)))

    r2 = r20 + dzi*(r21 + r22*dzi)

    g = r1*(tau*log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) &
        + t1*(log(1.0_r8 - sqtau_t1) - sqtau_t1)) &
	+ r2*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) &
	+ t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2))

    gsw_gibbs_ice = g0 - tt*(s0*tau - real(g))

elseif (nt.eq.1 .and. np.eq.0) then

    tau_t1 = tau/t1
    tau_t2 = tau/t2

    r2 = r20 + dzi*(r21 + r22*dzi)

    g = r1*(log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) - 2.0_r8*tau_t1) &
        + r2*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2)

    gsw_gibbs_ice = -s0 + real(g)

elseif (nt.eq.0 .and. np.eq.1) then

    tau_t2 = tau/t2
    sqtau_t2 = tau_t2*tau_t2

    g0p = rec_pt*(g01 + dzi*(2.0_r8*g02 + dzi*(3.0_r8*g03 + 4.0_r8*g04*dzi)))

    r2p = rec_pt*(r21 + 2.0_r8*r22*dzi)

    g = r2p*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) &
        + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2))

    gsw_gibbs_ice = g0p + tt*real(g)

elseif (nt.eq.1 .and. np.eq.1) then

    tau_t2 = tau/t2

    r2p = rec_pt*(r21 + 2.0_r8*r22*dzi)

    g = r2p*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2)

    gsw_gibbs_ice = real(g)

elseif (nt.eq.2 .and. np.eq.0) then

    r2 = r20 + dzi*(r21 + r22*dzi)

    g = r1*(1.0_r8/(t1 - tau) + 1.0_r8/(t1 + tau) - 2.0_r8/t1) &
        + r2*(1.0_r8/(t2 - tau) + 1.0_r8/(t2 + tau) - 2.0_r8/t2)

    gsw_gibbs_ice = rec_tt*real(g)

elseif (nt.eq.0 .and. np.eq.2) then

    sqrec_pt = rec_pt*rec_pt

    tau_t2 = tau/t2
    sqtau_t2 = tau_t2*tau_t2

    g0pp = sqrec_pt*(2.0_r8*g02 + dzi*(6.0_r8*g03 + 12.0_r8*g04*dzi))

    r2pp = 2.0_r8*r22*sqrec_pt

    g = r2pp*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) &
        + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2))

   gsw_gibbs_ice = g0pp + tt*real(g)

end if

return
end function

!--------------------------------------------------------------------------


      SUBROUTINE DT_CROMSC(Pin,R,Pout,Incl)

C***********************************************************************
C Cronin-Effect. Multiple scattering of one parton passing through     *
C nuclear matter.                                                      *
C            PIN(4)       input 4-momentum of parton                   *
C            POUT(4)      4-momentum of parton after mult. scatt.      *
C            R(3)         spatial position of parton in target nucleus *
C            INCL = 1     multiple sc. in projectile                   *
C                 = 2     multiple sc. in target                       *
C This is a revised version of the original version written by J. Ranft*
C This version dated 17.01.95 is written by S. Roesler.                *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION a , cfe , costh , cosx , cosxn , cosy , cosyn ,
     &                 cosz , coszn , dist , pe , Pin , Pout , ptot ,
     &                 pz , R , r1 , r2 , rncl , rtesq
      DOUBLE PRECISION sfe , sinth , theta , theto , TINY3 , tmp , ZERO
      INTEGER Incl , k , mode , ncback
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)

      LOGICAL lstart

C rejection counter
      INCLUDE 'inc/dtrejc'
C Glauber formalism: collision properties
      INCLUDE 'inc/dtglcp'
C various options for treatment of partons (DTUNUC 1.x)
C (chain recombination, Cronin,..)
      INCLUDE 'inc/dtchai'

      DIMENSION Pin(4) , Pout(4) , R(3)

      DATA lstart/.TRUE./

      IRCron(1) = IRCron(1) + 1

      IF ( lstart ) THEN

         IF ( LPRi.GT.4 ) WRITE (LOUt,99010) CROnco
99010    FORMAT (/,1X,'CROMSC:  multiple scattering of chain ends',
     &           ' treated',/,10X,'with parameter CRONCO = ',F5.2)
         lstart = .FALSE.
      END IF

      ncback = 0
      rncl = RPRoj
      IF ( Incl.EQ.2 ) rncl = RTArg

C Lorentz-transformation into Lab.
      mode = -(Incl+1)
      CALL DT_LTNUC(Pin(3),Pin(4),pz,pe,mode)

      ptot = SQRT(Pin(1)**2+Pin(2)**2+pz**2)
      IF ( ptot.LE.8.0D0 ) THEN

         IRCron(2) = IRCron(2) + 1
      ELSE

C direction cosines of parton before mult. scattering
         cosx = Pin(1)/ptot
         cosy = Pin(2)/ptot
         cosz = pz/ptot

         rtesq = R(1)**2 + R(2)**2 + R(3)**2 - rncl**2
         IF ( rtesq.LT.-TINY3 ) THEN

C calculate distance (DIST) from R to surface of nucleus (radius RNCL)
C in the direction of particle motion

            a = cosx*R(1) + cosy*R(2) + cosz*R(3)
            tmp = a**2 - rtesq
            IF ( tmp.LT.ZERO ) THEN
               IRCron(3) = IRCron(3) + 1
            ELSE
               dist = -a + SQRT(tmp)

C multiple scattering angle
               theto = CROnco*SQRT(dist)/ptot
               IF ( theto.GT.0.1D0 ) theto = 0.1D0

C Gaussian sampling of spatial angle
 10            CALL DT_RANNOR(r1,r2)
               theta = ABS(r1*theto)
               IF ( theta.GT.0.3D0 ) THEN
                  IRCron(2) = IRCron(2) + 1
               ELSE
                  CALL DT_DSFECF(sfe,cfe)
                  costh = COS(theta)
                  sinth = SIN(theta)

C new direction cosines
                  CALL DT_MYTRAN(1,cosx,cosy,cosz,costh,sinth,sfe,cfe,
     &               cosxn,cosyn,coszn)

                  Pout(1) = cosxn*ptot
                  Pout(2) = cosyn*ptot
                  pz = coszn*ptot
C Lorentz-transformation into nucl.-nucl. cms
                  mode = Incl + 1
                  CALL DT_LTNUC(pz,pe,Pout(3),Pout(4),mode)

C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
                  IF ( (ABS(Pin(4)-Pout(4))/Pin(4)).GT.0.05D0 ) THEN
                     theto = theto/2.0D0
                     ncback = ncback + 1
                     IF ( MOD(ncback,200).EQ.0 ) THEN

                        IF ( LPRi.GT.4 ) WRITE (LOUt,99020) theto ,
     &                       Pin , Pout
99020                   FORMAT (1X,
     &                     'CROMSC: inconsistent scattering angle ',
     &                     E12.4,/,1X,'        PIN :',4E12.4,/,1X,
     &                     '       POUT:',4E12.4)
                        IRCron(2) = IRCron(2) + 1
                        GOTO 100
                     END IF
                     GOTO 10
                  END IF

                  RETURN
               END IF
            END IF
         END IF
      END IF

 100  DO k = 1 , 4
         Pout(k) = Pin(k)
      END DO
      END SUBROUTINE


      subroutine bmp_det_pond

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    the purpose of this program is to read in data from the detention pond
!!    input file (.dtp) and perform computations

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~ ~ ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dtp_evrsv      |none          |detention pond evaporation coefficient
!!    dtp_weirtype(:)|none          |Type of weir: 1 rectangular and 2 circular
!!    dtp_numweir(:) |none          |Total number of weirs in the BMP
!!    dtp_numstage(:)|none          |Total number of stages in the weir
!!    dtp_wdratio(:,:)|none         |Width depth ratio (rectangular wier) at different stages
!!    dtp_depweir(:,:)|m            |Depth of rectangular wier at different stages
!!    dtp_diaweir(:,:)|m            |Diameter of circular wier at different stages
!!    dtp_retperd(:,:)|years        |Return period at different stages
!!    dtp_pcpret(:,:)|mm            |precipitation for different return periods (not used)
!!    dtp_cdis(:,:)  |none          |coeffieicne of discharge at different stages
!!    hhvaroute(2,:,:) |m^3 H2O     |water
!!    hhvaroute(3,:,:) |metric tons |sediment or suspended solid load
!!    i_mo           |none          |current month of simulation
!!    sub_subp_dt(:,:)  |mm H2O      |precipitation for time step in subbasin
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    name           |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    hhvaroute(2,:,:) |m^3 H2O    |water
!!    hhvaroute(3,:,:) |metric tons|sediment or suspended solid load
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ii          |none          |time step counter
!!    k           |none          |weir stage counter
!!    titldum     |NA            |dummy string
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT:  surf_seep,surf_evap,water_depth
!!    Intrinsic: Log,exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm
      implicit none

      character (len=80) :: titldum
      integer :: ii, k, sb
      real*8 :: qin,qout,qpnd,qpnd_last,sedin,sedout,sedpnd,spndconc,
     &        qdepth,sedpnd_last,
     &        watdepact,qstage,backup_length,seep_sa,evap_sa,pcp_vol,
     &        evap_vol,seep_vol,warea,pi,qovmax,qaddon,depaddon

      pi = 3.14159
      sb = inum1
      qout=0.;qpnd_last=0.;sedout=0.;depaddon=0.;sedpnd_last=0.

      if (iyr<dtp_iyr(sb) .or.
     &(iyr==dtp_iyr(sb) .and. i_mo<dtp_imo(sb))) then
         return
      endif

      !! Get initial values from previous day
      qpnd = dtp_ivol(sb) !m^3
      sedpnd = dtp_ised(sb) !tons

      !! Storage capacity under addon
      qaddon = dtp_addon(sb,1)**3./(3.*dtp_lwratio(sb)*ch_s(2,sb)**2.) !m3 Note: V = d^3 / (3*R*S^2) |Modify by J. Osorio (3/19/2013)

      !!	iterate for subdaily flow/sediment routing
      do ii=1,nstep

         if (ii==1) qpnd_last=dtp_ivol(sb)

         qout = 0.; qovmax = 0; depaddon = 0.
         qin = hhvaroute(2,ihout,ii) !m^3
         sedin = hhvaroute(3,ihout,ii)  !tons

	   !! Estimate water depth
         qdepth = (3.*qpnd*dtp_lwratio(sb)*ch_s(2,sb)**2)**0.33333

	   !! skip to next time step if no ponding occurs
!	   if (qdepth<=0.0001) cycle

         if (dtp_stagdis(sb)==0) then
          !! Calculate weir outflow
          do k = 1, dtp_numstage(sb)
            qstage = 0.

            !! calculate weir discharge

	        if (dtp_weirtype(sb,k)==2) then
	        !! Circular weir
	           dtp_depweir(sb,k) = dtp_diaweir(sb,k) + dtp_addon(sb,k)

	           if (qdepth>dtp_depweir(sb,k)) then
               !! Fully submerged
                  qdepth = qdepth - dtp_depweir(sb,k)
                  watdepact = qdepth + dtp_diaweir(sb,k) / 2
  	            warea = 3.14159 * dtp_diaweir(sb,k) ** 2 / 4.

		          !! orifice equation
   	            qstage = dtp_cdis(sb,k) * 0.6 * warea *
     & 	               sqrt(19.6 * watdepact) !m3/s/unit
                  qstage = qstage * dtp_numweir(sb) * 60. * idt !m^3
                 else
               !! Partially submerged
                  watdepact = max(qdepth - dtp_addon(sb,k),0.)
                  dtp_wrwid(sb,k) = dtp_diaweir(sb,k) * 0.667

		          !! weir/orifice discharge
		          qstage = dtp_cdis(sb,k) * 1.84 * dtp_wrwid(sb,k) *
     &		            watdepact ** 1.5 !m3/s
		          qstage = qstage * dtp_numweir(sb) * 60. * idt !m^3
                 end if

	        else
	        !! Rectangular weir
	           watdepact = max(qdepth - dtp_addon(sb,k),0.)

               !! Estimate weir/orifice discharge
		       qstage = dtp_cdis(sb,k) * 1.84 * dtp_wrwid(sb,k) *
     &		       watdepact ** 1.5 !m3/s     The Bureau of Reclamation, in their Water Measurement Manual, SI units
		       qstage = qstage * dtp_numweir(sb) * 60. * idt !m^3

	        end if

            qout = qout + qstage
	      end do

	      !Limit total outflow amount less than available water above addon
	      if(qout>qpnd-qaddon) qout = max(qpnd - qaddon,0.)

          !! Flow over the emergency weir
          watdepact = qdepth - (dtp_depweir(sb,1) + dtp_addon(sb,1))
          if (dtp_weirtype(sb,k)==1 .and. watdepact>0.) then
            qstage = dtp_cdis(sb,k) * 1.84 *
     &             dtp_totwrwid(sb) * (watdepact ** 1.5) * 60. * idt !m3/s
            qout = qout + qstage
          end if

		 else
		 !! Use stage-discharge relationship if available
		  if (dtp_stagdis(sb)==1) then
		     select case(dtp_reltype(sb))
		       case(1) !! 1 is exponential function
		         qout = dtp_coef1(sb) * exp(dtp_expont(sb) * qdepth) +
     &	             dtp_intcept(sb)
		       case(2) !! 2 is Linear function
		         qout = dtp_coef1(sb) * qdepth + dtp_intcept(sb)
		       case(3) !! 3 is logarthmic function
		         qout = dtp_coef1(sb) * log(qdepth) + dtp_intcept(sb)
		       case(4) !! 4 is power function
		         qout = dtp_coef1(sb) * (qdepth**3) + dtp_coef2(sb) *
     & 	         (qdepth**2) + dtp_coef3(sb) * qdepth + dtp_intcept(sb)
               case(5)
                 qout = dtp_coef1(sb)*(qdepth**dtp_expont(sb))+
     &                  dtp_intcept(sb)
			 end select
		     qout = qout * 60. * idt
	      end if  !! end of stage-discharge calculation
	     end if

         !! Check mass balance for flow
         if (qout>qpnd) then !no detention occurs
            qout = qpnd
            qpnd = 0.
         else !detention occurs
            !!	Estimating surface area of water
            backup_length = qdepth / ch_s(2,sb)
            seep_sa = backup_length/dtp_lwratio(sb)
     &                + (4. * dtp_lwratio(sb) * qdepth**2) / 3.      !! Note: SSA = w + (4*l*d^2)/(3*w) |Modify by J. Osorio (3/20/2013)
            evap_sa = (2. * backup_length**2) / (3. * dtp_lwratio(sb)) !! Note: ESA = 2 * w * l / 3 |Modify by J. Osorio (3/20/2013)

            !! converting surface area to hectares (ha)
            seep_sa = seep_sa / 10000.0
            evap_sa = evap_sa / 10000.0

            !!	Estimate rainfall, evapotranspiration, and seepage
            pcp_vol  = 10.0 * sub_subp_dt(sb,ii) * evap_sa !m^3
            evap_vol = 10.0 * dtp_evrsv(sb) * pet_day * evap_sa !m^3
            seep_vol = 10.0 * ch_k(2,sb) * seep_sa * idt / 60. !m^3

            !!	Check mass balance for water in the pond
            qpnd = qpnd_last + qin + pcp_vol - qout - evap_vol
     &                - seep_vol
            if (qpnd<0) qpnd = 0.
         end if

         if (qpnd>1e-6) then
            spndconc = sedpnd / qpnd !initial sed conc, tons/m3
         else
            spndconc = 0
         end if

         qpnd_last=qpnd

         !! Mass balance for sediment
         sedout = spndconc * qout !tons
         sedpnd = sedpnd_last + sedin - sedout
         if (sedout > sedpnd) then
             sedout = sedpnd
             sedpnd = 0
         end if

         sedpnd_last=sedpnd

   	   !! Store flow/sediment out of the pond at the subbasin outlet
   	   hhvaroute(2,ihout,ii) = max(0.,qout)
   	   hhvaroute(3,ihout,ii) = max(0.,sedout)

         write (33333,'(8f10.2,4f10.6)') qin,
     & qpnd,qout,qstage,pcp_vol,evap_vol,seep_vol,sedin,sedpnd,sedout

      end do  !! Outermost do loop ends here

      ! Store end-of-day values for next day
      dtp_ivol(sb) = qpnd !m^3
      dtp_ised(sb) = sedpnd !tons

      end subroutine bmp_det_pond