PROGRAM GTPE2_HT
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Mech. Eng. Department"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "GTPE2_HT"
 WRITE(*,*) "Dimension  : 	2D"
 WRITE(*,*) "Atmosphere : 	Homogeneous"
 WRITE(*,*) "Boundary   : 	Generalized Terrain"
 WRITE(*,*) "Impedance  : 	Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Enter inputs L, f, zs, As, angle, dc"
 WRITE(*,*) ""
 READ *, L, F, ZS, AS, ANGLE, DC
 WRITE(*,*) ""
 WRITE(*,*) "Store output ? (Y or N)"
 WRITE(*,*) ""
 READ *, OUTPUT
 !-----------------------------------------------------------
 !----------------------------------------------------------
 C0     = 343.0_DP
 LMBDA0 = C0/F
 K0     = 2*PI*F/C0
 DZ     = LMBDA0/10
 DR     = LMBDA0/10
 H      = 100*LMBDA0
 HA     = 30*LMBDA0
 N      = FLOOR(H/DZ)
 M      = FLOOR(L/DR)
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS     = MAX(1,FLOOR(ZS/DZ))
 NA     = FLOOR(HA/DZ)
 A      = IM/(2.0_DP*K0*DZ**2)
 KU     = 1
 KL     = 1
 NDIAG  = KU+KL+1
 WIDE   = 0
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Memory allocation
 ALLOCATE(PHI(N,M+1), T(N,N), S(N,N), M1(N,N), &
 M2(N,N), I(N), P(N,M), LP(N,M), LP2(N,M), LPG(M), LPG2(M), E(N,N), &
 MB2(NDIAG,N), MB1(NDIAG,N), TEMP(N,1), M1T(N,N), M2T(N,N), IPIV(N), &
 LIN(-2:M+2) MCOND(M,2), &
 MB1T(NDIAG,N), MB2T(KL+NDIAG,N), MT(NDIAG,N), MS(NDIAG,N), RGE(-1:M+2))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Atmosphere density and wave velocity
 ALLOCATE(C(N),K(N),DK2(N),ALT(N))
 Z0 = 0.5_DP
 DO NZ = 1,N
  ALT(NZ) = NZ*DZ
  C(NZ)   = C0+DC*LOG(1+Z/Z0)
  K(NZ)   = K0
  DK2(NZ) = K(NZ)**2-K0**2
 END DO
 !Absorbing layer (PML)
 DO NZ=N-NABL,N THEN
  K(NZ)  = K0+AS*IM*(NZ-N+NABL)**2/NABL**2
 END
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Terrain Boundary condition
 ALLOCATE(LIN(0:M),X(M),TERR(M),TERR1(M),TERR2(M),SLOPX(M))
 ALLOCATE(ALPHA(M),BETA(M),X(M))
 LIN(0) = 0
 THETA   = ANGLE*PI/180.0_DP
 X0      = L/2.0_DP
 S       = L/5.0_DP
 H0      = SQRT(EXP(1.0_DP)/2.0_DP)*S*ATAN(THETA)
 DO MX = 0,M
  GHX       = GHILL(H0,X0,S,MX*DR)
  TERR(MX)  = GHX(1)
  TERR1(MX) = GHX(2)
  TERR2(MX) = GHX(3)
  X(MX)     = MX*DR
  LIN(MX)   = LIN(MX-1)+(1+TERR1(MX))*DR
  SLOPE(MX) = ATAN(TERR1(MX))
  !--------
  ALPHA(MX) = TERR1(MX)**2+1
  BETA(MX)  = 2*IM*K0*TERR1(MX)+TERR2(MX)
  XI(MX)    = TERR2(MX)-2*IM*K0*TERR1(MX)
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Starting field - Initial Condition
 ALLOCATE(PHI(N,M+1),PC(N,M),P(N,M),Q(N,M))
 A0 = 1.3717_DP
 A2 = -0.3701_DP
 B  = 3.0_DP
 DO NZ = 1,N
 PHI(NZ,1) = SQRT(IM*K0)* &
             ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B)+ &
             (A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Matrix building
 FD1 = (/ -0.5_DP, 0.0_DP, 0.5_DP /)
 FD2 = (/ 1.0_DP, -2.0_DP, 1.0_DP /)
 T = BBAND(FD2,N,KL,KU)
 S = BBAND(FD1,N,KL,KU)
 G = DIAG(DK2,N)
 D = D2B(G,N,KL,KU)
 WRITE(*,*) "Wide-angle order : ", WIDE
 PHI_G(-1:0) = 0.0_DP
 PHI_T(-1:0) = 0.0_DP
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 CALL CPU_TIME(TI)
 DO MX = 2,M+1
  WRITE(*,*) "Step :", MX-1, "out of", M
  !-------------------------------
  !-------------------------------
  !Terrain integration
  A_ALPHA = DR*(ALPHA(MX-2)/3+ALPHA(MX-1)/6)
  B_ALPHA = DR*(ALPHA(MX-2)/6+ALPHA(MX-1)/3)
  A_XI    = DR*(XI(MX-2)/3+XI(MX-1)/6)
  B_XI    = DR*(XI(MX-2)/6+XI(MX-1)/3)
  !-------------------------------
  !-------------------------------
  !GTPE Coefficients updating
  SELECT CASE (WIDE)
   CASE(0)
    E2 = I-(IM*DR/(2*K0))*D
    E1 = I+(IM*DR/(2*K0))*D
    D2 =  B_XI/(2*IM*K0*DZ)
    D1 = -A_XI/(2*IM*K0*DZ)
    C2 =  B_ALPHA/(2*IM*K0*DZ**2)
    C1 = -A_ALPHA/(2*IM*K0*DZ**2)
   CASE(1)
    E2 = I+(1/(2*K0))*(1/(2*K0)-IM*DR)*D
    E1 = I+(1/(2*K0))*(1/(2*K0)+IM*DR)*D
    D2 = -(IM*BETA(MX-1)/(2*K0)+2*TERR1(MX-1)-B_XI)/(2*IM*K0*DZ)
    D1 = -(IM*BETA(MX-2)/(2*K0)+2*TERR1(MX-2)+A_XI)/(2*IM*K0*DZ)
    C2 = (IM*ALPHA(MX-1)/(2*K0)+B_ALPHA)/(2*IM*K0*DZ**2)
    C1 = (IM*ALPHA(MX-2)/(2*K0)-A_ALPHA)/(2*IM*K0*DZ**2)
  END SELECT
  !-------------------------------
  !-------------------------------
  !Boundary Conditions RHS
  EPS2 = 2.0_DP*DZ*COS(SLOPE(MX-1))
  DG2  =          (3.0_DP/EPS2)+(3.0_DP/(2.0_DP*DR)+IM*K0)*SIN(SLOPE(MX-1))
  DT2  = -IM*K(M)+(3.0_DP/EPS2)-(3.0_DP/(2.0_DP*DR)+IM*K0)*SIN(SLOPE(MX-1))
  UG2  = 4.0_DP/(DG2*EPS2)
  UT2  = 4.0_DP/(DT2*EPS2)
  VG2  = -UG2/4.0_DP
  VT2  = -UT2/4.0_DP
  WG2  =  2.0_DP*SIN(SLOPE(MX-1))/(DG2*DR)
  WT2  = -2.0_DP*SIN(SLOPE(MX-1))/(DT2*DR)
  YG2  = -WG2/4.0_DP
  YT2  = -WT2/4.0_DP
  !Boundary Conditions LHS
  EPS1 = 2.0_DP*DZ*COS(SLOPE(MX-2))
  DG1  =          (3.0_DP/EPS1)+(3.0_DP/(2.0_DP*DR)+IM*K0)*SIN(SLOPE(MX-2))
  DT1  = -IM*K(M)+(3.0_DP/EPS1)-(3.0_DP/(2.0_DP*DR)+IM*K0)*SIN(SLOPE(MX-2))
  UG1  = 4.0_DP/(DG1*EPS1)
  UT1  = 4.0_DP/(DT1*EPS1)
  VG1  = -UG1/4.0_DP
  VT1  = -UT1/4.0_DP
  WG1  =  2.0_DP*SIN(SLOPE(MX-2))/(DG1*DR)
  WT1  = -2.0_DP*SIN(SLOPE(MX-2))/(DT1*DR)
  YG1  = -WG1/4.0_DP
  YT1  = -WT1/4.0_DP
  !--------------
  PHIG(MX-1) = UG2*PHI(1,MX-1)+VG2*PHI(2,MX-1)  +WG2*PHIG(MX-2)+YG2*PHIG(MX-3)
  PHIT(MX-1) = UT2*PHI(N,MX-1)+VT2*PHI(N-1,MX-1)+WT2*PHIT(MX-2)+YT2*PHIT(MX-3)
  !-------------------------------
  !-------------------------------
  !Updating Right-hand side
  T2 = T
  S2 = S
  T2(KL+1,1)      = T2(KL+1,1)+UG2
  T2(KL+1,N)      = T2(KL+1,N)+UT2
  T2(KL,2)        = T2(KL,2)+VG2
  T2(KL+KU+1,N-1) = T2(KL+KU+1,N-1)+VT2
  S2(KL+1,1)      = S2(KL+1,1)-UG2
  S2(KL+1,N)      = S2(KL+1,N)+UT2
  S2(KL,2)        = S2(KL,2)-VG2
  S2(KL+KU+1,N-1) = S2(KL+KU+1,N-1)+VT2
  !Updating Left-hand side
  T1 = T
  S1 = S
  T1(KL+1,1)      = T1(KL+1,1)+UG1
  T1(KL+1,N)      = T1(KL+1,N)+UT1
  T1(KL,2)        = T1(KL,2)+VG1
  T1(KL+KU+1,N-1) = T1(KL+KU+1,N-1)+VT1
  S1(KL+1,1)      = S1(KL+1,1)-UG1
  S1(KL+1,N)      = S1(KL+1,N)+UT1
  S1(KL,2)        = S1(KL,2)-VG1
  S1(KL+KU+1,N-1) = S1(KL+KU+1,N-1)+VT1
  !--------------
  MB2(KL+1:KL+NDIAG,:) = C2*T2+D2*S2+E2
  MB1                  = C1*T1+D1*S1+E1
  !-------------------------------
  !-------------------------------
  !Right hand side multiplication
  CALL ZGBMV('N',N,N,KL,KU,A,MB1,KL+KU+1,PHI(1:N,MX-1),1,B,TEMP,1)
  TEMP(1) = TEMP(1)+C1*(WG1*PHIG(MX-3)+YG1*PHIG(MX-4))        &
                   -D1*(WG1*PHIG(MX-3)+YG1*PHIG(MX-4))/2.0_DP &
                   -C2*(WG2*PHIG(MX-2)+YG2*PHIG(MX-3))        &
                   +D2*(WG2*PHIG(MX-2)+YG2*PHIG(MX-3))/2.0_DP
  TEMP(N) = TEMP(N)+C1*(WG1*PHIT(MX-3)+YG1*PHIT(MX-4))        &
                   -D1*(WG1*PHIT(MX-3)+YG1*PHIT(MX-4))/2.0_DP &
                   -C2*(WG2*PHIT(MX-2)+YG2*PHIT(MX-3))        &
                   +D2*(WG2*PHIT(MX-2)+YG2*PHIT(MX-3))/2.0_DP
  WRITE(*,*) ".... Right-hand side multiplied"
  !-------------------------------
  !-------------------------------
  !System solving
  CALL ZGBSV(N,KL,KU,1,MB2,2*KL+KU+1,IPIV,TEMP,N,INFO)
  IF (INFO.NE.0) THEN
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*,*) ".... System solved"
  !-------------------------------
  !-------------------------------
  !Complex pressure
  PHI(1:N,MX) = TEMP(:,1)
  P(1:N,MX-1) = EXP(IM*K0*(MX-1)*DR)*PHI(1:N,MX)/SQRT((MX-1)*DR)
  WRITE(*,*)
 END DO
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 P0 = ABS(P(NS,1))
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 20.*LOG10(ABS(P(NZ,MX))/P0)
   IF (LP(NZ,MX).LE.-120) THEN
    LP(NZ,MX) = -120
   END IF
  END DO
 END DO
 LPG = LP(1,1:M)
 LP2 = LP/SQRT(2.0_DP)
 LPG2 = LP2(1,1:M)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Output
 OPEN(UNIT=10,FILE="GTPE2_LPg.dat")
 OPEN(UNIT=20,FILE="GTPE2_LP.dat")
 OPEN(UNIT=30,FILE="GTPE2_PC.dat")
 OPEN(UNIT=40,FILE="GTPE2_P.dat")
 OPEN(UNIT=50,FILE="GTPE2_TOPO.dat")
 DO MX = 1,M
  WRITE(10,100) MX*DR, LPG(MX), LQG(MX)
  WRITE(50,100) MX*DR, TERR(MX), TERR1(MX), TERR2(MX), SLOPX(MX)
  DO NZ = 1,N
   WRITE(20,100) MX*DR, NZ*DZ+TERR(MX), LP(NZ,MX), LQ(NZ,MX)
   WRITE(30,101) MX*DR, NZ*DZ+TERR(MX), PC(NZ,MX), QC(NZ,MX)
   WRITE(40,100) MX*DR, NZ*DZ+TERR(MX), P(NZ,MX)
  END DO
  WRITE(20,*)
  WRITE(30,*)
  WRITE(40,*)
 END DO
 100 FORMAT(3(3X,F12.3))
 101 FORMAT(2(3X,F12.3),3X,F12.3,SP,F12.3,SS,"i")
 !Plotting of results
 !CALL SYSTEM('gnuplot -p plot.plt')
 !CALL SYSTEM('gnuplot -p plot2.plt')
 WRITE(*,*) "================================================"
 WRITE(*,*) "Input file  : ", TOPO
 WRITE(*,*) "================================================"
 WRITE(*,*) "Output file : GTPE2_LPg.dat"
 WRITE(*,*) "              GTPE2_LP.dat"
 WRITE(*,*) "              GTPE2_PC.dat"
 WRITE(*,*) "              GTPE2_P.dat"
 WRITE(*,*) "              GTPE2_TOPO.dat"
 WRITE(*,*) "================================================"
 WRITE(*,*)
 WRITE(*,*) "System size (N x M) :", N, M
 WRITE(*,*) "Step size :", DR
 WRITE(*,*) "Main CPU time (s) :", TF-TI
 WRITE(*,*) "Real pressure at the source - P0 (Pa) :", P0
 WRITE(*,*) "Real pressure at the target - PR (Pa) :", PR
 WRITE(*,*) "SPL/TL at the target - LPR (dB) :", LPR
 WRITE(*,*)
 !-----------------------------------------------------------
 !----------------------------------------------------------
END PROGRAM GTPE2_HT


module init_rhs_mod

contains

    subroutine init_rhs(rhs,rhs_type,prob_lo,dx)

        use constants
        use multifab_module

        integer         , intent(in)     :: rhs_type
        double precision, intent(in)     :: dx
        double precision, intent(in)     :: prob_lo(:)
        type(multifab)  , intent(inout)  :: rhs

        integer :: i, ng
        integer :: lo(rhs%dim), hi(rhs%dim)

        ! 1st three indices are position; 4th index tells us which component
        double precision, pointer :: dp(:,:,:,:)

        ! When constructing RHS, # ghost cells = 0
        ng = rhs%ng

        ! Loop through all fabs in this multifab
        do i = 1,nfabs(rhs)
            dp => dataptr(rhs,i)
            lo = lwb(get_box(rhs,i))
            hi = upb(get_box(rhs,i))
            select case(rhs%dim)
                case(2)
                    select case(rhs_type)
                        case(SIN_RHS)
                            call init_rhs_sin_2d(dp(:,:,1,1),ng,lo,hi,prob_lo,dx)
                        case(RAND_RHS)
                            call init_rhs_rand_2d(dp(:,:,1,1),ng,lo,hi)
                        case(DELTA_RHS)
                            call init_rhs_delta_2d(dp(:,:,1,1),ng,lo,hi)
                    end select
                case(3)
                    select case(rhs_type)
                        case(SIN_RHS)
                            call init_rhs_sin_3d(dp(:,:,:,1),ng,lo,hi,prob_lo,dx)
                        case(RAND_RHS)
                            call init_rhs_rand_3d(dp(:,:,:,1),ng,lo,hi)
                        case(DELTA_RHS)
                            call init_rhs_delta_3d(dp(:,:,:,1),ng,lo,hi)
                    end select
            end select
        end do

    end subroutine init_rhs

    subroutine init_rhs_sin_2d(rhs,ng,lo,hi,prob_lo,dx)

        use constants

        implicit none

        integer         , intent(in)  :: ng
        integer         , intent(in)  :: lo(2), hi(2)
        double precision, intent(in)  :: dx
        double precision, intent(in)  :: prob_lo(2)
        double precision, intent(out) :: rhs(lo(1)-ng:,lo(2)-ng:)

        integer          :: i, j
        double precision :: x, y

        do j = lo(2),hi(2)
            y = prob_lo(2) + (dble(j)+0.5d0) * dx
            do i = lo(1),hi(1)
                x = prob_lo(1) + (dble(i)+0.5d0) * dx
                rhs(i,j) = sin(2.d0*pi*x) + sin(2.d0*pi*y)
            end do
        end do

    end subroutine init_rhs_sin_2d

    subroutine init_rhs_sin_3d(rhs,ng,lo,hi,prob_lo,dx)

        use constants

        implicit none

        integer         , intent(in)  :: ng
        integer         , intent(in)  :: lo(3), hi(3)
        double precision, intent(in)  :: dx
        double precision, intent(in)  :: prob_lo(3)
        double precision, intent(out) :: rhs(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)

        integer          :: i, j, k
        double precision :: x, y, z

        do k = lo(3),hi(3)
            z = prob_lo(3) + (dble(k)+0.5d0) * dx
            do j = lo(2),hi(2)
                y = prob_lo(2) + (dble(j)+0.5d0) * dx
                do i = lo(1),hi(1)
                    x = prob_lo(1) + (dble(i)+0.5d0) * dx
                    rhs(i,j,k) = sin(2.d0*pi*x) + sin(2.d0*pi*y) + sin(2.d0*pi*z)
                end do
            end do
        end do

    end subroutine init_rhs_sin_3d

    subroutine init_rhs_rand_2d(rhs,ng,lo,hi)

        use constants
        use mt19937_module ! in BoxLib/Src/F_BaseLib

        implicit none

        integer         , intent(in)  :: ng
        integer         , intent(in)  :: lo(2), hi(2)
        double precision, intent(out) :: rhs(lo(1)-ng:,lo(2)-ng:)

        integer          :: i, j
        double precision :: rhsAvg

        ! Just an arbitrary seed; random seed can also be used
        call init_genrand(lo(1)*hi(1))

        do j = lo(2),hi(2)
            do i = lo(1),hi(1)
                rhs(i,j) = genrand_real3()
            end do
        end do

        ! Offset RHS to ensure that RHS sums to zero
        rhsAvg = sum(rhs(:,:)) / (hi(1)-lo(1)+1)**2
        rhs(:,:) = rhs(:,:) - rhsAvg

    end subroutine init_rhs_rand_2d

    subroutine init_rhs_rand_3d(rhs,ng,lo,hi)

        use constants
        use mt19937_module ! in BoxLib/Src/F_BaseLib

        implicit none

        integer         , intent(in)  :: ng
        integer         , intent(in)  :: lo(3), hi(3)
        double precision, intent(out) :: rhs(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)

        integer          :: i, j, k
        double precision :: rhsAvg

        ! Just an arbitrary seed; random seed can also be used
        call init_genrand(lo(1)*hi(1))

        do k = lo(3),hi(3)
            do j = lo(2),hi(2)
                do i = lo(1),hi(1)
                    rhs(i,j,k) = genrand_real3()
                end do
            end do
        end do

        ! Offset RHS to ensure that RHS sums to zero
        rhsAvg = sum(rhs(:,:,:)) / (hi(1)-lo(1)+1)**3
        rhs(:,:,:) = rhs(:,:,:) - rhsAvg

    end subroutine init_rhs_rand_3d

    subroutine init_rhs_delta_2d(rhs,ng,lo,hi)
    ! Constructs an RHS in which each fab is zero everywhere except for a -1 in the
    ! third quadrant and 1 in the first quadrant.

        use constants

        implicit none

        integer         , intent(in)  :: ng
        integer         , intent(in)  :: lo(2), hi(2)
        double precision, intent(out) :: rhs(lo(1)-ng:,lo(2)-ng:)

        integer :: n

        n = (hi(1)-lo(1) + 1)

        rhs(:,:) = 0
        rhs(lo(1)+n/4  ,lo(2)+n/4) = -1
        rhs(lo(1)+3*n/4,lo(2)+3*n/4) = 1

    end subroutine init_rhs_delta_2d

    subroutine init_rhs_delta_3d(rhs,ng,lo,hi)
    ! Constructs an RHS in which each fab is zero everywhere except for a -1 in the
    ! third quadrant and 1 in the first quadrant.

        use constants

        implicit none

        integer         , intent(in)  :: ng
        integer         , intent(in)  :: lo(3), hi(3)
        double precision, intent(out) :: rhs(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)

        integer :: n

        n = (hi(1)-lo(1) + 1)

        rhs(:,:,:) = 0
        rhs(lo(1)+n/4  ,lo(2)+n/4  ,lo(3)+n/4) = -1
        rhs(lo(1)+3*n/4,lo(2)+3*n/4,lo(3)+3*n/4) = 1

    end subroutine init_rhs_delta_3d

end module init_rhs_mod


! { dg-do compile }
! Tests the fix for PR37836 in which the specification expressions for
! y were not simplified because there was no simplifier for minval and
! maxval.
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
! nint(exp(3.0)) is equal to 20 :-)
!
      function fun4a()
         integer fun4a
         real y(minval([25, nint(exp(3.0)), 15]))

        fun4a = size (y, 1)
       end function fun4a

      function fun4b()
         integer fun4b
         real y(maxval([25, nint(exp(3.0)), 15]))
         save

         fun4b = size (y, 1)
      end function fun4b

      EXTERNAL fun4a, fun4b
      integer fun4a, fun4b
      if (fun4a () .ne. 15) STOP 1
      if (fun4b () .ne. 25) STOP 2
      end


subroutine volume_jacobian_wrap(u, v, w, tu, tv, tw, ku, kv, kw, nctlu, nctlv, nctlw, &
     nu, nv, nw, vals, row_ptr, col_ind)
  use precision
  implicit none

  ! Input
  integer            , intent(in)      :: ku, kv, kw, nctlu, nctlv, nctlw, nu, nv, nw
  real(kind=realType), intent(in)      :: u(nw, nv, nu), v(nw, nv, nu), w(nw, nv, nu)
  real(kind=realType), intent(in)      :: tu(nctlu+ku), tv(nctlv+kv), tw(nctlw+kw)

  ! Output
  real(kind=realType), intent(out)     :: vals(nu*nv*nw*ku*kv*kw)
  integer            , intent(out)     :: col_ind(nu*nv*nw*ku*kv*kw), row_ptr(nu*nv*nw+1)

  ! Working
  real(kind=realType)                  :: basisu(ku), basisv(kv), basisw(kw)
  integer                              :: i, j, k, ii, jj, kk, counter, c1, c2
  integer                              :: ileftu, ileftv, ileftw

  counter = 1
  do i=1, nu
     do j = 1, nv
        do k=1, nw
           ! U
           call findSpan(u(k, j, i), ku, tu, nctlu, ileftu)
           call basis(tu, nctlu, ku, u(k, j, i), ileftu, basisu)

           ! V
           call findSpan(v(k, j, i), kv, tv, nctlv, ileftv)
           call basis(tv, nctlv, kv, v(k, j, i), ileftv, basisv)

           ! W
           call findSpan(w(k, j, i), kw, tw, nctlw, ileftw)
           call basis(tw, nctlw, kw, w(k, j, i), ileftw, basisw)

           row_ptr( (i-1)*nv*nw + (j-1)*nw + k  ) = counter-1
           do ii=1, ku
              c1 = (ileftu-ku+ii-1)*Nctlv*Nctlw
              do jj = 1, kv
                 c2 = (ileftv-kv+jj-1)*Nctlw
                 do kk=1, kw
                    col_ind(counter) = c1 + c2 + (ileftw-kw+kk-1)
                    vals(counter) = basisu(ii)*basisv(jj)*basisw(kk)
                    counter = counter + 1
                 end do
              end do
           end do
        end do
     end do
  end do
  row_ptr(nu*nv*nw+1) = counter-1

end subroutine volume_jacobian_wrap


!*******************************************************************************
!> author: Jacob Williams
!  license: BSD
!  date: 2/7/2016
!
!  Carlson symmetric forms of elliptic integrals.
!
!  These routines are refactored versions of the ones from [SLATEC](http://www.netlib.org/slatec/).
!  They have been converted into modern Fortran, and the documentation has been
!  converted to FORD syntax.

    module carlson_elliptic_module

    use iso_fortran_env, only: error_unit, wp => real64

    implicit none

    private

    !**************************************************************
    !>
    !  Machine constants (replaces the old SLATEC [D1MACH](http://www.netlib.org/slatec/src/d1mach.f) function)
    !
    !  The traditional D1MACH constants are:
    !  * `D1MACH( 1) = B**(EMIN-1)`,           the smallest positive magnitude.
    !  * `D1MACH( 2) = B**EMAX*(1 - B**(-T))`, the largest magnitude.
    !  * `D1MACH( 3) = B**(-T)`,               the smallest relative spacing.
    !  * `D1MACH( 4) = B**(1-T)`,              the largest relative spacing.
    !  * `D1MACH( 5) = LOG10(B)`

    real(wp),dimension(5),parameter :: d1mach = &
        [  tiny(1.0_wp), &
           huge(1.0_wp), &
           real(radix(1.0_wp),wp)**(-digits(1.0_wp)), &
           epsilon(1.0_wp), &
           log10(real(radix(1.0_wp),wp)) ]

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

    public :: drc,drd,drf,drj

    contains
!*******************************************************************************

!*******************************************************************************
!>
!  Compute an approximation of the Carlson elliptic integral:
!  $$ R_C(x,y) = \frac{1}{2} \int_{0}^{\infty} (t+x)^{-1/2}(t+y)^{-1} dt $$
!  where \(x\ge0\) and \(y>0\).
!
!  The duplication theorem is iterated until the variables are nearly equal,
!  and the function is then expanded in Taylor series to fifth order.
!  Logarithmic, inverse circular, and inverse hyperbolic functions can be
!  expressed in terms of DRC.
!
!### Authors
!  * Carlson, B. C. Ames Laboratory-DOE, Iowa State University, Ames, IA  50011
!  * Notis, E. M., Ames Laboratory-DOE, Iowa State University, Ames, IA  50011
!  * Pexton, R. L., Lawrence Livermore National Laboratory, Livermore, CA  94550
!
!### DRC special cases
!
!  $$
!    \begin{array}{rcll}
!     R_C(x,x+z) + R_C(y,y+z) &=& R_C(0,z)             & x>0, y>0, ~\mathrm{and}~ z>0 ~\mathrm{and}~ x y = z^2 \\
!     R_C(0,1/4)              &=& R_C(1/16,1/8) = \pi  & \\
!     R_C(9/4,2)              &=& \ln(2)               &
!    \end{array}
!  $$
!
!### Special functions via DRC
!
!  $$
!  \begin{array}{rll}
!     \ln(x)        &= (x-1) R_C \left( \left( \frac{1+x}{2} \right)^2, x \right) & x>0 \\
!     \sin^{-1}(x)  &=  x R_C ( (1-x)^2 ,1 ) & -1 \le x \le 1 \\
!     \cos^{-1}(x)  &= \sqrt{1-x^2} R_C(x^2,1)  & 0 \le x \le 1 \\
!     \tan^{-1}(x)  &= x R_C(1,1+x^2) & -\infty \lt x \lt \infty \\
!     \cot^{-1}(x)  &= R_C(x^2, x^2+1) & 0 \le x \lt \infty \\
!     \sinh^{-1}(x) &= x R_C(1+x^2, 1) & -\infty \lt x \lt \infty \\
!     \cosh^{-1}(x) &= \sqrt{x^2-1} R_C(x^2,1)  & x \ge 1 \\
!     \tanh^{-1}(x) &= x R_C(1,1-x^2) & -1 < x < 1 \\
!     \coth^{-1}(x) &= R_C(x^2,x^2-1) & x > 1 \\
!  \end{array}
!  $$
!
!### References
!  * B. C. Carlson and E. M. Notis, [Algorithms for incomplete
!    elliptic integrals](http://dl.acm.org/citation.cfm?id=355970),
!    ACM Transactions on Mathematical
!    Software 7, 3 (September 1981), pp. 398-403.
!  * B. C. Carlson, Computing elliptic integrals by
!    duplication, Numerische Mathematik 33, (1979),
!    pp. 1-16.
!  * B. C. Carlson, Elliptic integrals of the first kind,
!    SIAM Journal of Mathematical Analysis 8, (1977),
!    pp. 231-242.
!
!### History
!  * 790801  DATE WRITTEN
!  * 890531  Changed all specific intrinsics to generic.  (WRB)
!  * 891009  Removed unreferenced statement labels.  (WRB)
!  * 891009  REVISION DATE from Version 3.2
!  * 891214  Prologue converted to Version 4.0 format.  (BAB)
!  * 900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!  * 900326  Removed duplicate information from DESCRIPTION section. (WRB)
!  * 900510  Changed calls to XERMSG to standard form, and some editorial changes.  (RWC)
!  * 920501  Reformatted the REFERENCES section.  (WRB)
!  * Jan 2016, Refactored [SLATEC routine](http://www.netlib.org/slatec/src/drc.f) into modern Fortran. (Jacob Williams)
!
!@warning Changes in the program may improve speed at the expense of robustness.

    real(wp) function drc(x,y,ier)

    implicit none

    real(wp),intent(in) :: x    !! nonnegative variable
    real(wp),intent(in) :: y    !! positive variable
    integer,intent(out) :: ier  !! indicates normal or abnormal termination:
                                !!
                                !! * `IER = 0`: Normal and reliable termination of the
                                !!   routine. It is assumed that the requested
                                !!   accuracy has been achieved.
                                !! * `IER > 0`: Abnormal termination of the routine:
                                !! * `IER = 1`: `x<0 or y<=0`
                                !! * `IER = 2`: `x+y<LOLIM`
                                !! * `IER = 3`: `max(x,y) > UPLIM`

    character(len=16) :: xern3 , xern4 , xern5
    real(wp) :: lamda, mu , s , sn , xn , yn

    real(wp),parameter :: errtol = (d1mach(3)/16.0_wp)**(1.0_wp/6.0_wp)
        !! Determines the accuracy of the answer.
        !!
        !! The value assigned by the routine will result
        !! in solution precision within 1-2 decimals of
        !! machine precision.
        !!
        !! Relative error due to truncation is less than
        !! `16 * ERRTOL ** 6 / (1 - 2 * ERRTOL)`.
        !!
        !! Sample choices:
        !! (ERRTOL, Relative truncation error less than):
        !! (1.0e-3, 2.0e-17),
        !! (3.0e-3, 2.0e-14),
        !! (1.0e-2, 2.0e-11),
        !! (3.0e-2, 2.0e-8),
        !! (1.0e-1, 2.0e-5)
        !!
        !! The accuracy of the computed approximation to the inte-
        !! gral can be controlled by choosing the value of ERRTOL.
        !! Truncation of a Taylor series after terms of fifth order
        !! introduces an error less than the amount shown in the
        !! second column of the following table for each value of
        !! ERRTOL in the first column.  In addition to the trunca-
        !! tion error there will be round-off error, but in prac-
        !! tice the total error from both sources is usually less
        !! than the amount given in the table.
        !!
        !! Decreasing ERRTOL by a factor of 10 yields six more
        !! decimal digits of accuracy at the expense of one or
        !! two more iterations of the duplication theorem.
    real(wp),parameter :: lolim  = 5.0_wp*d1mach(1) !! Lower limit of valid arguments
    real(wp),parameter :: uplim  = d1mach(2)/5.0_wp !! Upper limit of valid arguments
    real(wp),parameter :: c1     = 1.0_wp/7.0_wp
    real(wp),parameter :: c2     = 9.0_wp/22.0_wp

    !initialize:
    drc = 0.0_wp

    ! check for errors:
    if ( x<0.0_wp .or. y<=0.0_wp ) then
        ier = 1
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write(error_unit,'(a)') &
            'drc: x<0 .or. y<=0 where x = '//xern3//' and y = '//xern4
        return
    endif

    if ( max(x,y)>uplim ) then
        ier = 3
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') uplim
        write(error_unit,'(a)') &
            'drc: max(x,y)>uplim where x = '//&
            xern3//' y = '//xern4//' and uplim = '//xern5
        return
    endif

    if ( x+y<lolim ) then
        ier = 2
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') lolim
        write(error_unit,'(a)') &
            'drc: x+y<lolim where x = '//xern3//&
            ' y = '//xern4//' and lolim = '//xern5
        return
    endif

    ier = 0
    xn = x
    yn = y

    do
        mu = (xn+yn+yn)/3.0_wp
        sn = (yn+mu)/mu - 2.0_wp
        if ( abs(sn)<errtol ) exit
        lamda = 2.0_wp*sqrt(xn)*sqrt(yn) + yn
        xn = (xn+lamda)*0.250_wp
        yn = (yn+lamda)*0.250_wp
    end do

    s = sn*sn*(0.30_wp+sn*(c1+sn*(0.3750_wp+sn*c2)))
    drc = (1.0_wp+s)/sqrt(mu)

    end function drc
!*******************************************************************************

!*******************************************************************************
!>
!  Compute an approximation for the incomplete or
!  complete elliptic integral of the 2nd kind:
!  $$ R_D(x,y,z) = \frac{3}{2} \int_{0}^{\infty}
!                       (t+x)^{-1/2}
!                       (t+y)^{-1/2}
!                       (t+z)^{-3/2} dt $$
!  Where \(x\ge0\), \(y\ge0\), \(x+y>0\), and \(z>0\).
!
!  If \(x=0\) or \(y=0\), the integral is complete.
!
!  The duplication theorem is iterated until the variables are
!  nearly equal, and the function is then expanded in Taylor
!  series to fifth order.
!
!### DRD Special Comments
!
!  $$
!    \begin{array}{rl}
!      R_D(x,y,z) + R_D(y,z,x) + R_D(z,x,y) = \frac{3}{\sqrt{x y z}}  &  x>0, y>0, z>0
!    \end{array}
!  $$
!
!### Special functions via DRD and DRF
!
!  * Legendre form of ELLIPTIC INTEGRAL of 2nd kind:
!
!    $$
!      E(\phi,k) = \sin \phi  R_F(\cos^2 \phi,1-k^2 \sin^2 \phi,1)
!      -\frac{k^2}{3} \sin^3 \phi R_D(\cos^2 \phi,1-k^2 \sin^2 \phi,1)
!    $$
!    When \( \phi = \pi /2 \) the integral is complete:
!    $$
!      \begin{array}{rcl}
!       E(k) &=& R_F(0,1-k^2 ,1) - \frac{k^2}{3} R_D(0,1-k^2 ,1) \\
!            &=& \int_{0}^{\pi/2} \sqrt{1-k^2 \sin^2 \phi}  d \phi
!      \end{array}
!    $$
!
!  * Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind:
!
!    $$
!      \mathrm{EL2}(x,k_c,a,b) = ax R_F(1,1+k_c^2 x^2 ,1+x^2 )
!        + \frac{1}{3}(b-a) x^3 R_D(1,1+k_c^2 x^2 ,1+x^2 )
!    $$
!
!  * Legendre form of alternative ELLIPTIC INTEGRAL of 2nd kind:
!
!    $$
!      \begin{array}{rcl}
!      D(q,k) &=& \int_{0}^{q} \sin^2 p (1-k^2 \sin^2 p)^{-1/2} dp \\
!             &=& \frac{1}{3} (\sin^3 q) R_D(\cos^2 q,1-k^2 \sin^2 q,1)
!      \end{array}
!    $$
!
!  * Lemniscate constant B:
!
!    $$
!      \begin{array}{rcl}
!      B &=& \int_{0}^{1} s^2 (1-s^4)^{-1/2} ds \\
!        &=& \frac{1}{3} R_D (0,2,1)
!      \end{array}
!    $$
!
!  * Heuman's LAMBDA function:
!
!    $$
!      \begin{array}{rcl}
!      \frac{\pi}{2} \Lambda_0(a,b) &=&
!      \sin b \left(R_F(0,\cos^2 a,1)-\frac{1}{3} \sin^2 a
!      R_D(0,\cos^2 a,1) \right) R_F(\cos^2 b,1-\cos^2 a \sin^2 b,1) \\
!      & &-\frac{1}{3} \cos^2 a \sin^3 b R_F(0,\cos^2 a,1)
!      R_D(\cos^2 b,1-\cos^2 a \sin^2 b,1)
!      \end{array}
!    $$
!
!  * Jacobi ZETA function:
!
!    $$
!      \begin{array}{rcl}
!      Z(b,k) &=& \frac{k^2}{3} \sin b R_F(\cos^2 b,1-k^2 \sin^2 b,1)
!               R_D(0,1-k^2 ,1)/R_F(0,1-k^2 ,1) \\
!                & & -\frac{k^2}{3} \sin^3 b R_D(\cos^2 b,1-k^2 \sin^2 b,1)
!      \end{array}
!    $$
!
!### Authors
!  * Carlson, B. C. Ames Laboratory-DOE, Iowa State University, Ames, IA  50011
!  * Notis, E. M., Ames Laboratory-DOE, Iowa State University, Ames, IA  50011
!  * Pexton, R. L., Lawrence Livermore National Laboratory, Livermore, CA  94550
!
!### References
!  * B. C. Carlson and E. M. Notis, [Algorithms for incomplete
!    elliptic integrals](http://dl.acm.org/citation.cfm?id=355970),
!    ACM Transactions on Mathematical
!    Software 7, 3 (September 1981), pp. 398-403.
!  * B. C. Carlson, Computing elliptic integrals by
!    duplication, Numerische Mathematik 33, (1979),
!    pp. 1-16.
!  * B. C. Carlson, Elliptic integrals of the first kind,
!    SIAM Journal of Mathematical Analysis 8, (1977),
!    pp. 231-242.
!
!### History
!  * 790801  DATE WRITTEN
!  * 890531  Changed all specific intrinsics to generic.  (WRB)
!  * 890531  REVISION DATE from Version 3.2
!  * 891214  Prologue converted to Version 4.0 format.  (BAB)
!  * 900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!  * 900326  Removed duplicate information from DESCRIPTION section. (WRB)
!  * 900510  Modify calls to XERMSG to put in standard form.  (RWC)
!  * 920501  Reformatted the REFERENCES section.  (WRB)
!  * Jan 2016, Refactored [SLATEC routine](http://www.netlib.org/slatec/src/drd.f) into modern Fortran. (Jacob Williams)
!
!@warning Changes in the program may improve speed at the expense of robustness.

    real(wp) function drd(x,y,z,ier)

    implicit none

    real(wp),intent(in) :: x    !! nonnegative variable (\(x+y>0\))
    real(wp),intent(in) :: y    !! nonnegative variable (\(x+y>0\))
    real(wp),intent(in) :: z    !! positive variable
    integer,intent(out) :: ier  !! indicates normal or abnormal termination:
                                !!
                                !! * `IER = 0`: Normal and reliable termination of the
                                !!   routine. It is assumed that the requested
                                !!   accuracy has been achieved.
                                !! * `IER > 0`: Abnormal termination of the routine:
                                !! * `IER = 1`: `min(x,y) < 0`
                                !! * `IER = 2`: `min(x + y, z ) < LOLIM`
                                !! * `IER = 3`: `max(x,y,z) > UPLIM`

    character(len=16) :: xern3 , xern4 , xern5 , xern6
    real(wp) :: epslon, ea , eb , ec , ed , ef , lamda
    real(wp) :: mu , power4 , sigma , s1 , s2 , xn , xndev
    real(wp) :: xnroot , yn , yndev , ynroot , zn , zndev , znroot

    real(wp),parameter :: errtol = (d1mach(3)/3.0_wp)**(1.0_wp/6.0_wp)
        !! Determines the accuracy of the answer.
        !! The value assigned by the routine will result
        !! in solution precision within 1-2 decimals of
        !! machine precision.
        !!
        !! Relative error due to truncation is less than
        !! `3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2`.
        !!
        !! The accuracy of the computed approximation to the integral
        !! can be controlled by choosing the value of ERRTOL.
        !! Truncation of a Taylor series after terms of fifth order
        !! introduces an error less than the amount shown in the
        !! second column of the following table for each value of
        !! ERRTOL in the first column.  In addition to the truncation
        !! error there will be round-off error, but in practice the
        !! total error from both sources is usually less than the
        !! amount given in the table.
        !!
        !! Sample choices:
        !! (ERRTOL, Relative truncation error less than):
        !! (1.0e-3, 4.0e-18),
        !! (3.0e-3, 3.0e-15),
        !! (1.0e-2, 4.0e-12),
        !! (3.0e-2, 3.0e-9),
        !! (1.0e-1, 4.0e-6)
        !!
        !! Decreasing ERRTOL by a factor of 10 yields six more
        !! decimal digits of accuracy at the expense of one or
        !! two more iterations of the duplication theorem.

    real(wp),parameter :: lolim  = 2.0_wp/(d1mach(2))**(2.0_wp/3.0_wp) !! Lower limit of valid arguments
    real(wp),parameter :: tuplim = (0.10_wp*errtol)**(1.0_wp/3.0_wp)/&
                                    d1mach(1)**(1.0_wp/3.0_wp)
    real(wp),parameter :: uplim  = tuplim**2  !! Upper limit of valid arguments
    real(wp),parameter :: c1     = 3.0_wp/14.0_wp
    real(wp),parameter :: c2     = 1.0_wp/6.0_wp
    real(wp),parameter :: c3     = 9.0_wp/22.0_wp
    real(wp),parameter :: c4     = 3.0_wp/26.0_wp

    ! initialize:
    drd = 0.0_wp

    ! check for errors:
    if ( min(x,y)<0.0_wp ) then
        ier = 1
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write(error_unit,'(a)') 'drd: min(x,y)<0 where x = '//xern3// &
                                ' and y = '//xern4
        return
    endif

    if ( max(x,y,z)>uplim ) then
        ier = 3
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write (xern6,'(1pe15.6)') uplim
        write(error_unit,'(a)') 'drd: max(x,y,z)>uplim where x = '// &
                                xern3//' y = '//xern4//' z = '//xern5// &
                                ' and uplim = '//xern6
        return
    endif

    if ( min(x+y,z)<lolim ) then
        ier = 2
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write (xern6,'(1pe15.6)') lolim
        write(error_unit,'(a)') 'drd: min(x+y,z)<lolim where x = '// &
                                xern3//' y = '//xern4//' z = '//xern5// &
                                ' and lolim = '//xern6
        return
    endif

    ier    = 0
    xn     = x
    yn     = y
    zn     = z
    sigma  = 0.0_wp
    power4 = 1.0_wp

    do
        mu     = (xn+yn+3.0_wp*zn)*0.20_wp
        xndev  = (mu-xn)/mu
        yndev  = (mu-yn)/mu
        zndev  = (mu-zn)/mu
        epslon = max(abs(xndev),abs(yndev),abs(zndev))
        if ( epslon<errtol ) exit
        xnroot = sqrt(xn)
        ynroot = sqrt(yn)
        znroot = sqrt(zn)
        lamda  = xnroot*(ynroot+znroot) + ynroot*znroot
        sigma  = sigma + power4/(znroot*(zn+lamda))
        power4 = power4*0.250_wp
        xn     = (xn+lamda)*0.250_wp
        yn     = (yn+lamda)*0.250_wp
        zn     = (zn+lamda)*0.250_wp
    end do

    ea  = xndev*yndev
    eb  = zndev*zndev
    ec  = ea - eb
    ed  = ea - 6.0_wp*eb
    ef  = ed + ec + ec
    s1  = ed*(-c1+0.250_wp*c3*ed-1.50_wp*c4*zndev*ef)
    s2  = zndev*(c2*ef+zndev*(-c3*ec+zndev*c4*ea))
    drd = 3.0_wp*sigma + power4*(1.0_wp+s1+s2)/(mu*sqrt(mu))

    end function drd
!*******************************************************************************

!*******************************************************************************
!>
!  Compute an approximation for the incomplete or
!  complete elliptic integral of the 1st kind:
!  $$ R_F(x,y,z) = \frac{1}{2} \int_{0}^{\infty}
!                       (t+x)^{-1/2}
!                       (t+y)^{-1/2}
!                       (t+z)^{-1/2} dt $$
!  Where \(x\ge0\), \(y\ge0\), \(z\ge0\), and at most one of
!  them is \(=0\).
!
!  If \(x=0\), \(y=0\), or \(z=0\), the integral is complete.
!
!  The duplication theorem is iterated until the variables are
!  nearly equal, and the function is then expanded in Taylor
!  series to fifth order.
!
!### DRF Special Comments
!
!  $$
!    \begin{array}{rl}
!    R_F(x,x+z,x+w) + R_F(y,y+z,y+w) = R_F(0,z,w)
!    & x>0, y>0, z>0, x y = z w
!    \end{array}
!  $$
!
!### Special functions via DRF
!
!  * Legendre form of ELLIPTIC INTEGRAL of 1st kind:
!
!    $$
!    \begin{array}{rl}
!      F(\phi,k) &= \sin \phi R_F( \cos^2 \phi,1-k^2 \sin^2 \phi,1) \\
!           K(k) &= R_F(0,1-k^2 ,1) = \int_{0}^{\pi/2} (1-k^2 sin^2 \phi )^{-1/2} d \phi
!    \end{array}
!    $$
!
!  * Bulirsch form of ELLIPTIC INTEGRAL of 1st kind:
!
!    $$
!      \mathrm{EL1}(x,k_c) = x R_F(1,1+k_c^2 x^2 ,1+x^2 )
!    $$
!
!  * Lemniscate constant A:
!
!    $$
!      A = \int_{0}^{1} (1-s^4 )^{-1/2}    ds = R_F(0,1,2) = R_F(0,2,1)
!    $$
!
!### References
!  * B. C. Carlson and E. M. Notis, [Algorithms for incomplete
!    elliptic integrals](http://dl.acm.org/citation.cfm?id=355970),
!    ACM Transactions on Mathematical
!    Software 7, 3 (September 1981), pp. 398-403.
!  * B. C. Carlson, Computing elliptic integrals by
!    duplication, Numerische Mathematik 33, (1979),
!    pp. 1-16.
!  * B. C. Carlson, Elliptic integrals of the first kind,
!    SIAM Journal of Mathematical Analysis 8, (1977),
!    pp. 231-242.
!
!### History
!  * 790801  DATE WRITTEN
!  * 890531  Changed all specific intrinsics to generic.  (WRB)
!  * 891009  Removed unreferenced statement labels.  (WRB)
!  * 891009  REVISION DATE from Version 3.2
!  * 891214  Prologue converted to Version 4.0 format.  (BAB)
!  * 900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!  * 900326  Removed duplicate information from DESCRIPTION section. (WRB)
!  * 900510  Changed calls to XERMSG to standard form, and some editorial changes.  (RWC))
!  * 920501  Reformatted the REFERENCES section.  (WRB)
!  * Jan 2016, Refactored [SLATEC routine](http://www.netlib.org/slatec/src/drf.f) into modern Fortran. (Jacob Williams)
!
!@warning Changes in the program may improve speed at the expense of robustness.

    real(wp) function drf(x,y,z,ier)

    implicit none

    real(wp),intent(in) :: x    !! nonnegative variable
    real(wp),intent(in) :: y    !! nonnegative variable
    real(wp),intent(in) :: z    !! nonnegative variable
    integer,intent(out) :: ier  !! indicates normal or abnormal termination:
                                !!
                                !! * `IER = 0`: Normal and reliable termination of the
                                !!   routine. It is assumed that the requested
                                !!   accuracy has been achieved.
                                !! * `IER > 0`: Abnormal termination of the routine:
                                !! * `IER = 1`: `min(x,y,z) < 0`
                                !! * `IER = 2`:` min(x+y,x+z,y+z) < LOLIM`
                                !! * `IER = 3`: `max(x,y,z) > UPLIM`

    character(len=16) :: xern3 , xern4 , xern5 , xern6
    real(wp) :: epslon, e2 , e3 , lamda
    real(wp) :: mu , s , xn , xndev
    real(wp) :: xnroot , yn , yndev , ynroot , zn , zndev , znroot

    real(wp),parameter :: errtol = (4.0_wp*d1mach(3))**(1.0_wp/6.0_wp)
        !! Determines the accuracy of the answer.
        !! The value assigned by the routine will result
        !! in solution precision within 1-2 decimals of
        !! machine precision.
        !!
        !! Relative error due to truncation is less than
        !! `ERRTOL ** 6 / (4 * (1-ERRTOL)`.
        !!
        !! The accuracy of the computed approximation to the integral
        !! can be controlled by choosing the value of ERRTOL.
        !! Truncation of a Taylor series after terms of fifth order
        !! introduces an error less than the amount shown in the
        !! second column of the following table for each value of
        !! ERRTOL in the first column.  In addition to the truncation
        !! error there will be round-off error, but in practice the
        !! total error from both sources is usually less than the
        !! amount given in the table.
        !!
        !! Sample choices:
        !! (ERRTOL, Relative truncation error less than):
        !! (1.0e-3, 3.0e-19),
        !! (3.0e-3, 2.0e-16),
        !! (1.0e-2, 3.0e-13),
        !! (3.0e-2, 2.0e-10),
        !! (1.0e-1, 3.0e-7)
        !!
        !! Decreasing ERRTOL by a factor of 10 yields six more
        !! decimal digits of accuracy at the expense of one or
        !! two more iterations of the duplication theorem.

    real(wp),parameter :: lolim  = 5.0_wp*d1mach(1) !! Lower limit of valid arguments
    real(wp),parameter :: uplim  = d1mach(2)/5.0_wp !! Upper limit of valid arguments
    real(wp),parameter :: c1     = 1.0_wp/24.0_wp
    real(wp),parameter :: c2     = 3.0_wp/44.0_wp
    real(wp),parameter :: c3     = 1.0_wp/14.0_wp

    ! initialize:
    drf = 0.0_wp

    ! check for errors:
    if ( min(x,y,z)<0.0_wp ) then
        ier = 1
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write(error_unit,'(a)') 'drf: min(x,y,z)<0 where x = '// &
                xern3//' y = '//xern4//' and z = '//xern5
        return
    endif

    if ( max(x,y,z)>uplim ) then
        ier = 3
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write (xern6,'(1pe15.6)') uplim
        write(error_unit,'(a)') 'drf: max(x,y,z)>uplim where x = '// &
                xern3//' y = '//xern4//' z = '//xern5// &
                ' and uplim = '//xern6
        return
    endif

    if ( min(x+y,x+z,y+z)<lolim ) then
        ier = 2
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write (xern6,'(1pe15.6)') lolim
        write(error_unit,'(a)') 'drf: min(x+y,x+z,y+z)<lolim where x = '//xern3// &
                ' y = '//xern4//' z = '//xern5//' and lolim = '//xern6
        return
    endif

    ier = 0
    xn  = x
    yn  = y
    zn  = z

    do
        mu     = (xn+yn+zn)/3.0_wp
        xndev  = 2.0_wp - (mu+xn)/mu
        yndev  = 2.0_wp - (mu+yn)/mu
        zndev  = 2.0_wp - (mu+zn)/mu
        epslon = max(abs(xndev),abs(yndev),abs(zndev))
        if ( epslon<errtol ) exit
        xnroot = sqrt(xn)
        ynroot = sqrt(yn)
        znroot = sqrt(zn)
        lamda  = xnroot*(ynroot+znroot) + ynroot*znroot
        xn     = (xn+lamda)*0.250_wp
        yn     = (yn+lamda)*0.250_wp
        zn     = (zn+lamda)*0.250_wp
    end do
    e2  = xndev*yndev - zndev*zndev
    e3  = xndev*yndev*zndev
    s   = 1.0_wp + (c1*e2-0.10_wp-c2*e3)*e2 + c3*e3
    drf = s/sqrt(mu)

    end function drf
!*******************************************************************************

!*******************************************************************************
!>
!  Compute an approximation for the incomplete or
!  complete elliptic integral of the 3rd kind:
!  $$
!    R_J(x,y,z,p) = \frac{3}{2} \int_{0}^{\infty}
!                   (t+x)^{-1/2} (t+y)^{-1/2} (t+z)^{-1/2} (t+p)^{-1} dt
!  $$
!  where \(x\ge0\), \(y\ge0\), and \(z\ge0\),
!  and at most one of them \(=0\), and \(p>0\).
!
!  If \(x=0\) or \(y=0\) or \(z=0\), then the
!  integral is COMPLETE.
!
!  The duplication theorem is iterated
!  until the variables are nearly equal, and the function is
!  then expanded in Taylor series to fifth order.
!
!### DRJ Special Comments
!
!  $$
!  R_J(x,x+z,x+w,x+p) + R_J(y,y+z,y+w,y+p) +
!    (a-b) R_J(a,b,b,a) + \frac{3}{\sqrt{a}} = R_J(0,z,w,p)
!  $$
!  where:
!  $$
!      x>0, y>0, z>0, w>0, p>0
!  $$
!  and:
!  $$
!     \begin{array}{rl}
!         x y &= z w           \\
!           a &= p^2 (x+y+z+w) \\
!           b &= p (p+x) (p+y) \\
!       b - a &= p (p-z) (p-w)
!     \end{array}
!  $$
!  The sum of the third and
!  fourth terms on the left side is \( 3 R_C(a,b) \) .
!
!### Special functions via DRJ and DRF
!
!  * Legendre form of ELLIPTIC INTEGRAL of 3rd kind:
!
!  $$
!      \begin{array}{rcl}
!      P(\phi,k,n) &=& \int_{0}^{\phi} (1+n \sin^2 \theta )^{-1}
!                    (1-k^2 \sin^2 \theta )^{-1/2} d \theta \\
!                  &=& \sin \phi R_F(\cos^2 \phi, 1-k^2 sin^2 \phi,1)
!                    -\frac{n}{3} \sin^3 \phi R_J(\cos^2 \phi,1-k^2 \sin^2 \phi, 1,1+n \sin^2 \phi)
!      \end{array}
!  $$
!
!  * Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind:
!
!  $$
!   \begin{array}{rcl}
!      \mathrm{EL3}(x,k_c,p) &=& x R_F(1,1+k_c^2 x^2 ,1+x^2 ) +
!      \frac{1}{3}(1-p) x^3 R_J(1,1+k_c^2 x^2 ,1+x^2 ,1+p x^2 ) \\
!      \mathrm{CEL}(k_c,p,a,b) &=& a R_F(0,k_c^2 ,1) +
!      \frac{1}{3}(b-pa) R_J(0,k_c^2 ,1,p)
!   \end{array}
!  $$
!
!  * Heuman's LAMBDA function:
!
!  $$
!   \begin{array}{rcl}
!   L(a,b,p) &=&  ( \cos^2 a \sin b \cos b /(1-\cos^2 a \sin^2 b )^{1/2} )
!          (\sin p R_F(\cos^2 p ,1-\sin^2 a \sin^2 p ,1) \\
!          & ~ & +
!          (\sin^2 a \sin^3 p /(3(1-\cos^2 a \sin^2 b )))
!          R_J(\cos^2 p ,1-\sin^2 a \sin^2 p ,1,1-
!          \sin^2 a \sin^2 p /(1-\cos^2 a \sin^2 b ))) \\
!   \frac{\pi}{2} \Lambda_0(a,b) &=& L(a,b,\pi/2) \\
!         &=& \cos^2 a  \sin b \cos b (1-\cos^2 a \sin^2 b )^{-1/2}
!         R_F(0,\cos^2 a ,1) \\
!         &~& + (1/3) \sin^2 a \cos^2 a
!         \sin b \cos b (1-\cos^2 a \sin^2 b )^{-3/2}
!         R_J(0,\cos^2 a ,1,\cos^2 a \cos^2 b /(1-\cos^2 a \sin^2 b ))
!   \end{array}
!  $$
!
!  * Jacobi ZETA function:
!
!  $$
!      Z(b,k) = \frac{k^2}{3} \sin b \cos b (1-k^2 \sin^2 b)^{1/2}
!               \frac{R_J(0,1-k^2 ,1,1-k^2 \sin^2 b)}{R_F (0,1-k^2 ,1)}
!  $$
!
!### Authors
!  * Carlson, B. C. Ames Laboratory-DOE, Iowa State University, Ames, IA  50011
!  * Notis, E. M., Ames Laboratory-DOE, Iowa State University, Ames, IA  50011
!  * Pexton, R. L., Lawrence Livermore National Laboratory, Livermore, CA  94550
!
!### References
!  * B. C. Carlson and E. M. Notis, [Algorithms for incomplete
!    elliptic integrals](http://dl.acm.org/citation.cfm?id=355970),
!    ACM Transactions on Mathematical
!    Software 7, 3 (September 1981), pp. 398-403.
!  * B. C. Carlson, Computing elliptic integrals by
!    duplication, Numerische Mathematik 33, (1979),
!    pp. 1-16.
!  * B. C. Carlson, Elliptic integrals of the first kind,
!    SIAM Journal of Mathematical Analysis 8, (1977),
!    pp. 231-242.
!
!### History
!  * 790801  DATE WRITTEN
!  * 890531  Changed all specific intrinsics to generic.  (WRB)
!  * 891009  Removed unreferenced statement labels.  (WRB)
!  * 891009  REVISION DATE from Version 3.2
!  * 891214  Prologue converted to Version 4.0 format.  (BAB)
!  * 900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!  * 900326  Removed duplicate information from DESCRIPTION section. (WRB)
!  * 900510  Changed calls to XERMSG to standard form, and some editorial changes.  (RWC)).
!  * 920501  Reformatted the REFERENCES section.  (WRB)
!  * Jan 2016, Refactored [SLATEC routine](http://www.netlib.org/slatec/src/drj.f) into modern Fortran. (Jacob Williams)
!
!@warning Changes in the program may improve speed at the expense of robustness.

    real(wp) function drj(x,y,z,p,ier)

    implicit none

    real(wp),intent(in) :: x    !! nonnegative variable
    real(wp),intent(in) :: y    !! nonnegative variable
    real(wp),intent(in) :: z    !! nonnegative variable
    real(wp),intent(in) :: p    !! positive variable
    integer,intent(out) :: ier  !! indicates normal or abnormal termination:
                                !!
                                !! * `IER = 0`: Normal and reliable termination of the
                                !!   routine. It is assumed that the requested
                                !!   accuracy has been achieved.
                                !! * `IER = 1`: `min(x,y,z) < 0.0_wp`
                                !! * `IER = 2`: `min(x+y,x+z,y+z,p) < LOLIM`
                                !! * `IER = 3`: `max(x,y,z,p) > UPLIM`

    character(len=16) xern3 , xern4 , xern5 , xern6 , xern7
    real(wp) :: alfa , beta , ea , eb , ec , e2 , e3, epslon
    real(wp) :: lamda , mu , pn , pndev
    real(wp) :: power4 , sigma , s1 , s2 , s3 , xn , xndev
    real(wp) :: xnroot , yn , yndev , ynroot , zn , zndev , znroot

    real(wp),parameter :: errtol = (d1mach(3)/3.0_wp)**(1.0_wp/6.0_wp)
        !! Determines the accuracy of the answer
        !!
        !! the value assigned by the routine will result
        !! in solution precision within 1-2 decimals of
        !! "machine precision".
        !!
        !! Relative error due to truncation of the series for DRJ
        !! is less than `3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2`.
        !!
        !! The accuracy of the computed approximation to the integral
        !! can be controlled by choosing the value of ERRTOL.
        !! Truncation of a Taylor series after terms of fifth order
        !! introduces an error less than the amount shown in the
        !! second column of the following table for each value of
        !! ERRTOL in the first column.  In addition to the truncation
        !! error there will be round-off error, but in practice the
        !! total error from both sources is usually less than the
        !! amount given in the table.
        !!
        !! Sample choices:
        !! (ERRTOL, Relative truncation error less than}
        !! (1.0e-3, 4.0e-18),
        !! (3.0e-3, 3.0e-15),
        !! (1.0e-2, 4.0e-12),
        !! (3.0e-2, 3.0e-9),
        !! (1.0e-1, 4.0e-6)
        !!
        !! Decreasing ERRTOL by a factor of 10 yields six more
        !! decimal digits of accuracy at the expense of one or
        !! two more iterations of the duplication theorem.

    ! LOLIM and UPLIM determine the valid range of X, Y, Z, and P
    real(wp),parameter :: lolim  = (5.0_wp*d1mach(1))**(1.0_wp/3.0_wp)
        !! not less than the cube root of the value
        !! of LOLIM used in the routine for [[DRC]].
    real(wp),parameter :: uplim  = 0.30_wp*(d1mach(2)/5.0_wp)**(1.0_wp/3.0_wp)
        !! not greater than 0.3 times the cube root of
        !! the value of UPLIM used in the routine for [[DRC]].

    real(wp),parameter :: c1     = 3.0_wp/14.0_wp
    real(wp),parameter :: c2     = 1.0_wp/3.0_wp
    real(wp),parameter :: c3     = 3.0_wp/22.0_wp
    real(wp),parameter :: c4     = 3.0_wp/26.0_wp

    !initialize:
    drj = 0.0_wp

    ! check for errors:
    if ( min(x,y,z)<0.0_wp ) then
        ier = 1
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write(error_unit,'(a)') 'drj: min(x,y,z)<0 where x = '// &
            xern3//' y = '//xern4//' and z = '//xern5
        return
    endif

    if ( max(x,y,z,p)>uplim ) then
        ier = 3
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write (xern6,'(1pe15.6)') p
        write (xern7,'(1pe15.6)') uplim
        write(error_unit,'(a)') 'drj: max(x,y,z,p)>uplim where x = '// &
            xern3//' y = '//xern4//' z = '//xern5//' p = '// &
            xern6//' and uplim = '//xern7
        return
    endif

    if ( min(x+y,x+z,y+z,p)<lolim ) then
        ier = 2
        write (xern3,'(1pe15.6)') x
        write (xern4,'(1pe15.6)') y
        write (xern5,'(1pe15.6)') z
        write (xern6,'(1pe15.6)') p
        write (xern7,'(1pe15.6)') lolim
        write(error_unit,'(a)') 'drj: min(x+y,x+z,y+z,p)<lolim where x = '//xern3// &
            ' y = '//xern4//' z = '//xern5//' p = '//xern6// &
            ' and lolim = '//xern7
        return
    endif

    ier    = 0
    xn     = x
    yn     = y
    zn     = z
    pn     = p
    sigma  = 0.0_wp
    power4 = 1.0_wp

    do
        mu     = (xn+yn+zn+pn+pn)*0.20_wp
        xndev  = (mu-xn)/mu
        yndev  = (mu-yn)/mu
        zndev  = (mu-zn)/mu
        pndev  = (mu-pn)/mu
        epslon = max(abs(xndev),abs(yndev),abs(zndev),abs(pndev))
        if ( epslon<errtol ) exit
        xnroot = sqrt(xn)
        ynroot = sqrt(yn)
        znroot = sqrt(zn)
        lamda  = xnroot*(ynroot+znroot) + ynroot*znroot
        alfa   = pn*(xnroot+ynroot+znroot) + xnroot*ynroot*znroot
        alfa   = alfa*alfa
        beta   = pn*(pn+lamda)*(pn+lamda)
        sigma  = sigma + power4*drc(alfa,beta,ier)
        power4 = power4*0.250_wp
        xn     = (xn+lamda)*0.250_wp
        yn     = (yn+lamda)*0.250_wp
        zn     = (zn+lamda)*0.250_wp
        pn     = (pn+lamda)*0.250_wp
    end do

    ea  = xndev*(yndev+zndev) + yndev*zndev
    eb  = xndev*yndev*zndev
    ec  = pndev*pndev
    e2  = ea - 3.0_wp*ec
    e3  = eb + 2.0_wp*pndev*(ea-ec)
    s1  = 1.0_wp + e2*(-c1+0.750_wp*c3*e2-1.50_wp*c4*e3)
    s2  = eb*(0.50_wp*c2+pndev*(-c3-c3+pndev*c4))
    s3  = pndev*ea*(c2-pndev*c3) - c2*pndev*ec
    drj = 3.0_wp*sigma + power4*(s1+s2+s3)/(mu*sqrt(mu))

    end function drj
!*******************************************************************************

!*******************************************************************************
    end module carlson_elliptic_module
!*******************************************************************************


*DECK SPOFA
      SUBROUTINE SPOFA (A, LDA, N, INFO)
C***BEGIN PROLOGUE  SPOFA
C***PURPOSE  Factor a real symmetric positive definite matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      SINGLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SPOFA factors a real symmetric positive definite matrix.
C
C     SPOFA is usually called by SPOCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for SPOCO) = (1 + 18/N)*(Time for SPOFA) .
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the symmetric matrix to be factored.  Only the
C                diagonal and upper triangle are used.
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  R  so that  A = TRANS(R)*R
C                where  TRANS(R)  is the transpose.
C                The strict lower triangle is unaltered.
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SPOFA
      INTEGER LDA,N,INFO
      REAL A(LDA,*)
C
      REAL SDOT,T
      REAL S
      INTEGER J,JM1,K
C***FIRST EXECUTABLE STATEMENT  SPOFA
         DO 30 J = 1, N
            INFO = J
            S = 0.0E0
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1)
               T = T/A(K,K)
               A(K,J) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            S = A(J,J) - S
            IF (S .LE. 0.0E0) GO TO 40
            A(J,J) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END


program benchmark
  !-----------------------------------------------------------------------------
  ! Vector Discrete Ordinate Method Benchmark
  !
  !  This program runs the vdisord method and tested it using published results
  !  from Mischenko, et.al.
  !
  !--
  ! Developed by J.P. Dark
  ! Contact: email@jpdark.com
  ! Last modified June 2017
  !-----------------------------------------------------------------------------

  implicit none

  ! Basic parameters
  integer, parameter :: sp = kind(1.0)
  integer, parameter :: dp = kind(1.d0)
  real(dp), parameter :: PI = 3.141592653589793_dp
  real(dp), parameter :: tol = 10E-12

  call vbirefl_oblique()

contains

  subroutine vbirefl_oblique()
    !!---------------------------------------------------------------------------
    !! Name: vbirefl_oblique
    !!  Compare vector discrete ordinate method to a polarized bidirectional
    !!  reflectance benchmark results for an oblique beam.
    !!
    !! Model Description:
    !!  * Venutian atmosphere (Hansen).
    !!  * Non-absorbing, albedo = 1.
    !!  * Oblique beam, mu0 = 0.5.
    !!  * Gridpoints: Shifted Gauss-Legendre quadrature with N=49.
    !!
    !! References
    !! -----------
    !!  Benchmark results:
    !!   Mishchenko, M. I., Dlugach, J. M., Chowdhary, J., & Zakharova, N. T.
    !!   Polarized bidirectional reflectance of optically thick sparse
    !!   particulate layers: An efficient numerically exact radiative-transfer
    !!   solution. JQRST. 2015.
    !!
    !!  Bidirection reflectance code available at:
    !!   https://www.giss.nasa.gov/staff/mmishchenko/brf/
    !!--------------------------------------------------------------------------
    use halfspace, only: driver_reflectance
    use quadratures, only: gausslegendre_shifted
    implicit none
    ! Array sizes
    integer(8), parameter :: N = 49   ! Number of gridpoints
    integer(8), parameter :: kmax = 3 ! Number of Fourier modes computed
    integer(8) :: L                   ! Order of phase matrix expansion
    ! Expansion coefficients
    real(dp), allocatable, dimension(:, :) :: FL_coeff ! dim(6, L+1)
    ! Model parameters
    real(dp), parameter :: albedo = 1.0_dp
    real(dp), parameter :: mu0 = 0.5_dp
    ! Quadrature
    real(dp), dimension(N) :: mu, wt
    ! Results
    real(dp), dimension(4*N, 4, kmax+1) :: reflect ! Reflectance
    real(dp), dimension(N, 16, kmax+1) :: vdisord
    ! File output name
    character(len=50) :: reflout
    ! Workspace
    integer(8) :: k, ii, jj ! Loop index.
    ! Vector Bidirection Reflectance Benchmark Results for comparison.
    integer, parameter :: N_bm  = 49         ! Number of gridpoints.
    real(dp), dimension(N_bm) :: mu_bm          ! Array of gridpoints.
    real(dp), dimension(N_bm, 16, 4) :: vbirefl    ! Benchmark results for comparison.

    write (*, '(A)') "> Run benchmark test: halfspace reflectance from oblique beam."

    !---------------------------------------------------------------------------
    ! Get coefficients for the Venutian atmsophere model.
    !
    include 'coeff_venutian.f95'
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Compute the quadrature.
    !  *Benchmark is evaluated on a N=49 point *shifted* Gaussian quadrature.
    !
    call gausslegendre_shifted(N, mu, wt)
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Run the model.
    !
    call driver_reflectance(N, L, kmax, tol, albedo, mu0, mu, wt, &
       FL_coeff, reflect)
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Print results and errors to file.
    !
    do k=0, kmax
       if (kmax < 10) then
          write (reflout, "(A25,I1,A4)") &
               'results/venus/venus_refl_',k, '.dat'
       else if (kmax < 100) then
          write (reflout, "(A25,I2,A4)") &
               'results/venus/venus_refl_',k, '.dat'
       else
          write (reflout, "(A25,I3,A4)") &
               'results/venus/venus_refl_',k, '.dat'
       endif
       call print_refl(N, mu, reflect(:, :, k+1), reflout)
    enddo
    !---------------------------------------------------------------------------
    write (*, '(A)') "> Run ./venus.sh to print results."

    !---------------------------------------------------------------------------
    ! Get Vector Bidirectional Reflectance benchmark results.
    include 'vbirefl_results.f95'
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Change reflectance array output to match format of vbirefl results.
    !
    do k = 1, kmax+1
       do ii = 0, N - 1
          do jj = 1, 4
             vdisord(ii+1, 4*(jj-1)+1:4*(jj-1)+4, k) = reflect(4*ii+jj, :, k)
          enddo
       enddo
       write(*, '(A,I1,A,E12.4)') 'k = ', k-1,', Max Error = ', &
            maxval(abs(vdisord(:, : , k) - vbirefl(:, :, k)))
       write(*, '(A,I1,A,E12.4)') 'k = ', k-1,',  L2 Error = ', &
            norm2(vdisord(:, : , k) - vbirefl(:, :, k))
    enddo
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! Clean allocated arrays.
    !
    deallocate(FL_coeff)
    !---------------------------------------------------------------------------

  end subroutine vbirefl_oblique

  subroutine print_refl(N, mu, R0, filename)
    !!--------------------------------------------------------------------------
    !! Name: print_refl
    !!  Print reflectance matrix to file.
    !!
    !! Synopsis
    !!  print_refl(N, mu, R0, filename)
    !!
    !!   INPUT
    !!     Integer ------------- N
    !!     Double precision ---- mu(N), R0(4*N, 4)
    !!     Character------------ filename(*)
    !!
    !! Purpose
    !!  Print the reflectance matrix in the same format as results from the
    !!  vector bidirection reflectance benchmark results from Mishchenko, et.al.
    !!
    !! Arguments
    !!  N (input) integer
    !!   The number of ordinate quadrature points.
    !!
    !!  mu (input) double precision, array(N)
    !!   Quadrature of ordinate directions.
    !!
    !!  R0 (input) double precision, array(4N, 4)
    !!   Fourier mode of the reflectance matrix.
    !!
    !!  filename (input) character, array(*)
    !!   Name of the file the reflectance matrix is printed to.
    !!
    !!--------------------------------------------------------------------------
    implicit none
    ! INPUT
    integer(8), intent(in) :: N
    real(dp), intent(in), dimension(:) :: mu ! dim(N)
    real(dp), intent(in), dimension(:, :) :: R0 ! dim(4*N, 4)
    character(*), intent(in) :: filename
    ! Workspace
    integer(8) :: stat, ii, jj
    open (unit=10, file=filename, action="write", status="replace", iostat=stat)
    if (stat > 0) then
       write (*, '(A)') "> PROGRAM STOPPED BEFORE COMPLETION."
       write (*,'(A)') "> ERROR in subroutine print_refl."
       write (*,*) &
            "> Could not open file ", filename
       stop
    endif
    do ii = 0, N - 1
       write(10, '(17F14.6)', advance='no') mu(ii+1)
       do jj = 1, 4
          write(10, '(17F14.6)', advance='no') R0(4*ii+jj, :)
       enddo
       write(10, '(A)') ""
    enddo
    close(10)
  end subroutine print_refl

end program benchmark


      subroutine sgedi(a,lda,n,ipvt,det,work,job)
      integer lda,n,ipvt(1),job
      real a(lda,1),det(2),work(1)
c
c     sgedi computes the determinant and inverse of a matrix
c     using the factors computed by sgeco or sgefa.
c
c     on entry
c
c        a       real(lda, n)
c                the output from sgeco or sgefa.
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        ipvt    integer(n)
c                the pivot vector from sgeco or sgefa.
c
c        work    real(n)
c                work vector.  contents destroyed.
c
c        job     integer
c                = 11   both determinant and inverse.
c                = 01   inverse only.
c                = 10   determinant only.
c
c     on return
c
c        a       inverse of original matrix if requested.
c                otherwise unchanged.
c
c        det     real(2)
c                determinant of original matrix if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. abs(det(1)) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal and the inverse is requested.
c        it will not occur if the subroutines are called correctly
c        and if sgeco has set rcond .gt. 0.0 or sgefa has set
c        info .eq. 0 .
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 saxpy,sscal,sswap
c     fortran abs,mod
c
c     internal variables
c
      real t
      real ten
      integer i,j,k,kb,kp1,l,nm1
c
c
c     compute determinant
c
      if (job/10 .eq. 0) go to 70
         det(1) = 1.0e0
         det(2) = 0.0e0
         ten = 10.0e0
         do 50 i = 1, n
            if (ipvt(i) .ne. i) det(1) = -det(1)
            det(1) = a(i,i)*det(1)
c        ...exit
            if (det(1) .eq. 0.0e0) go to 60
   10       if (abs(det(1)) .ge. 1.0e0) go to 20
               det(1) = ten*det(1)
               det(2) = det(2) - 1.0e0
            go to 10
   20       continue
   30       if (abs(det(1)) .lt. ten) go to 40
               det(1) = det(1)/ten
               det(2) = det(2) + 1.0e0
            go to 30
   40       continue
   50    continue
   60    continue
   70 continue
c
c     compute inverse(u)
c
      if (mod(job,10) .eq. 0) go to 150
         do 100 k = 1, n
            a(k,k) = 1.0e0/a(k,k)
            t = -a(k,k)
            call sscal(k-1,t,a(1,k),1)
            kp1 = k + 1
            if (n .lt. kp1) go to 90
            do 80 j = kp1, n
               t = a(k,j)
               a(k,j) = 0.0e0
               call saxpy(k,t,a(1,k),1,a(1,j),1)
   80       continue
   90       continue
  100    continue
c
c        form inverse(u)*inverse(l)
c
         nm1 = n - 1
         if (nm1 .lt. 1) go to 140
         do 130 kb = 1, nm1
            k = n - kb
            kp1 = k + 1
            do 110 i = kp1, n
               work(i) = a(i,k)
               a(i,k) = 0.0e0
  110       continue
            do 120 j = kp1, n
               t = work(j)
               call saxpy(n,t,a(1,j),1,a(1,k),1)
  120       continue
            l = ipvt(k)
            if (l .ne. k) call sswap(n,a(1,k),1,a(1,l),1)
  130    continue
  140    continue
  150 continue
      return
      end


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_laplacian_routines) invert_scalar_laplacian_regular_grid

contains
    !     subroutine islapec(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, a, b, &
    !                        mdab, ndab, wshsec, pertrb, ierror)
    !
    !     islapec inverts the laplace or helmholz operator on an equally
    !     spaced latitudinal grid using o(n**2) storage. given the
    !     spherical harmonic coefficients a(m, n) and b(m, n) of the right
    !     hand side slap(i, j), islapec computes a solution sf(i, j) to
    !     the following helmhotz equation :
    !
    !           2                2
    !     [d(sf(i, j))/dlambda /sint + d(sint*d(sf(i, j))/dtheta)/dtheta]/sint
    !
    !                   - xlmbda * sf(i, j) = slap(i, j)
    !
    !      where sf(i, j) is computed at colatitude
    !
    !                 theta(i) = (i-1)*pi/(nlat-1)
    !
    !            and longitude
    !
    !                 lambda(j) = (j-1)*2*pi/nlon
    !
    !            for i=1, ..., nlat and j=1, ..., nlon.
    !
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct longitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than zero. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !     isym   this parameter should have the same value input to subroutine
    !            shaec to compute the coefficients a and b for the scalar field
    !            slap.  isym is set as follows:
    !
    !            = 0  no symmetries exist in slap about the equator. scalar
    !                 synthesis is used to compute sf on the entire sphere.
    !                 i.e., in the array sf(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !           = 1  sf and slap are antisymmetric about the equator. the
    !                synthesis used to compute sf is performed on the
    !                northern hemisphere only.  if nlat is odd, sf(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, sf(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !           = 2  sf and slap are symmetric about the equator. the
    !                synthesis used to compute sf is performed on the
    !                northern hemisphere only.  if nlat is odd, sf(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, sf(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !   nt       the number of solutions. in the program that calls islapec
    !            the arrays sf, a, and b can be three dimensional in which
    !            case multiple solutions are computed. the third index
    !            is the solution index with values k=1, ..., nt.
    !            for a single solution set nt=1. the description of the
    !            remaining parameters is simplified by assuming that nt=1
    !            and sf, a, b are two dimensional.
    !
    !   xlmbda   a one dimensional array with nt elements. if xlmbda is
    !            is identically zero islapec solves poisson's equation.
    !            if xlmbda > 0.0 islapec solves the helmholtz equation.
    !            if xlmbda < 0.0 the nonfatal error flag ierror=-1 is
    !            returned. negative xlambda could result in a division
    !            by zero.
    !
    !   ids      the first dimension of the array sf as it appears in the
    !            program that calls islapec.  if isym = 0 then ids must be at
    !            least nlat.  if isym > 0 and nlat is even then ids must be
    !            at least nlat/2. if isym > 0 and nlat is odd then ids must
    !            be at least (nlat + 1)/2.
    !
    !   jds      the second dimension of the array sf as it appears in the
    !            program that calls islapec. jds must be at least nlon.
    !
    !
    !   a, b      two or three dimensional arrays (see input parameter nt)
    !            that contain scalar spherical harmonic coefficients
    !            of the scalar field slap. a, b must be computed by shaec
    !            prior to calling islapec.
    !
    !
    !   mdab     the first dimension of the arrays a and b as it appears
    !            in the program that calls islapec.  mdab must be at
    !            least min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !   ndab     the second dimension of the arrays a and b as it appears
    !            in the program that calls islapec. ndab must be at least
    !            least nlat.
    !
    !            mdab, ndab should have the same values input to shaec to
    !            compute the coefficients a and b.
    !
    !
    !   wshsec   an array which must be initialized by subroutine shseci.
    !            once initialized, wshsec can be used repeatedly by
    !            islapec as long as nlat and nlon  remain unchanged.
    !            wshsec must not be altered between calls of islapec.
    !
    !   lshsec   the dimension of the array wshsec as it appears in the
    !            program that calls islapec.  let
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsec must be greater than or equal to
    !
    !               2*nlat*l2+3*((l1-2)*(2*nlat-l1-1))/2+nlon+15
    !
    !     output parameters
    !
    !
    !    sf      two or three dimensional arrays (see input parameter nt)
    !            that contain the solution to either the helmholtz
    !            (xlmbda>0.0) or poisson's equation. sf(i, j) is computed
    !            at colatitude
    !
    !                 theta(i) = (i-1)*pi/(nlat-1)
    !
    !            and longitude
    !
    !                 lambda(j) = (j-1)*2*pi/nlon
    !
    !            for i=1, ..., nlat and j=1, ..., nlon.
    !
    !   pertrb  a one dimensional array with nt elements (see input
    !           parameter nt). in the discription that follows we assume
    !           that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always
    !           returned because the helmholtz operator is invertible.
    !           if xlmbda = 0.0 then a solution exists only if a(1, 1)
    !           is zero. islapec sets a(1, 1) to zero. the resulting
    !           solution sf(i, j) solves poisson's equation with
    !           pertrb = a(1, 1)/(2.*sqrt(2.)) subtracted from the
    !           right side slap(i, j).
    !
    !
    !  ierror   a parameter which flags errors in input parameters as follows:
    !
    !            =-1  xlmbda is input negative (nonfatal error)
    !            = 0  no errors detected
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of ids
    !            = 6  error in the specification of jds
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshsec
    !
    module subroutine islapec(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, &
        a, b, mdab, ndab, wshsec, pertrb, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(in)  :: xlmbda(:)
        real(wp),    intent(out) :: sf(ids, jds, nt)
        integer(ip), intent(in)  :: ids
        integer(ip), intent(in)  :: jds
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wshsec(:)
        real(wp),    intent(out) :: pertrb(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)                  :: required_wavetable_size
        type(ScalarSynthesisUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshsec(nlat, nlon)

        call util%check_scalar_transform_inputs(isym, ids, jds, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshsec, ierror)

        ! Check sign of xlmbda
        if (any(xlmbda < ZERO)) then
            ierror = -1
        end if

        ! Check error flag
        if (ierror /= 0) return

        call invert_scalar_laplacian_lower_utility_routine(nlat, nlon, isym, &
            nt, xlmbda, pertrb, sf, a, b, wshsec, shsec, ierror)

    end subroutine islapec

end submodule invert_scalar_laplacian_regular_grid


! written by jxzou at 20220214: move math library wrappers into this file

! diagonalize a real symmetric matrix and get all eigenvalues and eigenvectors.
! eigenvalues in w() are in ascending order w(1)<=w(2)<=...
subroutine diag_get_e_and_vec(n, a, w)
 implicit none
 integer :: i, lwork, liwork
 integer, intent(in) :: n
 integer, allocatable :: iwork(:)
 real(kind=8), intent(inout) :: a(n,n)
 real(kind=8), intent(out) :: w(n)
 real(kind=8), allocatable :: work(:)

 if(n == 1) then
  w(1) = a(1,1)
  return
 end if
 ! ?syevd: Computes all eigenvalues and (optionally) all eigenvectors of a real
 ! symmetric matrix using divide and conquer algorithm.
 ! Syntax FORTRAN 77:
 ! call dsyevd(jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info)
 lwork = -1; liwork = -1
 allocate(work(1), iwork(1))
 call dsyevd('V', 'U', n, a, n, w, work, lwork, iwork, liwork, i)
 lwork = CEILING(work(1))
 liwork = iwork(1)
 deallocate(work, iwork)
 allocate(work(lwork), iwork(liwork))
 call dsyevd('V', 'U', n, a, n, w, work, lwork, iwork, liwork, i)

 if(i /= 0) then
  write(6,'(A)') 'ERROR in subroutine diag_get_e_and_vec: info/=0 in dsyevd.'
  write(6,'(2(A,I0))') 'n=', n, ', info=', i
  stop
 end if
 deallocate(work,iwork)
end subroutine diag_get_e_and_vec

! solve the A^1/2 and A^(-1/2) for a real symmetric matrix A
! Note: the input matrix A must be symmetric
subroutine mat_dsqrt(n, a0, sqrt_a, n_sqrt_a)
 implicit none
 integer :: i, m, lwork, liwork
 integer, parameter :: iout = 6
 integer, intent(in) :: n
 integer, allocatable :: iwork(:), isuppz(:)

 real(kind=8), parameter :: lin_dep = 1d-6
 ! 1.0D-6 is the default threshold of linear dependence in Gaussian and GAMESS
 ! But in PySCF, one needs to manually adjust the threshold if linear dependence occurs
 real(kind=8), intent(in) :: a0(n,n)
 real(kind=8), intent(out) :: sqrt_a(n,n), n_sqrt_a(n,n)
 ! sqrt_a: A^1/2
 ! n_sqrt_a: A(-1/2)
 real(kind=8), allocatable :: a(:,:), e(:), U(:,:), Ue(:,:), work(:), e1(:,:)
 ! a: copy of a0
 ! e: eigenvalues; e1: all 0 except diagonal e(i)
 ! U: eigenvectors
 ! Ue: U*e

 allocate(a(n,n), source=a0)
 ! call dsyevr(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z,
 ! ldz, isuppz, work, lwork, iwork, liwork, info)
 lwork = -1
 liwork = -1
 allocate(e(n), U(n,n), isuppz(2*n), work(1), iwork(1))
 call dsyevr('V', 'A', 'L', n, a, n, 0d0, 0d0, 0, 0, 1d-8, m, e, U, n, &
             isuppz, work, lwork, iwork, liwork, i)
 lwork = CEILING(work(1))
 liwork = iwork(1)
 deallocate(work, iwork)
 allocate(work(lwork), iwork(liwork))
 call dsyevr('V', 'A', 'L', n, a, n, 0d0, 0d0, 0, 0, 1d-8, m, e, U, n, &
             isuppz, work, lwork, iwork, liwork, i)

 deallocate(a, work, iwork, isuppz)
 if(i /= 0) then
  write(iout,'(A)') 'ERROR in subroutine mat_dsqrt: diagonalization failed.'
  write(iout,'(A,I0)') 'i=', i
  stop
 end if

 if(e(1) < -1d-6) then
  write(iout,'(A)') 'ERROR in subroutine mat_dsqrt: too negative eigenvalue.'
  write(iout,'(A,F16.9)') 'e(1)=', e(1)
  stop
 end if

 allocate(e1(n,n), source=0d0)
 allocate(Ue(n,n), source=0d0)
 sqrt_a = 0d0
 forall(i=1:n, e(i)>0d0) e1(i,i) = DSQRT(e(i))
 ! call dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
 call dsymm('R', 'L', n, n, 1d0, e1, n, U, n, 0d0, Ue, n)
 ! call dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
 call dgemm('N', 'T', n, n, n, 1d0, Ue, n, U, n, 0d0, sqrt_a, n)

 e1 = 0d0
 n_sqrt_a = 0d0
 forall(i=1:n, e(i)>=lin_dep) e1(i,i) = 1d0/DSQRT(e(i))
 ! call dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
 call dsymm('R', 'L', n, n, 1d0, e1, n, U, n, 0d0, Ue, n)
 ! call dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
 call dgemm('N', 'T', n, n, n, 1d0, Ue, n, U, n, 0d0, n_sqrt_a, n)

 deallocate(e, e1, U, Ue)
end subroutine mat_dsqrt

! solving systems of linear equations with multiple right-hand sides
! Ax = b, x can be with multiple right-hand sides
subroutine solve_multi_lin_eqs(a1, a2, a, a3, b, x)
 implicit none
 integer :: i
 integer, intent(in) :: a1, a2, a3
 integer, parameter :: iout = 6
 integer, allocatable :: ipiv(:)
 real(kind=8), intent(in) :: a(a1,a2), b(a1,a3)
 real(kind=8), intent(out) :: x(a2,a3)
 real(kind=8), allocatable :: a_copy(:,:), b_copy(:,:)

 ! mkl Syntax FORTRAN 77:
 ! ?getrf: Computes the LU factorization of a general m-by-n matrix
 ! call dgetrf(m, n, a, lda, ipiv, info)

 ! ?getrs: Solves a system of linear equations with an LU-factored square
 !  matrix, with multiple right-hand sides.
 ! call dgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)
 allocate(a_copy(a1,a2), source=a)
 allocate(b_copy(a1,a3), source=b)
 allocate(ipiv(min(a1,a2)), source=0)

 call dgetrf(a1, a2, a_copy, a1, ipiv, i)
 if(i /= 0) then
  write(iout,'(/,A)') 'ERROR in subroutine solve_multi_lin_eqs: MKL subroutine&
                     & dgetrf failed.'
  write(iout,'(A,I0)') 'info=', i
  stop
 end if

 call dgetrs('N', a2, a3, a_copy, a1, ipiv, b_copy, a1, i)
 deallocate(ipiv, a_copy)

 x = b_copy(1:a2,1:a3)
 deallocate(b_copy)
 return
end subroutine solve_multi_lin_eqs


!*==slapy3.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAPY3 returns sqrt(x2+y2+z2).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAPY3 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       REAL             FUNCTION SLAPY3( X, Y, Z )
!
!       .. Scalar Arguments ..
!       REAL               X, Y, Z
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
!> unnecessary overflow.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] X
!> \verbatim
!>          X is REAL
!> \endverbatim
!>
!> \param[in] Y
!> \verbatim
!>          Y is REAL
!> \endverbatim
!>
!> \param[in] Z
!> \verbatim
!>          Z is REAL
!>          X, Y and Z specify the values x, y and z.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!  =====================================================================
      REAL FUNCTION SLAPY3(X,Y,Z)
      IMPLICIT NONE
!*--SLAPY372
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      REAL X , Y , Z
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E0)
!     ..
!     .. Local Scalars ..
      REAL w , xabs , yabs , zabs
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
      xabs = ABS(X)
      yabs = ABS(Y)
      zabs = ABS(Z)
      w = MAX(xabs,yabs,zabs)
      IF ( w==ZERO ) THEN
!     W can be zero for max(0,nan,0)
!     adding all three entries together will make sure
!     NaN will not disappear.
         SLAPY3 = xabs + yabs + zabs
      ELSE
         SLAPY3 = w*SQRT((xabs/w)**2+(yabs/w)**2+(zabs/w)**2)
      ENDIF
!
!     End of SLAPY3
!
      END FUNCTION SLAPY3


| for numbers 1..100, print "Fizz" if multiple of 3, "Buzz" if multiple of 5,
| and "FizzBuzz" if multiple of both - otherwise, print the number
create fizzbuzz " FizzBuzz" here,
variable fizzed

: fizzbuzz? ( i a mod -- i )
	third swap mod
	0if 4 type fizzed on ;then drop ;

: num?  ( i --   ) fizzed @ if space drop ;then . ;
: fizz? ( i -- i ) fizzbuzz 3 fizzbuzz? ;
: buzz? ( i -- i ) fizzbuzz cell+ 5 fizzbuzz?  ;

: fb 101 1 do fizzed off i fizz? buzz? num? loop ;

fb cr bye


module rand_tools

implicit none

contains

subroutine rand_int_array(i,n,m)
    integer, intent(inout) :: i(:)
    integer, intent(in) :: n, m
    real, allocatable :: u(:)
    allocate(u(size(i)))
    call random_number(u)
    i = n + FLOOR((m+1-n)*u)
end subroutine

integer function rand_int(n,m)
    integer, intent(in) :: n, m

    real :: u
    call random_number(u)
    rand_int = n + FLOOR((m+1-n)*u)

end function

subroutine init_random_seed()
integer :: i, n, clock
integer, dimension(:), allocatable :: seed

call random_seed(size = n)
allocate(seed(n))

call system_clock(count=clock)

seed = clock + 37 * (/ (i - 1, i = 1, n) /)
call random_seed(put = seed)

deallocate(seed)
end subroutine

subroutine generate_random_characters(filename,nchar)
    character(len=*), intent(in) :: filename
    integer, intent(in) :: nchar
    integer :: i, unit, r

    !   33-47   !"#$%&'()*+,-./
    !   48-57   0123456789
    !   58-64   :;<=>?@
    !   65-70   ABCDEF
    !   71-90   GHIJKLMNOPQRSTUVWXYZ
    !   91-96   [\]^_`
    !  97-102   abcdef
    ! 103-122   ghijklmnopqrstuvwxyz
    ! 123-126   {|}~

    open(newunit=unit,file=filename)

    do i = 1, nchar
        r = rand_int(33,126)
        write(unit,'(a1)') achar(r)
    end do

    close(unit)
end subroutine

subroutine generate_random_characters_stream(filename,nchar)
    character(len=*), intent(in) :: filename
    integer, intent(in) :: nchar
    character(len=:), allocatable :: stream
    integer :: i, unit
    integer, allocatable :: r(:)

    !   33-47   !"#$%&'()*+,-./
    !   48-57   0123456789
    !   58-64   :;<=>?@
    !   65-70   ABCDEF
    !   71-90   GHIJKLMNOPQRSTUVWXYZ
    !   91-96   [\]^_`
    !  97-102   abcdef
    ! 103-122   ghijklmnopqrstuvwxyz
    ! 123-126   {|}~

    open(newunit=unit,file=filename)

    allocate(r(nchar))
    call rand_int_array(r,33,126)

    allocate(character(nchar) :: stream)
    do i = 1, nchar
        stream(i:i) = achar(r(i))
    end do

    write(unit,'(A)') stream
    close(unit)
end subroutine

end module

program generate_chars

    use rand_tools

    integer :: exp, sz
    character(len=30) :: filename

    do exp = 3, 8
        sz = 10**exp
        write(filename,'(A,I0,A)') 'chars-',sz,'.txt'
        print *, filename
        ! call generate_random_characters(filename,sz)
        call generate_random_characters_stream(filename,sz)
    end do

end program


SUBROUTINE form_s(gg,ell,kappa,omega,gamma,s)
!
! This subroutine forms the s vector in bicgstab(l)
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::gg(:,:),kappa
 INTEGER,INTENT(IN)::ell
 REAL(iwp),INTENT(OUT)::omega,gamma(:),s(:)
 REAL(iwp)::HH(ell-1,ell-1),gamma0(ell+1),p(ell-1),q(ell-1),gamma1(ell+1),&
   ngamma0,ngamma1,cosine,zero=0.0_iwp,one=1.0_iwp
 hh=-gg(2:ell,2:ell)
 CALL invert(hh)
 p=matmul(hh,gg(2:ell,1))
 q=matmul(hh,gg(2:ell,ell+1))
 gamma0(1)=one
 gamma0(ell+1)=zero
 gamma0(2:ell)=p
 gamma1(1)=zero
 gamma1(ell+1)=one
 gamma1(2:ell)=q
 ngamma0=DOT_PRODUCT(gamma0,MATMUL(gg,gamma0))
 ngamma1=DOT_PRODUCT(gamma1,MATMUL(gg,gamma1))
 omega=DOT_PRODUCT(gamma0,MATMUL(gg,gamma1))
 cosine=ABS(omega)/SQRT(ABS(ngamma0*ngamma1))
 omega=omega/ngamma1
 IF(cosine<kappa)omega=(kappa/cosine)*omega
 gamma=gamma0-omega*gamma1
 s(1:ell)=gamma(2:ell+1)
 s(ell+1)=zero
RETURN
CONTAINS
SUBROUTINE invert(matrix)
!
! This subroutine inverts a small square matrix onto itself.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::matrix(:,:)
 REAL(iwp)::det,j11,j12,j13,j21,j22,j23,j31,j32,j33,con
 INTEGER::ndim,i,k
 ndim=UBOUND(matrix,1)
 IF(ndim==2)THEN
   det=matrix(1,1)*matrix(2,2)-matrix(1,2)*matrix(2,1)
   j11=matrix(1,1)
   matrix(1,1)=matrix(2,2)
   matrix(2,2)=j11
   matrix(1,2)=-matrix(1,2)
   matrix(2,1)=-matrix(2,1)
   matrix=matrix/det
 ELSE IF(ndim==3)THEN
   det=matrix(1,1)*(matrix(2,2)*matrix(3,3)-matrix(3,2)*matrix(2,3))
   det=det-matrix(1,2)*(matrix(2,1)*matrix(3,3)-matrix(3,1)*matrix(2,3))
   det=det+matrix(1,3)*(matrix(2,1)*matrix(3,2)-matrix(3,1)*matrix(2,2))
   j11=matrix(2,2)*matrix(3,3)-matrix(3,2)*matrix(2,3)
   j21=-matrix(2,1)*matrix(3,3)+matrix(3,1)*matrix(2,3)
   j31=matrix(2,1)*matrix(3,2)-matrix(3,1)*matrix(2,2)
   j12=-matrix(1,2)*matrix(3,3)+matrix(3,2)*matrix(1,3)
   j22=matrix(1,1)*matrix(3,3)-matrix(3,1)*matrix(1,3)
   j32=-matrix(1,1)*matrix(3,2)+matrix(3,1)*matrix(1,2)
   j13=matrix(1,2)*matrix(2,3)-matrix(2,2)*matrix(1,3)
   j23=-matrix(1,1)*matrix(2,3)+matrix(2,1)*matrix(1,3)
   j33=matrix(1,1)*matrix(2,2)-matrix(2,1)*matrix(1,2)
   matrix(1,1)=j11
   matrix(1,2)=j12
   matrix(1,3)=j13
   matrix(2,1)=j21
   matrix(2,2)=j22
   matrix(2,3)=j23
   matrix(3,1)=j31
   matrix(3,2)=j32
   matrix(3,3)=j33
   matrix=matrix/det
 ELSE
   DO k=1,ndim
     con=matrix(k,k)
     matrix(k,k)=1.0_iwp
     matrix(k,:)=matrix(k,:)/con
     DO i=1,ndim
       IF(i/=k)THEN
         con=matrix(i,k)
         matrix(i,k)=0.0_iwp
         matrix(i,:)=matrix(i,:)-matrix(k,:)*con
       END IF
     END DO
   END DO
 END IF
RETURN
END SUBROUTINE invert
END SUBROUTINE form_s


MODULE Soilheatfluxmod
    IMPLICIT NONE
CONTAINS
    SUBROUTINE model_soilheatflux(netRadiationEquivalentEvaporation, &
        tau, &
        soilEvaporation, &
        soilHeatFlux)
        REAL, INTENT(IN) :: netRadiationEquivalentEvaporation
        REAL, INTENT(IN) :: tau
        REAL, INTENT(IN) :: soilEvaporation
        REAL, INTENT(OUT) :: soilHeatFlux
        !- Description:
    !            - Model Name: SoilHeatFlux Model
    !            - Author: Pierre Martre
    !            - Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            - Institution: INRA/LEPSE Montpellier
    !            - Abstract: The available energy in the soil
        !- inputs:
    !            - name: netRadiationEquivalentEvaporation
    !                          - variablecategory : state
    !                          - description : net Radiation Equivalent Evaporation
    !                          - datatype : DOUBLE
    !                          - default : 638.142
    !                          - min : 0
    !                          - max : 5000
    !                          - unit : g m-2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
    !            - name: tau
    !                          - description : plant cover factor
    !                          - parametercategory : species
    !                          - datatype : DOUBLE
    !                          - default : 0.9983
    !                          - min : 0
    !                          - max : 100
    !                          - unit :
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : parameter
    !            - name: soilEvaporation
    !                          - description : soil Evaporation
    !                          - variablecategory : state
    !                          - datatype : DOUBLE
    !                          - default : 448.240
    !                          - min : 0
    !                          - max : 10000
    !                          - unit : g m-2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
        !- outputs:
    !            - name: soilHeatFlux
    !                          - description : soil Heat Flux
    !                          - variablecategory : rate
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - unit : g m-2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        soilHeatFlux = tau * netRadiationEquivalentEvaporation -  &
                soilEvaporation
    END SUBROUTINE model_soilheatflux

END MODULE


program test
  double precision     :: val
  val = 1d-7
  print *, val
  val = 1d+7
  print *, val
  val = 1d7
  print *, val
  val = 1d0
  print *, val
end program test