!************************************************************************************
!>
!  1976 Standard Atmosphere Model
!
!### History
!  * Original Julia code from: https://github.com/danielmatz/COESA.jl [MIT License]
!  * Jacob Williams, converted to Fortran 4/30/2020

    module COESA_module

    use iso_fortran_env, wp => real64

    implicit none

    private

    real(wp),parameter :: r0 = 6356766.0_wp ! (m), effective Earth radius at 45 deg N latitude
    real(wp),parameter :: g0 = 9.80665_wp ! (m / s^2) or (m^2 / s^2 m')
    real(wp),parameter :: M0 = 28.9644_wp ! (kg / kmol)
    real(wp),parameter :: Rstar = 8.31432e3_wp ! (N m / kmol K)
    real(wp),parameter :: gamma = 1.4_wp
    real(wp),dimension(*),parameter :: Hb = [0, 11, 20, 32, 47, 51, 71] * 1000.0_wp ! (m')
    real(wp),dimension(*),parameter :: Lmb = [-6.5_wp, 0.0_wp, 1.0_wp, 2.8_wp, 0.0_wp, -2.8_wp, -2.0_wp] / 1000.0_wp ! (K / m')
    real(wp),dimension(*),parameter :: Ztable = [80.0_wp, 80.5_wp, 81.0_wp, 81.5_wp, 82.0_wp, 82.5_wp, 83.0_wp, &
                                                83.5_wp, 84.0_wp, 84.5_wp, 85.0_wp, 85.5_wp, 86.0_wp] * 1000 ! (m)
    real(wp),dimension(*),parameter :: Mratiotable = [1.0_wp, 0.999996_wp, 0.999989_wp, 0.999971_wp, 0.999941_wp, &
                                                    0.999909_wp, 0.999870_wp, 0.999829_wp, 0.999786_wp, 0.999741_wp, &
                                                    0.999694_wp, 0.999641_wp, 0.999579_wp]

    ! based on David's code, which was based on Regan
    ! M and log(P) are interpolated quadratically
    real(wp),dimension(*),parameter :: Ztableupper = [&
        86000.0_wp,  87000.0_wp,  88000.0_wp,  89000.0_wp,  90000.0_wp,  91000.0_wp, 93000.0_wp,  &
        95000.0_wp,  97000.0_wp,  99000.0_wp, 101000.0_wp, 103000.0_wp, 105000.0_wp, 107000.0_wp, &
        109000.0_wp, 110000.0_wp, 111000.0_wp, 112000.0_wp, 113000.0_wp, 114000.0_wp, 115000.0_wp, &
        116000.0_wp, 117000.0_wp, 118000.0_wp, 119000.0_wp, 120000.0_wp, 125000.0_wp, 130000.0_wp, &
        135000.0_wp, 140000.0_wp, 145000.0_wp, 150000.0_wp, 160000.0_wp, 170000.0_wp, 180000.0_wp, &
        190000.0_wp, 200000.0_wp, 210000.0_wp, 220000.0_wp, 230000.0_wp, 240000.0_wp, 250000.0_wp, &
        260000.0_wp, 270000.0_wp, 280000.0_wp, 290000.0_wp, 300000.0_wp, 310000.0_wp, 320000.0_wp, &
        330000.0_wp, 340000.0_wp, 350000.0_wp, 360000.0_wp, 370000.0_wp, 380000.0_wp, 390000.0_wp, &
        400000.0_wp, 410000.0_wp, 420000.0_wp, 430000.0_wp, 440000.0_wp, 450000.0_wp, 460000.0_wp, &
        470000.0_wp, 480000.0_wp, 490000.0_wp, 500000.0_wp, 525000.0_wp, 550000.0_wp, 575000.0_wp, &
        600000.0_wp, 625000.0_wp, 650000.0_wp, 675000.0_wp, 700000.0_wp, 725000.0_wp, 750000.0_wp, &
        775000.0_wp, 800000.0_wp, 825000.0_wp, 850000.0_wp, 875000.0_wp, 900000.0_wp, 925000.0_wp, &
        950000.0_wp, 975000.0_wp, 1000000.0_wp] ! (m)
    real(wp),dimension(*),parameter :: Ptableupper = [&
        3.7338E-1_wp, 3.1259E-1_wp, 2.6173E-1_wp, 2.1919E-1_wp, 1.8359E-1_wp, &
        1.5381E-1_wp, 1.0801E-1_wp, 7.5966E-2_wp, 5.3571E-2_wp, 3.7948E-2_wp, 2.7192E-2_wp, &
        1.9742E-2_wp, 1.4477E-2_wp, 1.0751E-2_wp, 8.1142E-3_wp, 7.1042E-3_wp, 6.2614E-3_wp, &
        5.5547E-3_wp, 4.9570E-3_wp, 4.4473E-3_wp, 4.0096E-3_wp, 3.6312E-3_wp, 3.3022E-3_wp, &
        3.0144E-3_wp, 2.7615E-3_wp, 2.5382E-3_wp, 1.7354E-3_wp, 1.2505E-3_wp, 9.3568E-4_wp, &
        7.2028E-4_wp, 5.6691E-4_wp, 4.5422E-4_wp, 3.0395E-4_wp, 2.1210E-4_wp, 1.5271E-4_wp, &
        1.1266E-4_wp, 8.4736E-5_wp, 6.4756E-5_wp, 5.0149E-5_wp, 3.9276E-5_wp, 3.1059E-5_wp, &
        2.4767E-5_wp, 1.9894E-5_wp, 1.6083E-5_wp, 1.3076E-5_wp, 1.0683E-5_wp, 8.7704E-6_wp, &
        7.2285E-6_wp, 5.9796E-6_wp, 4.9630E-6_wp, 4.1320E-6_wp, 3.4498E-6_wp, 2.8878E-6_wp, &
        2.4234E-6_wp, 2.0384E-6_wp, 1.7184E-6_wp, 1.4518E-6_wp, 1.2291E-6_wp, 1.0427E-6_wp, &
        8.8645E-7_wp, 7.5517E-7_wp, 6.4468E-7_wp, 5.5155E-7_wp, 4.7292E-7_wp, 4.0642E-7_wp, &
        3.5011E-7_wp, 3.0236E-7_wp, 2.1200E-7_wp, 1.5137E-7_wp, 1.1028E-7_wp, 8.2130E-8_wp, &
        6.2601E-8_wp, 4.8865E-8_wp, 3.9048E-8_wp, 3.1908E-8_wp, 2.6611E-8_wp, 2.2599E-8_wp, &
        1.9493E-8_wp, 1.7036E-8_wp, 1.5051E-8_wp, 1.3415E-8_wp, 1.2043E-8_wp, 1.0873E-8_wp, &
        9.8635E-9_wp, 8.9816E-9_wp, 8.2043E-9_wp, 7.5138E-9_wp] ! (Pa)
    real(wp),dimension(*),parameter :: logPtableupper = log(Ptableupper)
    real(wp),dimension(*),parameter :: Mtableupper = [&
        28.95_wp, 28.95_wp, 28.94_wp, 28.93_wp, 28.91_wp, 28.89_wp, 28.82_wp, 28.73_wp, &
        28.62_wp, 28.48_wp, 28.30_wp, 28.10_wp, 27.88_wp, 27.64_wp, 27.39_wp, 27.27_wp, 27.14_wp, 27.02_wp, &
        26.90_wp, 26.79_wp, 26.68_wp, 26.58_wp, 26.48_wp, 26.38_wp, 26.29_wp, 26.20_wp, 25.80_wp, 25.44_wp, &
        25.09_wp, 24.75_wp, 24.42_wp, 24.10_wp, 23.49_wp, 22.90_wp, 22.34_wp, 21.81_wp, 21.30_wp, 20.83_wp, &
        20.37_wp, 19.95_wp, 19.56_wp, 19.19_wp, 18.85_wp, 18.53_wp, 18.24_wp, 17.97_wp, 17.73_wp, 17.50_wp, &
        17.29_wp, 17.09_wp, 16.91_wp, 16.74_wp, 16.57_wp, 16.42_wp, 16.27_wp, 16.13_wp, 15.98_wp, 15.84_wp, &
        15.70_wp, 15.55_wp, 15.40_wp, 15.25_wp, 15.08_wp, 14.91_wp, 14.73_wp, 14.54_wp, 14.33_wp, 13.76_wp, &
        13.09_wp, 12.34_wp, 11.51_wp, 10.62_wp,  9.72_wp,  8.83_wp,  8.00_wp,  7.24_wp,  6.58_wp,  6.01_wp, &
        5.54_wp,   5.16_wp,  4.85_wp,  4.60_wp,  4.40_wp,  4.25_wp,  4.12_wp,  4.02_wp,  3.94_wp] ! (kg / kmol)

    ! ... computed by the initialize() routine:
    real(wp),dimension(*),parameter :: Tmb = [0.288150000000000000E+003, &
                                              0.216650000000000000E+003, &
                                              0.216650000000000000E+003, &
                                              0.228650000000000000E+003, &
                                              0.270650000000000000E+003, &
                                              0.270650000000000000E+003, &
                                              0.214650000000000000E+003 ]

    real(wp),dimension(*),parameter :: Pb = [0.101325000000000000E+006, &
                                             0.226320639734629302E+005, &
                                             0.547488866967777956E+004, &
                                             0.868018684755227330E+003, &
                                             0.110906305554965877E+003, &
                                             0.669388731186872660E+002, &
                                             0.395642042804072865E+001 ]

    type,public :: State
        real(wp) :: mean_molecular_weight = 0.0_wp
        real(wp) :: temperature = 0.0_wp
        real(wp) :: pressure = 0.0_wp
        real(wp) :: speed_of_sound = 0.0_wp
        contains
        procedure :: density
    end type State

    public :: COESA_atmosphere
    public :: COESA_density

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

subroutine initialize()
    integer :: i
    real(wp),dimension(:),allocatable :: Tmb,Pb
    Tmb = [288.15_wp] ! (K)
    do i = 1, (size(Hb) - 1)
        Tmb = [Tmb, Tmb(i) + Lmb(i) * (Hb(i + 1) - Hb(i))]
    end do
    Pb = [101325.0_wp]
    do i = 1, (size(Hb) - 1)
        if (Lmb(i) == 0) then
            Pb = [Pb, Pb(i) * exp(-g0 * M0 * (Hb(i + 1) - Hb(i)) / (Rstar * Tmb(i)))]
        else
            Pb = [Pb, Pb(i) * (Tmb(i) / (Tmb(i) + Lmb(i) * (Hb(i + 1) - Hb(i)))) ** (g0 * M0 / (Rstar * Lmb(i)))]
        end if
    end do
    write(*,*) ''
    write(*,'(A,*(E30.18E3,1x))') 'Tmb = ', Tmb
    write(*,*) ''
    write(*,'(A,*(E30.18E3,1x))') 'Pb = ', Pb
    write(*,*) ''
end subroutine initialize

pure function find(x, xvec) result(i)
    real(wp),intent(in) :: x
    real(wp),dimension(:),intent(in) :: xvec
    integer :: i
    i = 1
    do
        if (i >= size(xvec)) exit
        if (x <= xvec(i + 1)) exit
        i = i + 1
    end do
end function find

pure real(wp) function density(s)
    class(State),intent(in) :: s
    density = s%pressure * s%mean_molecular_weight / (Rstar * s%temperature)
end function density

pure real(wp) function geopotential_altitude(Z)
    real(wp),intent(in) :: Z
    geopotential_altitude = r0 * Z / (r0 + Z)
end function geopotential_altitude

pure real(wp) function Tm(H)
    real(wp),intent(in) :: H
    integer :: i
    i = find(H, Hb)
    Tm = Tmb(i) + Lmb(i) * (H - Hb(i))
end function Tm

pure real(wp) function temperature_lower(H, M)
    real(wp),intent(in) :: H
    real(wp),intent(in) :: M
    temperature_lower = Tm(H) / M0 * M
end function temperature_lower

pure real(wp) function pressure_lower(H)
    real(wp),intent(in) :: H
    integer :: i
    i = find(H, Hb)
    if (Lmb(i) == 0) then
        pressure_lower = Pb(i) * exp(-g0 * M0 * (H - Hb(i)) / (Rstar * Tmb(i)))
    else
        pressure_lower = Pb(i) * (Tmb(i) / (Tmb(i) + Lmb(i) * (H - Hb(i)))) ** (g0 * M0 / (Rstar * Lmb(i)))
    end if
end function pressure_lower

pure real(wp) function speed_of_sound_lower(T, M)
    real(wp),intent(in) :: T, M
    speed_of_sound_lower = sqrt(gamma * Rstar * T / M)
end function speed_of_sound_lower

pure real(wp) function mean_molecular_weight_ratio_lower(Z)
    real(wp),intent(in) :: Z
    integer :: i
    if (Z < Ztable(1)) then
        mean_molecular_weight_ratio_lower = 1.0_wp
    else if (Z > Ztable(size(Ztable))) then
        error stop "altitude above maximum value in table"
    else
        i = find(Z, Ztable)
        mean_molecular_weight_ratio_lower = &
            Mratiotable(i) + (Mratiotable(i + 1) - Mratiotable(i)) / &
            (Ztable(i + 1) - Ztable(i)) * (Z - Ztable(i))
    end if
end function mean_molecular_weight_ratio_lower

pure real(wp) function mean_molecular_weight_lower(Z)
    real(wp),intent(in) :: Z
    mean_molecular_weight_lower = M0 * mean_molecular_weight_ratio_lower(Z)
end function mean_molecular_weight_lower

pure real(wp) function temperature_upper(Z)
    real(wp),intent(in) :: Z
    real(wp) :: Tc,A,aa,T9,LK9,Z9,T10,Z10,Tinf,lambda,xi
    if (Z <= 91000.0_wp) then
        temperature_upper = 186.8673_wp ! (K)
    elseif (Z <= 110000.0_wp) then
        Tc = 263.1905_wp ! (K)
        A = -76.3232_wp ! (K)
        aa = -19.9429_wp * 1000.0_wp ! (m)
        temperature_upper = Tc + A * sqrt(1.0_wp - ((Z - 91000.0_wp) / aa) ** 2)
    elseif (Z <= 120000.0_wp) then
        T9 = 240.0_wp ! (K)
        LK9 = 12.0_wp / 1000.0_wp ! (K / m)
        Z9 = 110000.0_wp ! (m)
        temperature_upper = T9 + LK9 * (Z - Z9)
    elseif (Z <= 1000000.0_wp) then
        T10 = 360.0_wp ! (K)
        Z10 = 120000.0_wp ! (m)
        Tinf = 1000.0_wp ! (K)
        lambda = 0.01875_wp / 1000.0_wp ! (1 / m)
        xi = (Z - Z10) * (r0 + Z10) / (r0 + Z)
        temperature_upper = Tinf - (Tinf - T10) * exp(-lambda * xi)
    end if
end function temperature_upper

pure integer function interpolation_index(Z) result(i)
    real(wp),intent(in) :: Z
    ! Find the index for the lower side of the altitude interval
    i = find(Z, Ztableupper)
    ! We are going to reference all elements from i - 1 to i + 1, so we need to
    ! adjust the index away from the boundaries
    if (i==1) i = 2
end function interpolation_index

pure subroutine interpolation_scale_factors(i, Z, scale0, scale1, scale2)
    integer,intent(in) :: i
    real(wp),intent(in) :: Z
    real(wp),intent(out) :: scale0, scale1, scale2
    real(wp) :: Z0,Z1,Z2
    Z0 = Ztableupper(i - 1)
    Z1 = Ztableupper(i)
    Z2 = Ztableupper(i + 1)
    scale0 = (Z - Z1) * (Z - Z2) / ((Z0 - Z1) * (Z0 - Z2))
    scale1 = (Z - Z0) * (Z - Z2) / ((Z1 - Z0) * (Z1 - Z2))
    scale2 = (Z - Z0) * (Z - Z1) / ((Z2 - Z0) * (Z2 - Z1))
end subroutine interpolation_scale_factors

pure real(wp) function pressure_upper(Z)
    real(wp),intent(in) :: Z
    integer :: i
    real(wp) :: logP0,logP1,logP2,logP,scale0,scale1,scale2
    i = interpolation_index(Z)
    call interpolation_scale_factors(i, Z, scale0, scale1, scale2)
    logP0 = logPtableupper(i - 1)
    logP1 = logPtableupper(i)
    logP2 = logPtableupper(i + 1)
    logP = logP0 * scale0 + logP1 * scale1 + logP2 * scale2
    pressure_upper = exp(logP)
end function pressure_upper

pure real(wp) function mean_molecular_weight_upper(Z)
    real(wp),intent(in) :: Z
    integer :: i
    real(wp) :: M0,M1,M2,scale0,scale1,scale2
    i = interpolation_index(Z)
    call interpolation_scale_factors(i, Z, scale0, scale1, scale2)
    M0 = Mtableupper(i - 1)
    M1 = Mtableupper(i)
    M2 = Mtableupper(i + 1)
    mean_molecular_weight_upper = M0 * scale0 + M1 * scale1 + M2 * scale2
end function mean_molecular_weight_upper

pure real(wp) function speed_of_sound_86km()
    real(wp),parameter :: Z = 86000.0_wp ! (m)
    real(wp) :: H,M,T
    H = geopotential_altitude(Z)
    M = mean_molecular_weight_lower(Z)
    T = temperature_lower(H, M)
    speed_of_sound_86km = speed_of_sound_lower(T, M)
end function speed_of_sound_86km

pure real(wp) function dynamic_viscosity(Z,T)
    real(wp),intent(in) :: Z !! altitude (m)
    real(wp),intent(in) :: T !! temperature (K)
    if (Z > 86000.0_wp) error stop 'unable to compute dynamic viscosity above 86km'
    dynamic_viscosity = 1.458e-6_wp * T**(3.0_wp/2.0_wp) / (T + 110.4_wp)
end function dynamic_viscosity

function COESA_atmosphere(Z) result(s)
    real(wp),intent(in) :: Z ! altitude in meters
    type(state) :: s
    real(wp) :: H,M,T,P,c
    if (Z < -5000.0_wp) then
        error stop "altitude below lower bound of -5000 m"
    else if (Z > 1000000.0_wp) then
        error stop "altitude above upper bound of 1000000 m"
    else if (Z < 86000.0_wp) then
        H = geopotential_altitude(Z)
        M = mean_molecular_weight_lower(Z)
        T = temperature_lower(H, M)
        P = pressure_lower(H)
        c = speed_of_sound_lower(T, M)
    else
        T = temperature_upper(Z)
        P = pressure_upper(Z)
        M = mean_molecular_weight_upper(Z)
        c = speed_of_sound_86km()
    end if
    s = State(M, T, P, c)
end function COESA_atmosphere

function COESA_density(Z) result(density)
    !! a simple version that just returns density
    real(wp),intent(in) :: Z !! altitude in meters
    real(wp) :: density !! kg/m^3
    real(wp) :: H,M,T,P
    if (Z < -5000.0_wp) then
        error stop "altitude below lower bound of -5000 m"
    else if (Z > 1000000.0_wp) then
        error stop "altitude above upper bound of 1000000 m"
    else if (Z < 86000.0_wp) then
        H = geopotential_altitude(Z)
        M = mean_molecular_weight_lower(Z)
        T = temperature_lower(H, M)
        P = pressure_lower(H)
    else
        T = temperature_upper(Z)
        P = pressure_upper(Z)
        M = mean_molecular_weight_upper(Z)
    end if
    density = P * M / (Rstar * T)
end function COESA_density

!************************************************************************************
    end module COESA_module
!************************************************************************************


! Heat capacity as a function of temperature
! From:
!   Williams, D. F. (2006a). “Assessment of Candidate
!   Molten Salt Coolants for the NGNP/NHI Heat-
!   Transfer Loop,” Oak Ridge National Laboratory Report ORNL/TM-2006/69
!   For FLiNaK salt ***
!
!   There are no correlations for heat capacity of Potassium Chloride- Magnesium Chloride salt. There is only one constant value of
!   1.150 kJ/kg K given by Ambrosek [2010]. for KCl-MgCl_2
!
!   Taube and Ligou assumed 0.95 kJ/kg K for UCl_3 @ 983 C
!
!   Modified FLiNak constants to give us what we want @ nominal temperature
!   basd on published data.  Assume temperature dependence is somewhat similar
!   between salts.
!
! Units: [J/g-K]
!
! Input: Temperature [K]
!
! Output: heat_capacity
!

subroutine heat_capacity_corr(T, heat_capacity)

    USE global_parameters_M
    USE flags_M

    implicit none

!---Dummy
    real(dp), intent(in) :: T
    real(dp), intent(out) :: heat_capacity
!---Local
    real(dp) :: a
    real(dp) :: b

    a = 76.78_dp
    !b = 1.0634_dp

    !heat_capacity = 1.150
    !heat_capacity = 900.0
    heat_capacity = 0.90

    if(MSRE_problem .eqv. .TRUE.) then

        heat_capacity = 1.74

    end if

    !heat_capacity = (a + b*T)/1000.0_dp

end subroutine heat_capacity_corr


subroutine sum_reduce(a, s)
real, intent(in) :: a(:)
real, intent(out) :: s
integer :: N, i
N = size(a)
s = 0
do concurrent (i = 1:N) reduce(*: s)
    s = s + a(i)
end do
do concurrent (i = 1:N) reduce(MIN: s)
    s = s + a(i)
end do
do concurrent (i = 1:N) reduce(MAX: s)
    s = s + a(i)
end do
end subroutine


      SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $                   LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     This is the FCN routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03BD. See the
C     parameter FCN in the routine MD03BD for the description of
C     parameters.
C
C     The example programmed in this routine is adapted from that
C     accompanying the MINPACK routine LMDER.
C
C     ******************************************************************
C
C     .. Parameters ..
C     .. NOUT is the unit number for printing intermediate results ..
      INTEGER           NOUT
      PARAMETER         ( NOUT = 6 )
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           IFLAG, INFO, LDJ, LDPAR1, LDPAR2, LDWORK, LIPAR,
     $                  M, N, NFEVL
C     .. Array Arguments ..
      INTEGER           IPAR(*)
      DOUBLE PRECISION  DPAR1(*), DPAR2(*), DWORK(*), E(*), J(LDJ,*),
     $                  X(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  ERR, TMP1, TMP2, TMP3, TMP4
C     .. External Functions ..
      DOUBLE PRECISION  DNRM2
      EXTERNAL          DNRM2
C     .. DATA Statements ..
      DOUBLE PRECISION  Y(15)
      DATA              Y(1), Y(2), Y(3), Y(4), Y(5), Y(6), Y(7), Y(8),
     $                  Y(9), Y(10), Y(11), Y(12), Y(13), Y(14), Y(15)
     $                  / 1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1,
     $                    3.2D-1, 3.5D-1, 3.9D-1, 3.7D-1, 5.8D-1,
     $                    7.3D-1, 9.6D-1, 1.34D0, 2.1D0,  4.39D0 /
C
C     .. Executable Statements ..
C
      INFO = 0
      IF ( IFLAG.EQ.1 ) THEN
C
C        Compute the error function values.
C
         DO 10 I = 1, 15
            TMP1 = I
            TMP2 = 16 - I
            IF ( I.GT.8 ) THEN
               TMP3 = TMP2
            ELSE
               TMP3 = TMP1
            END IF
            E(I) = Y(I) - ( X(1) + TMP1/( X(2)*TMP2 + X(3)*TMP3 ) )
   10    CONTINUE
C
      ELSE IF ( IFLAG.EQ.2 ) THEN
C
C        Compute the Jacobian.
C
         DO 30 I = 1, 15
            TMP1 = I
            TMP2 = 16 - I
            IF ( I.GT.8 ) THEN
               TMP3 = TMP2
            ELSE
               TMP3 = TMP1
            END IF
            TMP4 = ( X(2)*TMP2 + X(3)*TMP3 )**2
            J(I,1) = -ONE
            J(I,2) = TMP1*TMP2/TMP4
            J(I,3) = TMP1*TMP3/TMP4
   30    CONTINUE
C
         NFEVL = 0
C
      ELSE IF ( IFLAG.EQ.3 ) THEN
C
C        Set the parameter LDJ, the length of the array J, and the sizes
C        of the workspace for FCN (IFLAG = 1 or 2), MD03BA and MD03BB.
C
         LDJ = M
         IPAR(1) = M*N
         IPAR(2) = 0
         IPAR(3) = 0
         IPAR(4) = 4*N + 1
         IPAR(5) = 4*N
C
      ELSE IF ( IFLAG.EQ.0 ) THEN
C
C        Special call for printing intermediate results.
C
         ERR = DNRM2( M, E, 1 )
         WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR
C
      END IF
C
      RETURN
C
C *** Last line of MD03BF ***
      END


!==============================================================================!
  subroutine Prec_Solve(a, x, b, prec)
!------------------------------------------------------------------------------!
! Solves the preconditioning system [d]{x}={b}                                 !
!------------------------------------------------------------------------------!
!   Allows preconditioning of the system by:                                   !
!     1. Diagonal preconditioning                                              !
!     2. Incomplete Cholesky preconditioning                                   !
!                                                                              !
!   The type of precondtioning is chosen by setting the variable prec to 0     !
!   (for no preconditioning), 1 (for diagonal preconditioning) or 2 (for       !
!   incomplete Cholesky preconditioning)                                       !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod
  use Comm_Mod
  use Matrix_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Matrix_Type) :: a
  real              :: x(-a % pnt_grid % n_bnd_cells : a % pnt_grid % n_cells)
  real              :: b( a % pnt_grid % n_cells)
  character(len=80) :: prec  ! preconditioner
!-----------------------------------[Locals]-----------------------------------!
  integer :: i, j, k, n
  real    :: sum1
!==============================================================================!

  n  = a % pnt_grid % n_cells - a % pnt_grid % comm % n_buff_cells

  !---------------------------------!
  !   1) diagonal preconditioning   !
  !---------------------------------!
  if(prec .eq. 'DIAGONAL') then
    do i=1,n
      x(i) = b(i)/d % val(d % dia(i))
    end do

  !--------------------------------------------!
  !   2) incomplete cholesky preconditioning   !
  !--------------------------------------------!
  else if(prec .eq. 'INCOMPLETE_CHOLESKY') then

    ! Forward substitutionn
    do i = 1, n
      sum1 = b(i)
      do j = a % row(i),a % dia(i)-1     ! only the lower triangular
        k = a % col(j)
        sum1 = sum1 - a % val(j)*x(k)
      end do
      x(i) = sum1 * d % val(d % dia(i))  ! BUG ?
    end do

    do i = 1, n
      x(i) = x(i) / ( d % val(d % dia(i)) + TINY )
    end do

    ! Backward substitution
    do i = n, 1, -1
      sum1 = x(i)
      do j = a % dia(i)+1, a % row(i+1)-1        ! upper triangular
        k = a % col(j)
        if(k <= n) sum1 = sum1 - a % val(j)*x(k)  ! avoid buffer entries
      end do
      x(i) = sum1* d % val(d % dia(i))           ! BUG ?
    end do

  !---------------------------!
  !   .) no preconditioning   !
  !---------------------------!
  else
    do i = 1, n
      x(i) = b(i)
    end do
  end if

  end subroutine


subroutine face_velocity(u, v, p, uw, ue, vs, vn, pw, pe, ps, pn, imax, jmax)
use kind_parameters
implicit none

integer:: i, j, imax, jmax
real(kind=dp), dimension(imax, jmax):: u,v, p, uw, ue, vs, vn, pw, pe, ps, pn

uw(2,:) = u(1,:)
ue(2,:) = 0.5*(u(2,:)+u(3,:))
pw(2,:) = p(1,:)
pe(2,:) = 0.5*(p(2,:)+p(3,:))

do j = 1,jmax

 do i = 3,imax-1

  uw(i,j) = 0.5*(u(i-1,j) + u(i,j))
  ue(i,j) = 0.5*(u(i,j) + u(i+1,j))
  pw(i,j) = 0.5*(p(i-1,j) + p(i,j))
  pe(i,j) = 0.5*(p(i,j) + p(i+1,j))

 end do

end do

ue(imax-1,:) = u(imax,:)
pe(imax-1,:) = p(imax,:)

vs(:,2) = v(:,1)
vn(:,2) = 0.5*(v(:,2) + v(:,3))

ps(:,2) = p(:,1)
pn(:,2) = 0.5*(p(:,2) + p(:,3))

do j = 3,jmax-1

 do i = 1,imax

  vs(i,j) = 0.5*(v(i,j-1) + v(i,j))
  vn(i,j) = 0.5*(v(i,j) + v(i,j+1))
  ps(i,j) = 0.5*(p(i,j-1) + p(i,j))
  pn(i,j) = 0.5*(p(i,j) + p(i,j+1))

 end do

end do

vn(:,jmax-1) = v(:,jmax)
pn(:,jmax-1) = p(:,jmax)

end subroutine


      subroutine putit ( t, kpm, left, scrtch, dbiatx, q, nrow, b )
c  from  * a practical guide to splines *  by c. de boor
calls  bsplvd(bsplvb),difequ(*)
c  to be called by  e q b l o k .
c
c  puts together one block of the collocation equation system
c
c******  i n p u t  ******
c  t	 knot sequence, of size  left+kpm (at least)
c  kpm	 order of spline
c  left  integer indicating interval of interest, viz the interval
c	    (t(left), t(left+1))
c  nrow  number of rows in block to be put together
c
c******  w o r k  a r e a  ******
c  scrtch   used in bsplvd, of size (kpm,kpm)
c  dbiatx   used to contain derivatives of b-splines, of size (kpm,m+1)
c	    with dbiatx(j,i+1) containing the i-th derivative of the
c	    j-th b-spline of interest
c
c******  o u t p u t  ******
c  q  the block, of size (nrow,kpm)
c  b  the corresponding piece of the right side, of size (nrow)
c
c******  m e t h o d  ******
c  the	k  collocation equations for the interval  (t(left),t(left+1))
c  are constructed with the aid of the subroutine  d i f e q u ( 2, .,
c  . ) and interspersed (in order) with the side conditions (if any) in
c  this interval, using  d i f e q u ( 3, ., . )  for the information.
c     the block  q  has  kpm  columns, corresponding to the  kpm  b-
c  splines of order  kpm  which have the interval (t(left),t(left+1))
c  in their support. the block's diagonal is part of the diagonal of the
c  total system. the first equation in this block not overlapped by the
c  preceding block is therefore equation  l o w r o w , with lowrow =
c  number of side conditions in preceding intervals (or blocks).
c
      integer kpm,left,nrow,   i,irow,iside,itermx,j,k,ll,lowrow,m,mode
     *			      ,mp1
      real b(1),dbiatx(kpm,1),q(nrow,kpm),scrtch(1),t(1),   dx,rho,sum
     *						      ,v(20),xm,xside,xx
      common /side/ m, iside, xside(10)
      common /other/ itermx,k,rho(19)
      mp1 = m+1
      do 10 j=1,kpm
	 do 10 i=1,nrow
   10	    q(i,j) = 0.
      xm = (t(left+1)+t(left))/2.
      dx = (t(left+1)-t(left))/2.
c
      ll = 1
      lowrow = iside
      do 30 irow=lowrow,nrow
	 if (ll .gt. k) 		go to 22
	 mode = 2
c	 next collocation point is ...
	 xx = xm + dx*rho(ll)
	 ll = ll + 1
c	 the corresp.collocation equation is next unless the next side
c	 condition occurs at a point at, or to the left of, the next
c	 collocation point.
	 if (iside .gt. m)		go to 24
	 if (xside(iside) .gt. xx)	go to 24
	 ll = ll - 1
   22	 mode = 3
	 xx = xside(iside)
   24	 call difequ ( mode, xx, v )
c	 the next equation, a collocation equation (mode = 2) or a side
c	 condition (mode = 3), reads
c   (*)   (v(m+1)*d**m + v(m)*d**(m-1) +...+ v(1)*d**0)f(xx) = v(m+2)
c	 in terms of the info supplied by  difequ . the corresponding
c	 equation for the b-coeffs of  f  therefore has the left side of
c	 (*), evaluated at each of the	kpm  b-splines having  xx  in
c	 their support, as its	kpm  possibly nonzero coefficients.
	 call bsplvd ( t, kpm, xx, left, scrtch, dbiatx, mp1 )
	 do 26 j=1,kpm
	    sum = 0.
	    do 25 i=1,mp1
   25	       sum = v(i)*dbiatx(j,i) + sum
   26	    q(irow,j) = sum
   30	 b(irow) = v(m+2)
					return
      end


program cvresizetest
  use flips
  use rand

  implicit none

  integer, parameter :: n = 200, cv = 30, bw = 20, bs = 10

  type(flips_d) :: ha,hb

  real(dp), dimension(:,:), allocatable :: Amat, wAmat, sol,meas
  real(dp), dimension(:), allocatable ::  fsol, rsol, wbw, wcv,err

  real(dp), dimension(8) :: ttt

  integer :: i

  logical, dimension(:), allocatable :: resizemask

  call set_rand_seed()

  allocate(Amat(n,n),wAmat(n+bw,n+bw),meas(n,1),sol(n,1),fsol(n),wbw(bw),wcv(cv),resizemask(n))

  ! solution
  call random_number(sol)

  ! Theory matrix
  wAmat = 0.0
  do i = 1,n
     call random_number(wbw)
     wAmat(i,i:(i+bw-1)) = wbw
     call random_number(wbw)
     wAmat(i:(i+bw-1),i) = wbw
  end do

  Amat = wAmat(1:n,1:n)
  if (cv > 0) then
     call random_number(Amat(1:n,n-cv+1:n))
  end if

  do i = 1,n
     Amat(i,i) = 1.0
  end do

  ! measurement
  meas = matmul(Amat,sol)

  !call get_row_d('rmat',ha,n,fsol,145)
  !write(*,*) 'rrow=',Amat(145,:)
  !writew(*,*) ' '

  ! Full FLIPS problem
  call flips_init(ha,200,1,bandwidth=1,common=cv,buffersize=bs)

  do i = 1,n
     call flips_add(ha,1,Amat(i,:),meas(i,1))
  end do

  call flips_solve(ha)

  fsol = ha%solmat

 ! write(*,*) fsol
  write(*,*) 'Orig. Maxerr=',maxval(fsol-sol(:,1))
  !write(*,*) ' '
  write(*,*) 'bw=',ha%bw,'cv=',ha%common

write(*,*) '** **'
  ! Resize 1
  ! Marginalize unknowns 1..100, add none
  resizemask = .FALSE.
  resizemask(1:100) = .TRUE.

  allocate(err(100),rsol(100))

  call flips_resize(hb,ha,100,remove=resizemask,buffersize=bs)

  call flips_solve(hb)

  !call get_row_s('rmat',hb,100,rsol,50)
  !write(*,*) 'rrow=',rsol
  !write(*,*) ' '
!  write(*,*) 'bw=',hb%bw

  rsol = hb%solmat

  !write(*,*) rsol

  err(1:100) = rsol(1:100)-sol(101:200,1)
  !err(51:100) = rsol(51:100) - sol(151:200,1)

  write(*,*) 'Resize 1. Max err=',maxval(err)
  write(*,*) 'bw=',hb%bw,'cv=',hb%common

  deallocate(err,rsol)

  call flips_kill(hb)

write(*,*) '** **'
  ! Resize 2
  ! Marginalize unknowns 176..200

  resizemask = .FALSE.
  resizemask(176:200) = .TRUE.

  allocate(err(175),rsol(175))

  call flips_resize(hb,ha,remove=resizemask,buffersize=bs)

  call flips_solve(hb)

  rsol=hb%solmat

  err = rsol-sol(1:175,1)
  write(*,*) 'Resize 2. Max err=',maxval(err)
    write(*,*) 'bw=',hb%bw,'cv=',hb%common

  deallocate(err,rsol)

  call flips_kill(hb)

write(*,*) '** **'
  ! Resize 3
  ! Marginalize unknowns 161..180

  resizemask = .FALSE.
  resizemask(161:180) = .TRUE.

  allocate(err(180),rsol(180))

!write(*,*) '**'

  call flips_resize(hb,ha,remove=resizemask,buffersize=bs)

!write(*,*) '** **'

  !call make_rotations_s(hb)
  call flips_solve(hb)

  rsol=hb%solmat

  err(1:160) = rsol(1:160)-sol(1:160,1)
  err(161:180) = rsol(161:180) - sol(181:200,1)
  !write(*,*) err
  write(*,*) 'Resize 3. Max err=',maxval(err)
  write(*,*) 'bw=',hb%bw,'cv=',hb%common

  call flips_kill(hb)

  call flips_kill(ha)

end program cvresizetest


C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM          LMBMA
C
C  LBFGS-B test driver for problems derived from SIF files.
C
C  Nick Gould, A. Sartenaer, Ph. Toint, for CGT Productions.
C  December 1995.
C
      INTEGER          NMAX  , MMAX , IOUT  , N , M , INPUT
      INTEGER          MSAVE , LW, I , MAXIT, MAXCLL
      INTEGER          IFLAG , ICALL , ITER, IPRINT, INSPEC
CS    REAL             F, GTOL
CD    DOUBLE PRECISION F, GTOL
CBIG  PARAMETER      ( NMAX = 100000, MMAX = 25 )
CMED  PARAMETER      ( NMAX =  10000, MMAX = 25 )
CTOY  PARAMETER      ( NMAX =   1000, MMAX = 25 )
CCUS  PARAMETER      ( NMAX =  50000, MMAX = 25 )
      PARAMETER      ( IOUT  = 6, MSAVE = 7 )
      PARAMETER      ( LW    = NMAX * ( 2 * MSAVE + 1 ) + 2 * MSAVE )
      PARAMETER      ( INPUT = 55, INSPEC = 46 )
CS    REAL             X     ( NMAX ), G     ( NMAX ), W     ( LW   )
CD    DOUBLE PRECISION X     ( NMAX ), G     ( NMAX ), W     ( LW   )
      CHARACTER * 10   XNAMES( NMAX ), PNAME
      INTRINSIC        ABS   , MAX
      REAL             CPU(2), CALLS( 4 )
      CHARACTER*60     TASK, CSAVE
      LOGICAL          LSAVE(4)
      INTEGER          ISBMIN, NBD(NMAX), IWA(3*NMAX), ISAVE(44)
CS    REAL             FACTR, DSAVE(29),
CD    DOUBLE PRECISION FACTR, DSAVE(29),
     +                 WA(2*MMAX*NMAX+4*NMAX+12*MMAX*MMAX+12*MMAX)
C
C  Open the Spec file for the method.
C
      OPEN( INSPEC, FILE = 'LBFGSB.SPC', FORM = 'FORMATTED',
     *      STATUS = 'OLD' )
      REWIND INSPEC
C
C  Read input Spec data.
C
C   M = the maximum number of variable metric correction used to define
C     the limited memory matrix.
C
C   FACTR determines the stopping criterion
C
C      (f^k - f^{k+1})/MAX{|f^k|,|f^{k+1}|,1} <= FACTR * epsmch
C
C      where epsmch is the machine precision which is automatically
C      generated by the code.
C
C   IPRINT controls the frequency and type of output generated:
C      iprint<0    no output is generated;
C      iprint=0    print only one line at the last iteration;
C      0<iprint<99 print also f and |proj g| every iprint iterations;
C      iprint=99   print details of every iteration except n-vectors;
C      iprint=100  print also the changes of active set and final x;
C      iprint>100  print details of every iteration including x and g;
C      When iprint > 0, the file iterate.dat will be created to
C      summarize the iteration.
C
C   ISBMIN specifies the subspace minimization methods.
C      isbmin = 1  the direct method will be used,
C               2  the dual method will be used,
C               3  the conjugate gradient method will be used.
C
      READ ( INSPEC, 1000 ) M, FACTR, GTOL, IPRINT, ISBMIN,
     *                      MAXIT, MAXCLL
C
C  Close input file.
C
      CLOSE ( INSPEC )
C
C  Open the relevant file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INPUT
C
C  Set up SIF data.
C
      CALL USETUP( INPUT, IOUT, N, X, W, W( NMAX + 1 ), NMAX )
C
C  Obtain variable names.
C
      CALL UNAMES( N, PNAME, XNAMES )
C
C  Set up algorithmic input data.
C
      DO 10 I = 1, N
         NBD( I ) = 2
 10   CONTINUE
      TASK   = 'START'
      ICALL  = 0
      ITER   = 0
      IFLAG  = 0
C
C  Evaluate the initial function and gradient.
C
C      CALL UOFG( N, X, F, G, .TRUE. )
C
C  Reverse communication loop
C
   20 CONTINUE
C
C  Call the optimizer.
C
      CALL LBFGSB( N, M, X, W, W( NMAX + 1 ), NBD, F, G, FACTR,
     +             WA, IWA, TASK, IPRINT, ISBMIN, CSAVE, LSAVE,
     +             ISAVE, DSAVE )
C
C  Check exit conditions and prepare for re-entry.
C
      IF ( TASK( 1:2 ) .EQ. 'FG' ) THEN
         IF ( ICALL .LE. MAXCLL ) THEN
            ICALL = ICALL + 1
            CALL UOFG( N, X, F, G, .TRUE. )
            GO TO 20
         ELSE
            IFLAG = 2
         END IF
      END IF
      IF ( TASK( 1:5 ) .EQ. 'NEW_X' ) THEN
         IF ( DSAVE( 13 ) .LE. GTOL ) THEN
            TASK='STOP: NORM OF PROJECTED GRADIENT <= 1E-5'
            GO TO 20
         END IF
         IF ( ICALL .LE. MAXIT ) THEN
            ITER = ITER + 1
            GO TO 20
         ELSE
            IFLAG = 1
         END IF
      END IF
C
C  Terminal exit.
C
      CALL UREPRT( CALLS, CPU )
      IF ( TASK( 1:4 ) .EQ. 'CONV' )  IFLAG = 0
      IF ( TASK( 1:4 ) .EQ. 'ABNO' )  IFLAG = 3
      IF ( TASK( 1:5 ) .EQ. 'ERROR' ) IFLAG = 4
      WRITE ( IOUT, 2010 )
      DO 40 I = 1, N
         WRITE( IOUT, 2020 ) XNAMES( I ), X( I ), G( I )
   40 CONTINUE
      WRITE ( IOUT, 2000 ) PNAME, N, CALLS(1), CALLS(2),
     *                     IFLAG, F, CPU(1), CPU(2)
      CLOSE( INPUT  )
      STOP
C
C  Non-executable statements.
C
 1000 FORMAT( I10, /, D10.3, /, D10.3, /, I10, /, I10, /, I10, /, I10 )
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  LBFGS-B',  /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # objective functions   =        ', F8.2 /
     *    ,' # objective gradients   =        ', F8.2 /
     *     ' Exit code               =      ', I10 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *     ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
 2010 FORMAT( /, '                 X         G ' )
 2020 FORMAT(  1X, A10, 1P, 2D12.4 )
      END


      real*4 function dl(h,q,z)
c.....
c	  Computes luminosity distance corresponding to a redshift z.
c	  Uses Mattig formulae for qo both 0 and non 0
c	  Revised January 1991 to implement cosmolgical constant
c	Ho in km/sec/Mpc
c	******DL is in Mpc******
c.....
      implicit none
c     include 'cosmo2.dec'
      real*4 h, q, z, d1, d2
c......
      real*4 aa, bb, epsr, s, s0, funl
      real*4 dd1, dd2, omega0
      logical success
      integer npts
      external funl
      common /cosm/ omega0
c.....
      if (z.le.0.) then
c	10 pc
	dl=1.e-5
      	return
      endif

      if (q .eq. 0) then
      dl = ((3.e5 * z) * (1 + (z / 2.))) / h
      else if (q .gt. 0.) then
      d1 = (q * z) + ((q - 1.) * (sqrt(1. + ((2. * q) * z)) - 1.))
      d2 = ((h * q) * q) / 3.e5
      dl = d1 / d2
      else if (q .lt. 0.) then
         omega0 = (2. * (q + 1.)) / 3.
         aa = 1.
         bb = 1. + z
         success=.false.
         s0=1.e-10
         npts=0
         do while (.not.success)
             npts=npts+1
             call midpnt(funl,aa,bb,s,npts)
             epsr=abs(s-s0)/s0
             if (epsr.lt.1.e-4) then
                success=.true.
             else
                s0=s
             endif
         enddo
         dd1=s
	 dd2 = (3.e5 * (1. + z)) / (h * sqrt(omega0))
	 dl = dd1 * dd2
      end if
c.....
      return
      end
c=======================================================================
      real*4 function funl(x)
c.... For non-zero cosmological constant
      real*4 x, omega0, omegainv
      common /cosm/ omega0
      omegainv = 1. / omega0
      funl = 1. / sqrt(((x ** 3.) + omegainv) - 1.)
      return
      end
c=======================================================================


module lapack
implicit none

! This is the precision that LAPACK "d" routines were compiled with (typically
! double precision, unless a special compiler option was used while compiling
! LAPACK). This "dp" is only used in lapack.f90
! The "d" routines data type is defined as "double precision", so
! we make "dp" the same kind as 0.d0 ("double precision"), so
! as long as LAPACK and this file were compiled with the same compiler options,
! it will be consistent. (If for example all double precision is promoted to
! quadruple precision, it will be promoted both in LAPACK and here.)
integer, parameter:: dp=kind(0.d0)

interface

    SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
    import :: dp
    INTEGER            INFO, LDA, LDB, N, NRHS
    INTEGER            IPIV( * )
    REAL(dp)           A( LDA, * ), B( LDB, * )
    END SUBROUTINE

    SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, &
                       EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, &
                       IWORK, INFO )
    import :: dp
    CHARACTER          EQUED, FACT, TRANS
    INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
    REAL(dp)           RCOND
    INTEGER            IPIV( * ), IWORK( * )
    REAL(dp)           A( LDA, * ), AF( LDAF, * ), B( LDB, * ), BERR( * ), &
                       C( * ), FERR( * ), R( * ), WORK( * ), X( LDX, * )
    END SUBROUTINE

    SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
    import :: dp
    INTEGER            INFO, LDA, LDB, N, NRHS
    INTEGER            IPIV( * )
    COMPLEX(dp)        A( LDA, * ), B( LDB, * )
    END SUBROUTINE

    SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, &
                       EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, &
                       WORK, RWORK, INFO )
    import :: dp
    CHARACTER          EQUED, FACT, TRANS
    INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
    REAL(dp)           RCOND
    INTEGER            IPIV( * )
    REAL(dp)           BERR( * ), C( * ), FERR( * ), R( * ), RWORK( * )
    COMPLEX(dp)        A( LDA, * ), AF( LDAF, * ), B( LDB, * ), WORK( * ), &
                       X( LDX, * )
    END SUBROUTINE

    SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
    import :: dp
    INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
    INTEGER            IPIV( * )
    REAL(dp)           AB( LDAB, * ), B( LDB, * )
    END SUBROUTINE

    SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )
    import :: dp
    CHARACTER          UPLO
    INTEGER            INFO, LDA, LDB, LWORK, N, NRHS
    INTEGER            IPIV( * )
    REAL(dp)           A( LDA, * ), B( LDB, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, &
                       LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, &
                       IWORK, INFO )
    import :: dp
    CHARACTER          FACT, UPLO
    INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
    REAL(dp)           RCOND
    INTEGER            IPIV( * ), IWORK( * )
    REAL(dp)           A( LDA, * ), AF( LDAF, * ), B( LDB, * ), &
                       BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
    END SUBROUTINE

    SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, &
                       LIWORK, INFO )
    import :: dp
    CHARACTER          JOBZ, UPLO
    INTEGER            INFO, LDA, LIWORK, LWORK, N
    INTEGER            IWORK( * )
    REAL(dp)           A( LDA, * ), W( * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, &
                       VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, &
                       LWORK, IWORK, IFAIL, INFO )
    import :: dp
    CHARACTER          JOBZ, RANGE, UPLO
    INTEGER            IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
    REAL(dp)           ABSTOL, VL, VU
    INTEGER            IFAIL( * ), IWORK( * )
    REAL(dp)           A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), &
                       Z( LDZ, * )
    END SUBROUTINE

    SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, &
                      BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
    import :: dp
    CHARACTER          JOBVL, JOBVR
    INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
    REAL(dp)           A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                       B( LDB, * ), BETA( * ), VL( LDVL, * ), &
                       VR( LDVR, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, &
                       ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, &
                       LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, &
                       LWORK, IWORK, BWORK, INFO )
    import :: dp
    CHARACTER          BALANC, JOBVL, JOBVR, SENSE
    INTEGER            IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
    REAL(dp)           ABNRM, BBNRM
    LOGICAL            BWORK( * )
    INTEGER            IWORK( * )
    REAL(dp)           A( LDA, * ), ALPHAI( * ), ALPHAR( * ), B( LDB, * ), &
                       BETA( * ), LSCALE( * ), RCONDE( * ), RCONDV( * ), &
                       RSCALE( * ), VL( LDVL, * ), VR( LDVR, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, &
                      LDVR, WORK, LWORK, INFO )
    import :: dp
    CHARACTER          JOBVL, JOBVR
    INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
    REAL(dp)           A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), WI( * ), &
                       WORK( * ), WR( * )
    END SUBROUTINE

    SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, &
                       VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, &
                       RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
    import :: dp
    CHARACTER          BALANC, JOBVL, JOBVR, SENSE
    INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
    REAL(dp)           ABNRM
    INTEGER            IWORK( * )
    REAL(dp)           A( LDA, * ), RCONDE( * ), RCONDV( * ), &
                       SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), &
                       WI( * ), WORK( * ), WR( * )
    END SUBROUTINE

    SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, &
                      WORK, LWORK, RWORK, INFO )
    import :: dp
    CHARACTER          JOBVL, JOBVR
    INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
    REAL(dp)           RWORK( * )
    COMPLEX(dp)        A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), W( * ), &
                       WORK( * )
    END SUBROUTINE

    SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, &
                       LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, &
                       RCONDV, WORK, LWORK, RWORK, INFO )
    import :: dp
    CHARACTER          BALANC, JOBVL, JOBVR, SENSE
    INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
    REAL(dp)           ABNRM
    REAL(dp)           RCONDE( * ), RCONDV( * ), RWORK( * ), SCALE( * )
    COMPLEX(dp)        A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), W( * ), &
                       WORK( * )
    END SUBROUTINE

    SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, &
                       LWORK, IWORK, LIWORK, INFO )
    import :: dp
    CHARACTER          JOBZ, UPLO
    INTEGER            INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N
    INTEGER            IWORK( * )
    REAL(dp)           A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
    END SUBROUTINE

    REAL(dp) FUNCTION DLAMCH( CMACH )
    import :: dp
    CHARACTER          CMACH
    END FUNCTION

    INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
    CHARACTER*( * )    NAME, OPTS
    INTEGER            ISPEC, N1, N2, N3, N4
    END FUNCTION

    SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
    import :: dp
    INTEGER            INFO, LDA, M, N
    INTEGER            IPIV( * )
    COMPLEX(dp)        A( LDA, * )
    END SUBROUTINE

    SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
    import :: dp
    CHARACTER          TRANS
    INTEGER            INFO, LDA, LDB, N, NRHS
    INTEGER            IPIV( * )
    COMPLEX(dp)         A( LDA, * ), B( LDB, * )
    END SUBROUTINE

    SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
    import :: dp
    INTEGER            INFO, LDA, LWORK, N
    INTEGER            IPIV( * )
    COMPLEX(dp)        A( LDA, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
    import :: dp
    INTEGER            INFO, LDA, M, N
    INTEGER            IPIV( * )
    REAL(dp)           A( LDA, * )
    END SUBROUTINE

    SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
    import :: dp
    INTEGER            INFO, LDA, LWORK, N
    INTEGER            IPIV( * )
    REAL(dp)           A( LDA, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )
    import :: dp
    CHARACTER          JOBZ, UPLO
    INTEGER            INFO, LDA, LWORK, N
    REAL(dp)           RWORK( * ), W( * )
    COMPLEX(dp)        A( LDA, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, &
                       LRWORK, IWORK, LIWORK, INFO )
    import :: dp
    CHARACTER          JOBZ, UPLO
    INTEGER            INFO, LDA, LIWORK, LRWORK, LWORK, N
    INTEGER            IWORK( * )
    REAL(dp)           RWORK( * ), W( * )
    COMPLEX(dp)        A( LDA, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE ZHEGVD( ITYPE,  JOBZ,  UPLO,  N,  A,  LDA,  B, LDB, W, &
                       WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, &
                       INFO )
    import :: dp
    CHARACTER          JOBZ, UPLO
    INTEGER            INFO, ITYPE, LDA, LDB, LIWORK, LRWORK, LWORK, N
    INTEGER            IWORK( * )
    REAL(dp)           RWORK( * ), W( * )
    COMPLEX(dp)        A( LDA, * ), B( LDB, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, &
                       WORK, LWORK, INFO )
    import :: dp
    INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
    REAL(dp)           RCOND
    INTEGER            JPVT( * )
    REAL(dp)           A( LDA, * ), B( LDB, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, &
                       WORK, LWORK, RWORK, INFO )
    import :: dp
    INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
    REAL(dp)           RCOND
    INTEGER            JPVT( * )
    REAL(dp)           RWORK( * )
    COMPLEX(dp)        A( LDA, * ), B( LDB, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, &
                       LDVT, WORK, LWORK, INFO )
    import :: dp
    CHARACTER          JOBU, JOBVT
    INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
    REAL(dp)           A( LDA, * ), S( * ),  U( LDU,  * ), VT( LDVT, * ), &
                       WORK( * )
    END SUBROUTINE

    SUBROUTINE ZGESVD( JOBU, JOBVT,  M,  N,  A,  LDA, S, U, LDU, VT, LDVT, &
                       WORK, LWORK, RWORK, INFO )
    import :: dp
    CHARACTER          JOBU, JOBVT
    INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
    REAL(dp)           RWORK( * ), S( * )
    COMPLEX(dp)        A( LDA, * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
    END SUBROUTINE

    SUBROUTINE XERBLA( SRNAME, INFO )
    CHARACTER*(*)      SRNAME
    INTEGER            INFO
    END SUBROUTINE

! BLAS

    SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY)
    import :: dp
    INTEGER INCX,INCY,N
    COMPLEX(dp) ZX(*),ZY(*)
    END SUBROUTINE

    SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
    import :: dp
    integer :: INCX, INCY, N
    real(dp) :: DA, DX(*), DY(*)
    END SUBROUTINE

    SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
    import :: dp
    DOUBLE PRECISION ALPHA,BETA
    INTEGER K,LDA,LDB,LDC,M,N
    CHARACTER TRANSA,TRANSB
    REAL(dp) A(LDA,*),B(LDB,*),C(LDC,*)
    END SUBROUTINE

    real(dp) FUNCTION DNRM2(N,X,INCX)
    import :: dp
    integer :: INCX, N
    real(dp) :: X(*)
    END FUNCTION

    SUBROUTINE DSCAL(N,DA,DX,INCX)
    import :: dp
    real(dp) :: DA, DX(*)
    integer :: INCX, N
    END SUBROUTINE

    SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
    import :: dp
    REAL(dp) ALPHA,BETA
    INTEGER LDA,LDB,LDC,M,N
    CHARACTER SIDE,UPLO
    REAL(dp) A(LDA,*),B(LDB,*),C(LDC,*)
    END SUBROUTINE

end interface

contains

end module


program day01
    implicit none

    integer, parameter :: max_modules = 256
    integer, parameter :: max_iters = 64

    integer :: nvalues
    integer :: i
    integer, dimension(max_modules) :: mass
    integer, dimension(max_modules,max_iters) :: fuels

    call read_stdin(mass, nvalues)

    ! Solve Part 1
    fuels(:,1) = mass / 3 - 2

    ! Solve Part 2
    do i=2,max_iters
        fuels(:,i) = max(fuels(:,i-1) / 3 - 2, 0)
        if (sum(fuels(:,i)) == 0) exit
    end do

    print *, 'Naive fuel required: ', sum(fuels(1:nvalues,1))
    print *, 'Total fuel required: ', sum(fuels(1:nvalues,:i))

contains

subroutine read_stdin(mass, nvalues)
    use, intrinsic :: iso_fortran_env, only : input_unit
    implicit none

    integer, intent(in out) :: mass(:)
    integer, intent(out) :: nvalues

    integer :: ios

    nvalues = 1
    do
        read(input_unit, *, iostat=ios) mass(nvalues)
        if (ios /= 0) exit
        nvalues = nvalues + 1
    end do
    nvalues = nvalues - 1
end subroutine read_stdin

end program day01


# define ANGULAR_MOMENTUM 0

module setup_analyze_mod

use constants_mod

character(len=255) :: fpath = 'analysis.dat'

integer, parameter :: idens      = 1
integer, parameter :: imomx      = 2
integer, parameter :: imomy      = 3
integer, parameter :: imomz      = 4
integer, parameter :: ieint      = 5
integer, parameter :: iekin      = 6
integer, parameter :: iepot      = 7
integer, parameter :: ietot      = 8

integer, parameter :: iLtot      = 9    !! angular momentum
integer, parameter :: iHtot      = 10   !! specific angular momentum

integer, parameter :: imtot      = 11   !! specific angular momentum
integer, parameter :: ibulkd     = 12   !! specific angular momentum
integer, parameter :: ibulkx     = 13   !! specific angular momentum
integer, parameter :: ibulky     = 14   !! specific angular momentum
integer, parameter :: ibulke     = 15   !! specific angular momentum

integer, parameter :: sums_len  = 30

real(dp), save :: sums(1:SUMS_LEN) !! accumulators
real(dp), save :: nextanalyze = 0.0

contains

subroutine analyze_cb(quad)

    use setup_config_mod
    use equations_const_mod

    use equations_mod, only: pressure
    use mesh_types_mod, only: quad_t
    use quad_utils_mod, only: quad_get_volumes
    use quad_utils_mod, only: quad_get_coords

    type(quad_t), intent(inout) :: quad

    real(dp) :: coords(N_NODES,N_NODES,N_DIMS)

    real(dp), dimension(N_NODES,N_NODES) :: dens, momx, momy, momz, etot, ekin, eint, epot
    real(dp) :: vols(N_NODES,N_NODES)

# if ANGULAR_MOMENTUM
    real(dp) :: angx(N_NODES,N_NODES) !! x-angular momentum
    real(dp) :: angy(N_NODES,N_NODES) !! y-angular momentum
    real(dp) :: angz(N_NODES,N_NODES) !! z-angular momentum

    real(dp) :: angL(N_NODES,N_NODES) !! angular momentum
    real(dp) :: angH(N_NODES,N_NODES) !! specific angular momentum
# endif

    vols = quad_get_volumes(quad)
    coords = quad_get_coords(quad)

    dens = quad%pld%hydro%state(:,:,DENS_VAR)
    momx = quad%pld%hydro%state(:,:,MOMX_VAR)
    momy = quad%pld%hydro%state(:,:,MOMY_VAR)
    etot = quad%pld%hydro%state(:,:,ENER_VAR)

    eint = pressure(quad%pld%hydro%state)/(kappa-1.0_dp)
    ekin = 0.5 * (momx**2 + momy**2)/dens
# if MODULE_SELF_GRAVITY
    epot = 0.5 * dens*quad%aux%gravity%pot
# endif

# if ANGULAR_MOMENTUM
    angz = coords(:,:,:,X_DIR)*momy - coords(:,:,:,Y_DIR)*momx
    angL = abs(angz)
    angH = angL/dens
# endif

    !$omp critical
    sums(idens) = sums(idens) + sum(vols * dens)
    sums(imomx) = sums(imomx) + sum(vols * momx)
    sums(imomy) = sums(imomy) + sum(vols * momy)
    sums(imtot) = sums(imtot) + sum(vols * momx) + sum(vols * momy)

    sums(ieint) = sums(ieint) + sum(vols * eint)
    sums(iekin) = sums(iekin) + sum(vols * ekin)

    ! sums(ibulkd) = sums(ibulkd) + sum(vols * quad%pld%hydro%update(:,:,DENS_VAR))
    ! sums(ibulkx) = sums(ibulkx) + sum(vols * quad%pld%hydro%update(:,:,MOMX_VAR))
    ! sums(ibulky) = sums(ibulky) + sum(vols * quad%pld%hydro%update(:,:,MOMY_VAR))
    ! sums(ibulke) = sums(ibulke) + sum(vols * quad%pld%hydro%update(:,:,ENER_VAR))

# if MODULE_SELF_GRAVITY
    sums(iepot) = sums(iepot) + sum(vols * epot)
# endif

    sums(ietot) = sums(ietot) + sum(vols * etot)

# if ANGULAR_MOMENTUM
    sums(iLtot) = sums(iLtot) + sum(vols * angL)
    sums(iHtot) = sums(iHtot) + sum(vols * angH)
# endif
    !$omp end critical

end subroutine

subroutine hook_analyze_500

    use mesh_utils_mod, only: mesh_iterate_quads
    use mpi_f08, only: mpi_reduce,MPI_SUM,MPI_DOUBLE_PRECISION

    use utils_mod, only: incr, write2file
    use share_mod, only: mesh, rt => runtime

    use setup_config_mod, only: dt_analyze

    integer :: ierr
    integer :: cnt = 0
    real(dp) :: resBuf(99)
    real(dp) :: recv(1:SUMS_LEN) !! mpi accumulator

    if (rt%simtime < nextanalyze) return

    nextanalyze = rt%simtime + dt_analyze

    sums = 0.0

    call mesh_iterate_quads(mesh,analyze_cb)

    call mpi_reduce(sums,recv,SUMS_LEN, MPI_DOUBLE_PRECISION, MPI_SUM, 0, rt%mpi%comm, ierr)

    if (rt%mpi%root) then
        cnt = 0

        resBuf(incr(cnt)) = rt%simtime
        resBuf(incr(cnt)) = rt%maxtimestep
        resBuf(incr(cnt)) = rt%timesteps
        resBuf(incr(cnt)) = recv(idens)
        resBuf(incr(cnt)) = recv(imomx)
        resBuf(incr(cnt)) = recv(imomy)
        resBuf(incr(cnt)) = recv(ietot)
        resBuf(incr(cnt)) = recv(imtot)

        ! resBuf(incr(cnt)) = recv(ibulkd)
        ! resBuf(incr(cnt)) = recv(ibulkx)
        ! resBuf(incr(cnt)) = recv(ibulky)
        ! resBuf(incr(cnt)) = recv(ibulke)

!!         resBuf(incr(cnt)) = recv(ieint)
!!         resBuf(incr(cnt)) = recv(iekin)
!! # if MODULE_SELF_GRAVITY
!!         resBuf(incr(cnt)) = recv(iepot)
!! # endif
!!
!! # if ANGULAR_MOMENTUM
!!         resBuf(incr(cnt)) = recv(iLtot)
!!         resBuf(incr(cnt)) = recv(iHtot)
!! # endif

        call write2file(fpath, cnt, resBuf)
    end if

end subroutine

end module


program SPH

	use globvar, 			only: ntotal,nvirt,scale_k,allocateGlobalArrays,deallocateGlobalArrays
	use globvar_para, 		only: ierr,procid,numprocs,MPI_ftype
	use mpi
	use param, 				only: f,skf
	use param_para, 		only: CreateMPIType,Select_MPI_ftype

	use input_m, 			only: input,virt_part
	use kernel_m,			only: kernel_k
	use summary_m, 			only: preamble,time_print,print_summary
	use time_integration_m,	only: time_integration

	implicit none

	!Initializing MPI
	call MPI_INIT(ierr)
	call MPI_COMM_RANK(MPI_COMM_WORLD,procid,ierr) !Retrieving process rank
	call MPI_COMM_SIZE(MPI_COMM_WORLD,numprocs,ierr) !Retrieving total number of processes

	MPI_ftype = Select_MPI_ftype(f) ! choosing the appropriate float precision for MPI data transfers

	!Creating MPI derived types for use later
	call CreateMPIType

	!Printing preamble to screen
	call preamble

	! retrieving kernel k parameter for use in the program
	scale_k = kernel_k(skf)

	!Retrieving how many particles are to be generated. Hence the generate=.false.
	call input(.false.)
	call virt_part(.false.)

	if (procid.eq.0) write(*,'(A24,1x,I9,1x,A19)') 'Total simulation size of',ntotal,'physical particles.'

	!Allocating particle and interaction arrays
	call allocateGlobalArrays( )

	!Created fluid domain using particles
	call input(.true.)

	!Entering discretized time-integration loop
	call time_integration( )

	!Printing post-amble to terminal
	if (procid.eq.0) call time_print
	call print_summary

	!Cleaning up and ending MPI
	call deallocateGlobalArrays
	call MPI_FINALIZE(ierr)

end


PROGRAM LA_CGESDD_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_GESDD
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, INFO, M, N, MN
!  .. LOCAL ARRAYS ..
   CHARACTER(LEN=1) :: JOB
   REAL(WP), ALLOCATABLE :: AA(:,:), S(:), WW(:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:), U(:,:), VT(:,:), DUMMY(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'CGESDD ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) M, N
   PRINT *, 'M = ', M, ' N = ', N
   MN = MIN(M,N)
   ALLOCATE ( A(M,N), AA(M,N), S(MN), U(M,M), VT(N,N), WW(1:MN-1) )
!
      READ (NIN, *) AA
      A=AA
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, M; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,:); ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_CGESDD LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U, VT, WW, ''N'', INFO )'
   A=AA
   CALL LA_GESDD( A, S, U, VT, WW, 'N', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Singular values:'
   WRITE(NOUT,FMT) S
   WRITE(NOUT,*) 'Orthogonal/unitary matrix U):'
   DO I = 1, M; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) U(:,I); END DO
   WRITE(NOUT,*) 'Orthogonal/unitary matrix V**H):'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VT(:,I); END DO
   IF( INFO > 0 )THEN
      WRITE(NOUT,*) 'Unconverged superdiagonal elements:'
      WRITE(NOUT,FMT) WW
   ENDIF
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U, VT, WW, ''U'', INFO )'
   A=AA
   CALL LA_GESDD( A, S, U, VT, WW, 'U', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U, VT, WW, ''V'', INFO )'
   A=AA
   CALL LA_GESDD( A, S, U, VT, WW, 'V', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U, VT, WW, ''B'', INFO )'
   A=AA
   CALL LA_GESDD( A, S, U, VT, WW, 'B', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, VT=VT, WW=WW, JOB=''U'', INFO=INFO )'
   A=AA
   CALL LA_GESDD( A, S, VT=VT, WW=WW, JOB='U', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U=U, WW=WW, JOB=''V'', INFO=INFO )'
   A=AA
   CALL LA_GESDD( A, S, U=U, WW=WW, JOB='V', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, WW=WW, JOB=''V'', INFO=INFO )'
   A=AA
   CALL LA_GESDD( A, S, WW=WW, JOB='V', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, WW=WW, JOB=''U'', INFO=INFO )'
   A=AA
   CALL LA_GESDD( A, S, WW=WW, JOB='U', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, WW=WW, JOB=''N'', INFO=INFO )'
   A=AA
   CALL LA_GESDD( A, S, WW=WW, JOB='N', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U, VT )'
   A=AA
   CALL LA_GESDD( A, S, U, VT )
   WRITE(NOUT,*) ' Singular values:'
   WRITE(NOUT,FMT) S
   WRITE(NOUT,*) 'Orthogonal/unitary matrix U):'
   DO I = 1, M; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) U(:,I); END DO
   WRITE(NOUT,*) 'Orthogonal/unitary matrix V**H):'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VT(:,I); END DO
!
     WRITE(NOUT,*)
     WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U(:,1:MN), VT(1:MN,:) )'
     A=AA; U = HUGE(1.0_WP); VT = HUGE(1.0_WP)
     CALL LA_GESDD( A, S, U(:,1:MN), VT(1:MN,:) )
     WRITE(NOUT,*) ' Singular values:'
     WRITE(NOUT,FMT) S
     WRITE(NOUT,*) 'Orthogonal/unitary matrix U):'
     DO I = 1, M; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) U(:,I); END DO
       WRITE(NOUT,*) 'Orthogonal/unitary matrix V**H):'
       DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VT(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S )'
   A=AA
   CALL LA_GESDD( A, S )
   WRITE(NOUT,*) ' Singular values:'
   WRITE(NOUT,FMT) S
! STARTING ERROR TESTS
! ERROR 1
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( DUMMY, S, INFO=INFO )'
   A=AA
   CALL LA_GESDD( DUMMY, S, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 2
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S(1:MAX(M,N)+1), INFO=INFO )'
   A=AA
!   CALL LA_GESDD( A, S(1:MAX(M,N)+1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 3
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U(1:M-1,:), VT, WW, ''N'',INFO )'
   A=AA
!   CALL LA_GESDD( A, S, U(1:M-1,:), VT, WW, 'N', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 3
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U(:,1:MN-1), VT, WW, ''N'',INFO )'
   A=AA
   CALL LA_GESDD( A, S, U(:,1:MN-1), VT, WW, 'N', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 4
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U, VT(1:MN-1,:), WW, ''N'',INFO )'
   A=AA
   CALL LA_GESDD( A, S, U, VT(1:MN-1,:), WW, 'N', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 4
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, U, VT(:,1:N-1), WW, ''N'',INFO )'
   A=AA
   CALL LA_GESDD( A, S, U, VT(:,1:N-1), WW, 'N', INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 6
   JOB = 'T'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESDD( A, S, JOB=JOB, INFO=INFO )'
   A=AA
   CALL LA_GESDD( A, S,JOB=JOB, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
END PROGRAM LA_CGESDD_ET_EXAMPLE


************************************************************************
*
*     Subroutine DGEFA                                 Called by: FACINV
*
c     factors a matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
*
************************************************************************
      SUBROUTINE DGEFA(A,LDA,N,IPVT)
*
*     subroutine args
*
      INTEGER*4 LDA,N,IPVT(*)
      DOUBLE PRECISION A(LDA,*)
*
*     local vars
*
      INTEGER*4 IDAMAX,J,K,KP1,L
      DOUBLE PRECISION T
*
*     gaussian elimination with partial pivoting
*
      DO 60 K=1,N-1
         KP1 = K + 1
*
*        find pivot index, L
*
         L = IDAMAX(N-K+1,A(K,K)) + K - 1
         IPVT(K) = l
*
*        zero pivot implies this column already triangularized
*
         IF (A(L,K) .EQ. 0.D0) GOTO 60
*
*        interchange if necessary
*
         IF (L .NE. K) THEN
            T = A(L,K)
            A(L,K) = A(K,K)
            A(K,K) = T
         ENDIF
*
*        compute multipliers
*
         T = -1.D0/A(K,K)
         CALL DSCAL(N-K,T,A(K+1,K))
*
*        row elimination with column indexing
*
         DO 30 J=KP1,N
            T = A(L,J)
            IF (L .NE. K) THEN
               A(L,J) = A(K,J)
               A(K,J) = T
            ENDIF
            CALL DAXPY(N-K,T,A(K+1,K),A(K+1,J))
 30      CONTINUE
 60   CONTINUE

      IPVT(N) = N

      RETURN
      END


c gmm01f
c  subroutine mueller.f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
c  returns the values of 16 elements of the 4x4
c  Mueller matrix calculated from the known 2x2
c  amplitude scattering matrix
c  using Bohren & Huffman's formulas (p.65)
      subroutine mueller(s1,s2,s3,s4,s)
      double precision s(4,4),s1s,s2s,s3s,s4s
      complex*16 s1,s2,s3,s4
      complex*16 s2s3c,s1s4c,s2s4c,s1s3c,s1s2c
      complex*16 s3s4c,s2s1c,s4s3c,s2cs4,s3cs1
      s1s=cdabs(s1)**2
      s2s=cdabs(s2)**2
      s3s=cdabs(s3)**2
      s4s=cdabs(s4)**2
      s2s3c=s2*dconjg(s3)
      s1s4c=s1*dconjg(s4)
      s2s4c=s2*dconjg(s4)
      s1s3c=s1*dconjg(s3)
      s1s2c=s1*dconjg(s2)
      s3s4c=s3*dconjg(s4)
      s2s1c=s2*dconjg(s1)
      s4s3c=s4*dconjg(s3)
      s2cs4=dconjg(s2)*s4
      s3cs1=dconjg(s3)*s1
      s(1,1)=0.5d0*(s1s+s2s+s3s+s4s)
      s(1,2)=0.5d0*(s2s-s1s+s4s-s3s)
      s(1,3)=s2s3c+s1s4c
      s(1,4)=dimag(s2s3c-s1s4c)
      s(2,1)=0.5d0*(s2s-s1s-s4s+s3s)
      s(2,2)=0.5d0*(s2s+s1s-s4s-s3s)
      s(2,3)=s2s3c-s1s4c
      s(2,4)=dimag(s2s3c+s1s4c)
      s(3,1)=s2s4c+s1s3c
      s(3,2)=s2s4c-s1s3c
      s(3,3)=s1s2c+s3s4c
      s(3,4)=dimag(s2s1c+s4s3c)
      s(4,1)=dimag(s2cs4+s3cs1)
      s(4,2)=dimag(s2cs4-s3cs1)
      s(4,3)=dimag(s1s2c-s3s4c)
      s(4,4)=s1s2c-s3s4c
      return
      end


FUNCTION CSNDEQC(IOPT,SNDDIA,SSG,WS,TAUR,TAUB,D50,SIGPHI,SNDDMX,VDR,ISNDAL)

  ! *** CALCULATES NEAR BED REFERENCE CONCENTRATION FOR NONCOHESIVE SEDIMENT
  !
  ! CHANGE RECORD
  ! DATE MODIFIED     BY               DESCRIPTION
  !----------------------------------------------------------------------!
  ! 2011-03-02        PAUL M. CRAIG    FIXED CASE WHEN WS <= 0
  !                   JOHN HAMRICK     IF USTAR < WS SET EQUILBRIUM NEAR BED CONCENTRATION TO ZERO
  !                                    TRANSPORT VIA BED LOAD IMPLEMENTED IN SSEDTOX FOR
  !                                    USTAR**2 > CRITICAL SHIELDS AND USTAR < WS

  !     SNDDIA = SAND GRAIN DIAMETER
  !     SSG    = SAND GRAIN SPECIFIC GRAVITY
  !     WS     = SAND GRAIN SETTLING VELOCITY
  !     TAUR   = WATER DENSITY NORMALIZED CRITICAL SHIELDS STRESS
  !     TAUB   = WATER DENSITY NORMALIZED BED STRESS
  !     SSG    = SAND SPECIFIC GRAVITY
  !     SIGPHI = PHI SIZE STANDARD DEVIATION
  !     SNDDMX = D90 SEDIMENT DIAMETER OR MAX SEDIMENT DIAMETER
  !

  IMPLICIT NONE
  INTEGER :: IOPT,ISNDAL
  REAL :: CSNDEQC,SNDDIA,SSG,WS,TAUR,TAUB,D50,SIGPHI,SNDDMX,VDR,USTAR
  REAL :: REY,DFAC,RLAM,VAL,TMP,TAURS,REY3,RATIO,TMPVAL

  USTAR = SQRT(TAUB)
  IF( USTAR < WS )THEN
     CSNDEQC=0.
  ELSEIF( IOPT == 1 )THEN
    ! *** IOPT=1  BASED ON
    ! ***
    ! *** GARCIA, M., AND G. PARKER, 1991: ENTRAINMENT OF BED SEDIMENT
    ! *** INTO SUSPENSION, J. HYDRAU LIC ENGINEERING, 117, 414-435.

    IF( WS > 0. )THEN
      REY=1.E6*SNDDIA*SQRT( 9.8*(SSG-1.)*SNDDIA )   !EQ 42
      REY=REY**0.6                                  !SEE EQ 43
      DFAC=1.
      IF( ISNDAL >= 1 ) DFAC=(SNDDIA/D50)**0.2        !SEE EQ 43
      RLAM=1.-0.29*SIGPHI                           !EQ 51
      VAL=DFAC*RLAM*REY*USTAR/WS                    !Z IN EQ 43
      VAL=1.3E-7*(VAL**5)                           !TOP OF EQ 45
      TMP=VAL/(1+3.33*VAL)                          !EQ 45
      CSNDEQC=1.E6*SSG*TMP                          !CONVERT TO MASS CONC
    ELSE
      CSNDEQC=0.
    ENDIF

  ELSEIF( IOPT == 2 )THEN
    ! *** IOPT=2  BASED ON
    ! ***
    ! *** SMITH, J. D., AND S. R. MCLEAN, 1977: SPATIALLY AVERAGED FLOW
    ! *** OVER A WAVY SURFACE, J. GEOPHYSICAL RESEARCH, 82, 1735-1746.

    VAL=2.4E-3*( (TAUB/TAUR)-1. )
    VAL=MAX(VAL,0.)
    TMP=0.65*VAL/(1.+VAL)
    CSNDEQC=1.E6*SSG*TMP

  ELSEIF( IOPT == 3 )THEN
    ! *** IOPT=3  BASED ON
    ! ***
    ! *** VAN RIJN, L. C., 1984: SEDIMENT TRANSPORT, PART II: SUSPENDED
    ! *** LOAD TRANSPORT, J. HYDRAULIC ENGINEERING, 110, 1623-1641.

    IF( WS > 0. )THEN
      REY=1.E4*SNDDIA*( (9.8*(SSG-1.))**0.333 )
      IF( REY <= 10.) TAURS=(4.*WS/REY)**2
      IF( REY>10.) TAURS=0.016*WS*WS
      REY3=REY**0.3
      VAL=(TAUB/TAURS)-1.
      VAL=MAX(VAL,0.)
      VAL=VAL**1.5
      RATIO=SNDDIA/(3.*SNDDMX)
      TMP=0.015*RATIO*VAL/REY3
      CSNDEQC=1.E6*SSG*TMP
    ELSE
      CSNDEQC=0.
    ENDIF

  ELSEIF( IOPT == 4 )THEN

    ! *** IOPT=4  BASED ON
    ! **
    ! *** J.M. HAMRICK'S PARAMETERIZATION OF SEDFLUME DATA NO CRITICAL STRESS
    IF( WS > 0. )THEN
      REY=1.E4*SNDDIA*( (9.8*(SSG-1.))**0.333 )
      TMPVAL=SQRT(TAUB)/WS
      REY3=REY**1.333
      TMPVAL=REY3*TMPVAL
      VAL=(TMPVAL-1.0)**5.
      VAL=4.E-9*VAL
      CSNDEQC=1.E6*SSG*VAL/(1.+VDR)
    ELSE
      CSNDEQC=0.
    ENDIF

  ELSEIF( IOPT == 5 )THEN
    ! *** IOPT=5  BASED ON
    ! **
    ! *** J.M. HAMRICK'S PARAMETERIZATION OF SEDFLUME DATA WITH CRITICAL STRESS
    IF( WS > 0. )THEN
      REY=1.E4*SNDDIA*( (9.8*(SSG-1.))**0.333 )
      TMPVAL=SQRT(TAUB)/WS
      REY3=REY**1.333
      TMPVAL=REY3*TMPVAL
      VAL=0.0
      IF( TMPVAL > 1.0 ) VAL=(TMPVAL-1.0)**5.
      VAL=4.E-9*VAL
      CSNDEQC=1.E6*SSG*VAL/(1.+VDR)
    ELSE
      CSNDEQC=0.
    ENDIF
  ELSE
    ! *** BAD OPTION
    STOP ' BAD CSNDEQC OPTION'
  ENDIF

  RETURN
  END


      SUBROUTINE PLOAD1 (OPT,ISLT,V,SA,SB,BA,BB,PA,PB,TA,TB,SLT,EPT)
C
C     PLOAD1 CALCULATES THE END LOADS ON A BAR ELEMENT FOR PLOAD1 LOADS
C     IT IS CALLED ONLY BY PLBAR1
C
C     OPT   = 1, CALLED FROM PLBAR1/EXTERN,  2, CALLED FROM SDRX
C     SLT   = PLOAD1 CARD
C     V     = REFERENCE VECTOR IN BASIC
C     SA    = OFFSET VECTOR IN BASIC POINT A
C     SB    = OFFSET VECTOR IN BASIC POINT B
C     BA    = BASIC  COORD  FOR POINT A
C     BB    = BASIC  COORD  FOR POINT B
C     PA    = LOAD   VECOTR FOR POINT A
C     PB    = LOAD   VECOTR FOR POINT B
C     TA,TB = TRANSFORMATION MATRICES FOR A AND B ONLY USED WITH OPT 1
C     EPT   = POINTER TO EST
C
      INTEGER          OPT,OLDID,TYPE,SCALE,ISLT(7)
      REAL             LEN
      DOUBLE PRECISION AX,AY,AZ,BX,BY,BZ,DX1,DX2,DL,DT,DFX1,DFY1,DFZ1,
     1                 DFX2,DFY2,DFZ2,S1,S2,S3,S4,S5,
     2                 I01,I11,I21,I31,I41,I02,I12,I22,I32,I42
      DIMENSION        V(3),SA(3),SB(3),BA(3),BB(3),PA(6),PB(6),EPT(32),
     1                 A(3),B(3),C(3),D(9),E(9),SLT(7),TA(9),TB(9),TP(3)
      COMMON /MATOUT/  F,G
      EQUIVALENCE      (A(1),E(1)),(B(1),E(7)),(C(1),E(4))
      DATA    OLDID ,  D / 10*0 /
C
      IF (OLDID .EQ. ISLT(1)) GO TO 20
      OLDID = ISLT(1)
C
C     CALCULATE AXIS AND LENGTH, AND THE E MATRIX
C
      A(1) = BB(1)-BA(1) + SB(1)-SA(1)
      A(2) = BB(2)-BA(2) + SB(2)-SA(2)
      A(3) = BB(3)-BA(3) + SB(3)-SA(3)
      LEN  = SQRT(SADOTB(A,A))
      IF (LEN .EQ. 0.0) GO TO 380
      A(1) = A(1)/LEN
      A(2) = A(2)/LEN
      A(3) = A(3)/LEN
      CALL SAXB (A,V,B)
C
      TEMP = SQRT(SADOTB(B,B))
      IF (TEMP .EQ. 0.0) GO TO 380
      B(1) = B(1)/TEMP
      B(2) = B(2)/TEMP
      B(3) = B(3)/TEMP
      CALL SAXB (B,A,C)
C
C     TRANSVERSE SHEAR
C
      TEMP = EPT(31)*EPT(17)*G*LEN**2
      TMP  = 12.0*F*EPT(18)
      ALY  = 0.0
      IF (ABS(TEMP+TMP) .GT. 1.0E-14) ALY = TMP/(TMP+TEMP)
      OMALY = 1.0 - ALY
C
      TEMP = (TEMP/EPT(31))*EPT(32)
      TMP  = 12.0*F*EPT(19)
      ALZ  = 0.0
      IF (ABS(TEMP+TMP) .GT. 1.0E-14) ALZ = TMP/(TMP+TEMP)
      OMALZ = 1.0 - ALZ
C
C     START BUILDING THE FORCES AND MOMENTS
C
   20 TYPE  = ISLT(2)
      SCALE = ISLT(3)
      X1  =  SLT(4)
      F1  =  SLT(5)
      X2  =  SLT(6)
      F2  =  SLT(7)
      I   = (TYPE-1)/6 + 1
      J   = MOD(TYPE,6)
      IF (J .EQ. 0) GO TO 60
      GO TO (30,30,30,40,50,60), J
   30 FX1 = A(J)*F1
      FY1 = C(J)*F1
      FZ1 = B(J)*F1
      FX2 = A(J)*F2
      FY2 = C(J)*F2
      FZ2 = B(J)*F2
      GO TO 100
   40 FX1 = F1
      FY1 = 0.0
      FZ1 = 0.0
      FX2 = F2
      FY2 = 0.0
      FZ2 = 0.0
      GO TO 100
   50 FX1 = 0.0
      FY1 = F1
      FZ1 = 0.0
      FX2 = 0.0
      FY2 = F2
      FZ2 = 0.0
      GO TO 70
   60 FX1 = 0.0
      FY1 = 0.0
      FZ1 = F1
      FX2 = 0.0
      FY2 = 0.0
      FZ2 = F2
   70 J   = 4
C
C     SCALED
C
  100 IF (SCALE.EQ.2 .OR. SCALE.EQ.4) GO TO 110
      X1  = X1/LEN
      X2  = X2/LEN
C
C     DISTRIBUTED SCALED LOADS
C
  110 IF (X1 .EQ. X2) GO TO 220
      IF (SCALE.LE.2 .OR. J.EQ.4) GO TO 120
      FSCALE = SQRT(1.0-A(J)**2)
      FX1  = FSCALE*FX1
      FY1  = FSCALE*FY1
      FZ1  = FSCALE*FZ1
      FX2  = FSCALE*FX2
      FY2  = FSCALE*FY2
      FZ2  = FSCALE*FZ2
C
C     DISTRIBUTED LOADS
C
  120 DX1  = X1
      DX2  = X2
      DL   = LEN
      DFX1 = FX1
      DFY1 = FY1
      DFZ1 = FZ1
      DFX2 = FX2
      DFY2 = FY2
      DFZ2 = FZ2
      S1   = DX2 - DX1
      S2   = .5000000D0*(DX2**2 - DX1**2)
      S3   = .3333333D0*(DX2**3 - DX1**3)
      S4   = .2500000D0*(DX2**4 - DX1**4)
      S5   = .2000000D0*(DX2**5 - DX1**5)
      IF (I .EQ. 2) GO TO 140
C
C     FORCES
C
      I01  = DL*(S1-S2)
      I11  = DL*(S1-3.0D0*S3 + 2.0D0*S4)
      I21  = DL*(   3.0D0*S3 - 2.0D0*S4)
      I31  = DL*(S2-2.0D0*S3 + S4)
      I41  = DL*(S4-S3)
      DT   = DL*DL
      I02  = DT*(S2-S3)
      IF (F1 .EQ. F2) GO TO 130
      I12  = DT*(S2-3.0D0*S4 + 2.0D0*S5)
      I22  = DT*(   3.0D0*S4 - 2.0D0*S5)
      I32  = DT*(S3-2.0D0*S4 + S5)
      I42  = DT*(S5-S4)
      DT   = DL*(DX2-DX1)
      BX   = (DFX2-DFX1)/DT
      BY   = (DFY2-DFY1)/DT
      BZ   = (DFZ2-DFZ1)/DT
      AX   = DFX1 - DX1*BX*DL
      AY   = DFY1 - DX1*BY*DL
      AZ   = DFZ1 - DX1*BZ*DL
      GO TO 170
  130 AX   = DFX1
      AY   = DFY1
      AZ   = DFZ1
      GO TO 160
C
C     MOMENTS
C
  140 I01  = DL*(S1-S2)
      I11  =-6.0D0*(S2-S3)
      I21  =-I11
      I31  = S1 - 4.0D0*S2 + 3.0D0*S3
      I41  =    - 2.0D0*S2 + 3.0D0*S3
      IF (F1 .EQ. F2) GO TO 150
      I02  = (S2-S3)*DL**2
      I12  =-6.0D0*DL*(S3-S4)
      I22  =-I12
      I32  = DL*(S2-4.0D0*S3 + 3.0D0*S4)
      I42  =-DL*(   2.0D0*S3 - 3.0D0*S4)
      DT   = (DX2 -DX1)*DL
      BX   = (DFX2-DFX1)/DT
      BY   = (DFZ2-DFZ1)/DT
      BZ   =-(DFY2-DFY1)/DT
      AX   = DFX1 + DX1*BX*DL
      AY   = DFZ1 + DX1*BY*DL
      AZ   =-DFY1 + DX1*BZ*DL
      GO TO 170
  150 AX   = DFX1
      AY   = DFZ1
      AZ   =-DFY1
  160 BX   = 0.0D0
      BY   = 0.0D0
      BZ   = 0.0D0
      I12  = 0.0D0
      I22  = 0.0D0
      I32  = 0.0D0
      I42  = 0.0D0
C
C     LOADS
C
  170 PA(1) = I01*AX + I02*BX
      PA(2) = I11*AY + I12*BY
      PA(3) = I11*AZ + I22*BZ
      PA(4) = 0.0
      PA(5) =-DL*(I31*AZ + I32*BZ)
      PA(6) = DL*(I31*AY + I32*BY)
      DT    = DL*DL
      PB(1) = DL*S2*AX + DT*S3*BX
      PB(2) = I21  *AY + I22  *BY
      PB(3) = I21  *AZ + I22  *BZ
      PB(4) = 0.0
      PB(5) =-DL*(I41*AZ + I42*BZ)
      PB(6) = DL*(I41*AY + I42*BY)
      IF (I .EQ. 2) GO TO 190
      IF (ALY .EQ. 0.0) GO TO 180
      PA(2) = OMALY*PA(2) + ALY*(  I01*AY + I02*BY   )
      PA(6) = OMALY*PA(6) + ALY*(  I02*AY - I41*BY*DT)*.50
      PB(2) = OMALY*PB(2) + ALY*(DL*S2*AY + S3 *BY*DT)
      PB(6) = OMALY*PB(6) - ALY*(  I02*AY - I41*BY*DT)*.50
  180 IF (ALZ .EQ. 0.0) GO TO 300
      PA(3) = OMALZ*PA(3) + ALZ*(  I01*AZ + I02*BZ   )
      PA(5) = OMALZ*PA(5) - ALZ*(  I02*AZ - I41*BZ*DT)*.50
      PB(3) = OMALZ*PB(3) + ALZ*(DL*S2*AZ + S3 *BZ*DT)
      PB(5) = OMALZ*PB(5) + ALZ*(  I02*AZ - I41*BZ*DT)*.50
      GO TO 300
  190 TEMP  = PA(1)
      PA(1) = PA(4)
      PA(4) = TEMP
      TEMP  = PB(1)
      PB(1) = PB(4)
      PB(4) = TEMP
      IF (ALY .EQ. 0.0) GO TO 200
      PA(2) = OMALY*PA(2)
      PA(6) = OMALY*PA(6) + ALY*(I01*AY + I02*BY)
      PB(2) = OMALY*PB(2)
      PB(6) = OMALY*PB(6) + ALY*(DL*S2*AY + S3*BY*DT)
  200 IF (ALZ .EQ. 0.0) GO TO 300
      PA(3) = OMALZ*PA(3)
      PA(5) = OMALZ*PA(5) + ALZ*(I01*AZ + I02*BZ)
      PB(3) = OMALZ*PB(3)
      PB(5) = OMALZ*PB(5) + ALZ*(DL*S2*AZ + S3*BZ*DT)
      GO TO 300
C
C     CONCENTRATED LOADS
C
  220 TMP = 1.0 - X1
      IF (I .EQ. 2) GO TO 230
C
C     FORCES
C
      TEMP  = 1.0 - 3.0*X1**2 + 2.0*X1**3
      PA(1) = TMP*FX1
      PA(2) = TEMP*FY1*OMALY + FY1*TMP*ALY
      PA(3) = TEMP*FZ1*OMALZ + FZ1*TMP*ALZ
      PA(4) = 0.0
      TEMP  =-LEN*X1*TMP**2
      TMP   = TMP*LEN*X1*.50
      PA(5) = TEMP*FZ1*OMALZ - FZ1*TMP*ALZ
      PA(6) =-TEMP*FY1*OMALY + FY1*TMP*ALY
      TEMP  = 3.0*X1**2 - 2.0*X1**3
      PB(1) = X1*FX1
      PB(2) = TEMP*FY1*OMALY + FY1*X1*ALY
      PB(3) = TEMP*FZ1*OMALZ + FZ1*X1*ALZ
      PB(4) = 0.0
      TEMP  = (1.0-X1)*LEN*X1**2
      PB(5) = TEMP*FZ1*OMALZ + FZ1*TMP*ALZ
      PB(6) =-TEMP*FY1*OMALY - FY1*TMP*ALY
      GO TO 300
C
C     MOMENTS
C
  230 TEMP  =-(6.0/LEN*X1)*TMP
      PA(1) = 0.0
      PA(2) = TEMP*FZ1*OMALY
      PA(3) =-TEMP*FY1*OMALZ
      PA(4) = TMP*FX1
      TEMP  = 1.0 - 4.0*X1 + 3.0*X1**2
      PA(5) = TEMP*FY1*OMALZ + FY1*TMP*ALZ
      PA(6) = TEMP*FZ1*OMALY + FZ1*TMP*ALY
      PB(1) = 0.0
      PB(2) =-PA(2)
      PB(3) =-PA(3)
      PB(4) = X1*FX1
      TEMP  = 3.0*X1**2 - 2.0*X1
      PB(5) = TEMP*FY1*OMALZ + FY1*X1*ALZ
      PB(6) = TEMP*FZ1*OMALY + FZ1*X1*ALY
      GO TO 300
C
C     PIN FLAGS
C
  300 CALL PLOAPF (EPT,EPT,LEN,PA,PB)
C
C     LOAD VECTORS DONE FOR SDRX
C
      IF (OPT .EQ. 2) GO TO 400
C
C     TRANSFORM LOAD VECTOR TO GLOBAL
C
      CALL GMMATS (E ,3,3,1,PA(1),3,1,0,TP   )
      CALL GMMATS (TA,3,3,1,TP   ,3,1,0,PA(1))
      CALL GMMATS (E ,3,3,1,PB(1),3,1,0,TP   )
      CALL GMMATS (TB,3,3,1,TP   ,3,1,0,PB(1))
      CALL GMMATS (E ,3,3,1,PA(4),3,1,0,TP   )
      CALL GMMATS (TA,3,3,1,TP   ,3,1,0,PA(4))
      CALL GMMATS (E ,3,3,1,PB(4),3,1,0,TP   )
      CALL GMMATS (TB,3,3,1,TP   ,3,1,0,PB(4))
C
      DO 310 I = 1,3
      IF (SA(I) .NE. 0.0) GO TO 320
  310 CONTINUE
      GO TO 330
  320 D(2)  =-SA(3)
      D(3)  = SA(2)
      D(4)  = SA(3)
      D(6)  =-SA(1)
      D(7)  =-SA(2)
      D(8)  = SA(1)
      CALL GMMATS (D,3,3,0,PA(1),3,1,0,TP)
      PA(4) = PA(4) + TP(1)
      PA(5) = PA(5) + TP(2)
      PA(6) = PA(6) + TP(3)
C
  330 DO 340 I = 1,3
      IF (SB(I) .NE. 0.0) GO TO 350
  340 CONTINUE
      GO TO 400
  350 D(2)  =-SB(3)
      D(3)  = SB(2)
      D(4)  = SB(3)
      D(6)  =-SB(1)
      D(7)  =-SB(2)
      D(8)  = SB(1)
      CALL GMMATS (D,3,3,0,PB(1),3,1,0,TP)
      PB(4) = PB(4) + TP(1)
      PB(5) = PB(5) + TP(2)
      PB(6) = PB(6) + TP(3)
      GO TO 400
C
C     ERROR
C
  380 CALL MESAGE (-30,31,OLDID)
C
  400 RETURN
      END


! File VersionID:
!   $Id: rootextraction.for 192 2011-02-10 13:39:33Z kroes006 $
! ----------------------------------------------------------------------
      subroutine RootExtraction
! ----------------------------------------------------------------------
!     update    : February 2011: macrosopic uptake extended with compensation
!     date      : August 2004
!     purpose   : Calculate the root water extraction rate as function of soil water
!                 pressure head and salinity concentration for each node
! ----------------------------------------------------------------------
      use variables
      implicit none

! --- local variables
      integer node, lay, countpf                                        ! NwRootExtr
      logical flnus
      real*8  top,bot,ecsat,afgen,hlim3,hlim2,qpotrot,qred
      real*8  alpdry,alpwet,alpsol,alpwat,alpfrs,alptot,vsmall,factor
      real*8  qredwet(macp),qreddry(macp),qredsol(macp),qredfrs(macp)
      real*8  rmax,hwet                                                 ! NwRootExtr
      real*8  reldepth,rdensity,phi,sumrho,meandepth                    !
      logical flactive(macp),flhydrlift                                 !
      character messag*200

      save    countpf                                                   ! NwRootExtr
      parameter (vsmall = 1.0d-7)

! ----------------------------------------------------------------------
! --- reset root water extraction array
      do 10 node = 1,numnod
        qrot(node) = 0.0d0
10    continue
      qrosum = 0.0d0
      qreddrysum = 0.0d0
      qredwetsum = 0.0d0
      qredsolsum = 0.0d0
      qredfrssum = 0.0d0

! --- skip routine if there are no roots
      if (rd .lt. 1.d-3) return

! --- determine lowest compartment containing roots
      node = 1
      do while ((z(node) - dz(node)*0.5d0) .gt. (-rd + 1.d-8))
        node = node + 1
      end do
      noddrz = node

! --- skip routine if transpiration rate is zero                        ! NwRootExtr
      if (ptra .lt. 1.d-10) then                                        !
        if (swroottyp .eq. 2) then                                      !
! ---   set matric flux and pressure head at root surface equal to wettest node
          node = 1                                                      !
          hwet = h(node)                                                !
          call matricflux(2,h(node),node)                               !
          mfluxroot = mflux(node)                                       !
          do node = 2,noddrz                                            !
            if (h(node) .gt. hwet) then                                 !
              hwet = h(node)                                            !
              call matricflux(2,h(node),node)                           !
              mfluxroot = mflux(node)                                   !
            endif                                                       !
          enddo                                                         !
        endif                                                           !
! ---   skip root extraction routine                                    !
        return                                                          !

      endif                                                             !

                                                                        !

      if (swroottyp .eq. 1) then

! ===   ROOTWATER EXTRACTION ACCORDING TO FEDDES REDUCTION FUNCTION

! ---   calculate potential root extraction of the compartments
        do node = 1,noddrz
          top = abs((z(node) + 0.5*dz(node)) / rd)
          bot = abs((z(node) - 0.5*dz(node)) / rd)
          qrot(node) =
     &             (afgen(cumdens,202,bot)-afgen(cumdens,202,top))* ptra

        enddo

!=============================================================================
!        do node = 1,noddrz
!            write (*,65) qrot(node),rd,z(node),dz(node),ptra,h(node)
!65    format(10F7.3)
!        enddo
!      pause
!==============================================================================

! ---   calculating critical point hlim3 according to feddes
        hlim3=hlim3h
        if (atmdem.ge.adcrl) then
          if (atmdem.le.adcrh)   hlim3 =
     &            hlim3h+((adcrh-atmdem)/(adcrh-adcrl)) *(hlim3l-hlim3h)
        else
          hlim3 = hlim3l
        endif

! ---   calculation of transpiration reduction
        hlim2 = hlim2u
        do 200 node = 1,noddrz
          alpdry = 1.0d0
          alpwet = 1.0d0
          alpwat = 1.0d0
          alpsol = 1.0d0
          alpfrs = 1.0d0

! ---     reduction due to water stress
          if (node.gt.botcom(1)) hlim2=hlim2l
! ---     waterstress/ wet circumstances
          if (h(node).le.hlim1.and.h(node).gt.hlim2) then
            alpwat = (hlim1-h(node))/(hlim1-hlim2)
            alpwet = alpwat
          endif
! ---     waterstress/ dry circumstances
          if (h(node).le.hlim3.and.h(node).ge.hlim4) then
            alpwat = (hlim4-h(node))/(hlim4-hlim3)
            alpdry = alpwat
          endif
! ---     no transpiration
          if (h(node).gt.hlim1) then
            alpwat = 0.0d0
            alpwet = alpwat
          endif
          if (h(node).lt.hlim4) then
            alpwat = 0.0d0
            alpdry = alpwat
          endif

! ---     reduction due to salt stress
          if (swsolu.eq.1) then
            lay = layer(node)
            ecsat = c2eca * ( cml(node) *
     &            theta(node)/(thetsl(lay)*c2ecf(lay)) ) **c2ecb
            if (ecsat .lt. ecmax) then
              alpsol = 1.0d0
            else
              alpsol = (100.0d0 - (ecsat - ecmax)*ecslop) / 100.
              alpsol = max(0.0d0,alpsol)
            endif
          endif

! ----    reduction due to frost conditions
          if (swfrost.eq.1.and.tsoil(node).lt.0.0d0) then
            alpfrs = 0.0d0
          endif

! ----    overall reduction
          qpotrot = qrot(node)
          qrot(node) = qrot(node)*alpwet*alpdry*alpsol*alpfrs
          qrosum = qrot(node) + qrosum

! ----    apportionment to different types stresses (cm)
          qred = qpotrot - qrot(node)
          if(qred.lt.vsmall)then
            qredwet(node) = 0.d0
            qreddry(node) = 0.d0
            qredsol(node) = 0.d0
            qredfrs(node) = 0.d0
          else
            alptot = 0.0d0
!         set flag for non unique stress
            flnus = .true.
            if(alpwet .gt. vsmall) then
               alptot = alptot + dlog(alpwet)
            else
              qredwet(node) = qred
              qreddry(node) = 0.d0
              qredsol(node) = 0.d0
              qredfrs(node) = 0.d0
              flnus = .false.
            end if
            if(flnus)then
              if(alpdry .gt. vsmall) then
                 alptot = alptot + dlog(alpdry)
              else
                qredwet(node) = 0.d0
                qreddry(node) = qred
                qredsol(node) = 0.d0
                qredfrs(node) = 0.d0
                flnus = .false.
              end if
            end if
            if(flnus)then
              if(alpsol .gt. vsmall) then
                 alptot = alptot + dlog(alpsol)
              else
                qredwet(node) = 0.d0
                qreddry(node) = 0.d0
                qredsol(node) = qred
                qredfrs(node) = 0.d0
                flnus = .false.
              end if
            end if
            if(flnus)then
              if(alpfrs .gt. vsmall) then
                 alptot = alptot + dlog(alpfrs)
              else
                qredwet(node) = 0.d0
                qreddry(node) = 0.d0
                qredsol(node) = 0.d0
                qredfrs(node) = qred
                flnus = .false.
              end if
            end if

            if(flnus)then
              qredwet(node) = dlog(alpwet) / alptot * qred
              qreddry(node) = dlog(alpdry) / alptot * qred
              qredsol(node) = dlog(alpsol) / alptot * qred
              qredfrs(node) = dlog(alpfrs) / alptot * qred
            end if
          end if

          qredwetsum = qredwetsum + qredwet(node)
          qreddrysum = qreddrysum + qreddry(node)
          qredsolsum = qredsolsum + qredsol(node)
          qredfrssum = qredfrssum + qredfrs(node)

200           continue

! --    Compensated root water uptake according to Jarvis (1989)
        if (abs(alphacrit-1.0d0).ge.vsmall .and.
     &                           abs(qrosum-ptra).ge.vsmall) then
          alptot = qrosum / ptra
          if (alptot .gt. alphacrit) then
            do node = 1,noddrz
              qrot(node) = qrot(node) / alptot
            enddo
            qredwetsum = 0.0d0
            qreddrysum = 0.0d0
            qredsolsum = 0.0d0
            qredfrssum = 0.0d0
            qrosum = ptra
          else
            do node = 1,noddrz
              qrot(node) = qrot(node) / alphacrit
            enddo
            factor = (ptra - qrosum / alphacrit) / (ptra - qrosum)
            qredwetsum = qredwetsum * factor
            qreddrysum = qreddrysum * factor
            qredsolsum = qredsolsum * factor
            qredfrssum = qredfrssum * factor
            qrosum = qrosum / alphacrit
          endif
        endif

      else if (swroottyp .eq. 2) then

! ===    ROOTWATER EXTRACTION ACCORDING TO MATRIC FLUX POTENTIAL           ! NwRootExtr

! ---   initialization
        phi = 3.1415926d0
        mfluxroot = 0.d0
        flhydrlift = .false.
        if (countpf .eq. 0) countpf = 1

        do node = 1,noddrz
           flactive(node) = .true.
        enddo

! ---   calculate current matric flux potential MFlux
        do node = 1,numnod
          call MatricFlux(2,h(node),node)
        enddo

! ---   maximum root extraction (M0 = 0)
        do node = 1,noddrz-1
          reldepth = -z(node)/rd
          rdensity = afgen(rdctb,22,reldepth)
          rmax = 1.d0/sqrt(phi*rdensity)
          rootrho(node) = 4.d0/(rootcoefa*rmax * rootcoefa*rmax -
     &     rootradius*rootradius + 2.d0 * (rmax*rmax - rootradius *
     &     rootradius) * log(rootcoefa*rmax/rootradius))
          qrot(node) = rootrho(node)*mflux(node)*dz(node)
          qrosum = qrot(node) + qrosum
        enddo

! ---   last node, partly filled with roots
        node = noddrz
        meandepth = (z(node)+0.5*dz(node)-rd)/2.d0
        reldepth = meandepth/(-rd)
        rdensity = afgen(rdctb,22,reldepth)
        rmax = 1.d0/sqrt(phi*rdensity)
        rootrho(node) = 4.d0/(rootcoefa*rmax * rootcoefa*rmax -
     &     rootradius*rootradius + 2.d0 * (rmax*rmax - rootradius *
     &     rootradius) * log(rootcoefa*rmax/rootradius))
        if (node.gt.1) then
          mflux(node) = mflux(node) + (mflux(node-1)-mflux(node))/
     &              (z(node-1)-z(node)) * (meandepth-z(node))
        endif
        qrot(node) = rootrho(node) * mflux(node) *
     &             (z(node) + 0.5*dz(node) + rd)
        qrosum = qrot(node) + qrosum

        if (qrosum .gt. ptra) then
! ---     no water stress, calculate mfluxroot
          sumrho = 0.d0
          do node = 1,noddrz-1
            sumrho = sumrho + rootrho(node)*dz(node)
          enddo
          node = noddrz
          sumrho = sumrho + rootrho(node)*(z(node) + 0.5*dz(node) + rd)
          mfluxroot = (qrosum - ptra) / sumrho

! ---     calculate distribution root water uptake for potential conditions
          qrosum = 0.d0
          do node = 1,noddrz - 1
            qrot(node) = rootrho(node)*(mflux(node)-mfluxroot)*dz(node)
            if (qrot(node) .lt. 0.d0) then
              flhydrlift = .true.
              qrot(node) = 0.d0
              flactive(node) = .false.
            endif
            qrosum = qrot(node) + qrosum
          enddo
          node = noddrz
          qrot(node) = rootrho(node) * (mflux(node)-mfluxroot) *
     &               (z(node) + 0.5*dz(node) + rd)
          if (qrot(node) .lt. 0.d0) then
            flhydrlift = .true.
            qrot(node) = 0.d0
            flactive(node) = .false.
          endif
          qrosum = qrot(node) + qrosum

! ---     extra loop required when flhydrlift = .true.
          do while (flhydrlift)
            flhydrlift = .false.

! ---       determine sum maximum root extraction for active compartments
            qrosum = 0.d0
            do node = 1,noddrz-1
              if (flactive(node)) then
                qrot(node) = rootrho(node)*mflux(node)*dz(node)
                qrosum = qrot(node) + qrosum
              endif
            enddo
            node = noddrz
            if (flactive(node)) then
              qrot(node) = rootrho(node) * mflux(node) *
     &                   (z(node) + 0.5*dz(node) + rd)
              qrosum = qrot(node) + qrosum
            endif

! ---       no water stress, calculate M0 for active compartments
            sumrho = 0.d0
            do node = 1,noddrz-1
              if (flactive(node))
     &                          sumrho = sumrho + rootrho(node)*dz(node)
            enddo
            node = noddrz
            if (flactive(node)) sumrho = sumrho + rootrho(node) *
     &                                 (z(node) + 0.5*dz(node) + rd)
            mfluxroot = (qrosum - ptra) / sumrho

! ---       calculate again distribution root water uptake for potential conditions
            qrosum = 0.d0
            do node = 1,noddrz - 1
              if (flactive(node)) then
                qrot(node) =
     &                    rootrho(node)*(mflux(node)-mfluxroot)*dz(node)
                if (qrot(node) .lt. 0.d0) then
                  flhydrlift = .true.
                  qrot(node) = 0.d0
                  flactive(node) = .false.
                endif
                qrosum = qrot(node) + qrosum
              endif
            enddo
            node = noddrz
            if (flactive(node)) then
              qrot(node) = rootrho(node) * (mflux(node)-mfluxroot) *
     &                   (z(node) + 0.5*dz(node) + rd)
              if (qrot(node) .lt. 0.d0) then
                flhydrlift = .true.
                qrot(node) = 0.d0
                flactive(node) = .false.
              endif
              qrosum = qrot(node) + qrosum
            endif
          enddo

        else
! ---     actual transpiration less than potential transpiration
          mfluxroot = 0.0d0
        endif

      else

        messag = ' SwRootTyp not defined !'
        call fatalerr('rootextraction',messag)

      endif

      return
      end