! fortran_free_source
!
! This module is part of PERFCODE, written by Brad Eck

MODULE pfc1Dsubs
implicit none
contains

!   1. setup_1D_section
!   2. grid_1D_section
!   3. PFC1DIMP

!===================================================================================
!       \\\\\\\\\\      B E G I N    S U B R O U T I N E      //////////
!       //////////     S E T U P    1 D   S E C T I O N       \\\\\\\\\\
!===================================================================================
SUBROUTINE setup_1D_section( )
!   does the setup work for looking at this as a 1D section
USE shared,    ONLY: Z_lp, nr_lp, dist_lp, slope_cs_1D,        &
                     wid_cs_1d, eta_cs_1d, nr_cs, long_slope,  &
                     slope_cs, wid_cs
USE utilities, ONLY: F_PythagSum
!------------------------------------------------------------------
integer :: i
!------------------------------------------------------------------
! Compute longitudinal slope
!  ( assumed to be constant thorought the domain)
long_slope = (    Z_lp( nr_lp ) -    Z_lp( 1 ) ) / &
             ( dist_lp( nr_lp ) - dist_lp( 1 ) )

! Using the longitudinal slope and cross slope,
! compute the slopes and segment widths for the 1D profile

allocate( slope_cs_1d( nr_cs) )
allocate(   wid_cs_1d( nr_cs) )
allocate(   eta_cs_1d( nr_cs+1) )

write(*,*) ''
write(*,*) '  1D CROSS SECTION   '
write(*,*) ' Segment   Slope   Width '
write(*,*) '============================'
do i = 1, nr_cs
    !For the slope, compute the magnitude of the resultant slope
    ! using pythagorean sum and then use the intrinsic SIGN function
    ! to give the resultant the same sign as the cross slope.
    slope_cs_1D(i) = SIGN (  F_PythagSum( long_slope, slope_cs(i) ) , &
                                                        slope_cs(i)       )
    ! Compute 1D width using similar triangles
    wid_cs_1D(i) = slope_cs_1D(i) / slope_cs(i) * wid_cs(i)
    ! Print the results as we go
    write(*,10) i, slope_cs_1D(i), wid_cs_1d(i)
end do
write(*,*) ''

eta_cs_1d(1) = 0.

! Compute etas and elevations
do i = 2, nr_cs + 1
    eta_cs_1d(i) = eta_cs_1d(i-1) +   wid_cs_1d(i-1) / sum( wid_cs_1D(1:nr_cs) )
end do

! print the results to confirm
print *, ' 1D CROSS SECTION POINTS '
WRITE(*,*) ' Point        Eta        '
WRITE(*,*)  '=================================='
do i = 1, nr_cs + 1
    write(*,10) i, eta_cs_1d(i)
end do

!--------------------------------------------------------------------------------
! Format Statements
10      FORMAT('   ', ( i3, '    '),  ( F10.3, '  ') , F10.6 )

!--------------------------------------------------------------------------------
end subroutine setup_1D_section
!===================================================================================
!       \\\\\\\\\\      E N D        S U B R O U T I N E   //////////
!       //////////     S E T U P  1 D  S E C T I O N       \\\\\\\\\\
!===================================================================================

!===================================================================================
!       \\\\\\\\\\      B E G I N    S U B R O U T I N E   //////////
!       //////////     G R I D   1 D   S E C T I O N       \\\\\\\\\\
!===================================================================================
SUBROUTINE grid_1d_section( slope_in, width_in, seg, dx )
!---------------------------------------------------------------------------
use shared, only: TNE, XCV, ZCV, EDX, etaCV
use pfc1Dfuns
use utilities, only: F_Linterp
use outputs, only: WRITE_MATRIX

!Define variables

    IMPLICIT NONE

    !CONSTANTS
    INTEGER, intent(in) :: seg
    real, intent(in) :: dx

    !ARRAYS
    REAL, dimension( seg ), intent(in) :: slope_in,  width_in

!calculation variables
    real, dimension(seg) :: slope, width
    INTEGER, dimension( seg ) :: ne, ir

    INTEGER :: gb

    INTEGER :: i, n, s, start, finish

    REAL, ALLOCATABLE :: xface(:), zface(:)
    real, allocatable :: seg_X(:), seg_Z(:)

    REAL :: DX1

!---------------------------------------------------
! Need to reverse slope and width arrays based on
!   the design of this subroutine.
! Indices for Reverse arrays (uses an implied DO loop )
ir = (/ ( i, i = seg, 1, -1  ) /)

    do i = 1, seg
        slope(i) = slope_in( ir(i) )
        width(i) = width_in( ir(i) )
           ne(i) = NINT( width(i) / dx )
    end do

!-------------------------------------------------------------
!Compute derivative quanties   & allocate remaining arrays

    gb = seg - 1
    TNE = sum(ne) + gb

    allocate( XFACE(TNE+1), &
              ZFACE(TNE+1), &
                XCV(TNE)  , &
                ZCV(TNE)  , &
                EDX(TNE)  , &
              etaCV(TNE)         )

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

! compute the points for the boundaries and the CV centers

    XFACE( 1 ) = 0. !could use a different starting point
    EDX(:) = dx     ! all elemnts are the same size

    do i = 1, TNE
        XFACE( i+1 ) = XFACE( i ) + EDX( i )
        XCV  ( i   ) = (  XFACE( i ) + XFACE( i+1 )  ) / 2.
        etaCV( i   ) = 1. - XCV( i ) / sum( width(:) )
    end do
!------------------------------------------------------------------------
! interpolate elevations of the points

    allocate ( seg_X(seg+1), seg_Z(seg+1) )

    seg_x(1) = 0.
    seg_Z(1) = 10.

    do i = 1, seg
        seg_x(i+1) = seg_X(i) + width(i)
        seg_Z(i+1) = seg_Z(i) + width(i) * slope(i)
    end do

    ! first cross section by interpolation
    ZFACE( 1 ) = seg_z( 1 )
    do i = 1, TNE
        ZFACE( i+1 ) =  F_linterp( XFACE( i+1 ) , seg_X, seg_Z, seg+1 )
        ZCV  ( i   ) =  F_linterp( XCV  ( i   ) , seg_X, seg_Z, seg+1 )
    end do

!------------------------------------------------------------------------
! output the resulting arrays

! VECTOR FORM
    OPEN( UNIT = 20, FILE = 'grid_1D_section.csv', STATUS = 'REPLACE' )
    WRITE(20,*) 'XFACE, ZFACE, CV, XCV, ZCV, EDX, etaCV'
    do i = 1, TNE
        WRITE(20,100) XFACE( i ), ZFACE( i ), i, XCV( i ), ZCV( i ), EDX(i), etaCV(i)
    end do
    WRITE(20,99) XFACE( TNE+1 ), ZFACE( TNE+1)
    close(20)

!--------------------------------------------------
!Format statements
90      FORMAT( I12, F12.6 )
99      FORMAT( 2( F12.6, ',' ) )
100     FORMAT( 2( F12.6, ',' ), 1(I12, ','), 5( F12.6, ',')  )

!------------------------------------------------------------------------------
    end subroutine GRID_1D_SECTION
!===================================================================================
!       \\\\\\\\\\          E N D   S U B R O U T I N E     //////////
!       //////////       G R I D  1 D  S E C T I O N        \\\\\\\\\\
!===================================================================================

!====================================================================================
!	\\\\\\\\\\\\     B E G I N     S U B R O U T I N E   //////////
!	////////////            P F C 1 D I M P              \\\\\\\\\\
!====================================================================================
!       Purpose:        This program computes a 1D solution for unsteady
!                       drainage through a PFC.  The water THICKNESS in each
!                       cell is used as the primary variable.
!       History:        Source code revised from previous program that used
!                       an explicit method, and revised again to use as a
!                       subroutien within the 2D model
!
!                       29 June 2011 -- added pointers for use with K and K_input etc.
!
!       IC:             The depth on input to the subroutine
!       BCs:            Various
!       Linearization:  Picard Iteration (lag the coefficients)
!       Linear Solver:  Thomas Alogorithm used for this 1D case
!
!       Externals:      1.
!                       2.

SUBROUTINE pfc1Dimp( h_old, dt, rain, tolit, qmax, &
                     h_new, imax, eta_0_BC, eta_1_BC, Qout, X_sheet, numit )
!bring in related modules
use shared,    only: K_input, g, b_pfc_input, n_mann_input, por_input, XCV, ZCV, EDX, &
                     etaCV, relax, relax_tran, h_pfc_min, eta_0_hp2_max
use utilities, only: F_Linterp, F_L2_NORM, MIXED_RESIDUAL
use solvers,   only: Thomas
use pfc1Dfuns
use outputs,   only: WRITE_MATRIX, write_vector

!-----------------------------------------------------------------------------------
!VARIABLE DECLARATIONS

implicit none
! NOTE:  Because of ONLY statement for modules, only the names variables
!        are used in this subroutine.  This allows re-using variables names
!        thus the variable 'h_old' in this subroutine is not the same as
!        the 'h_old' matrix in PERFCODE.

! Arguments
integer,              intent(in)   :: imax    ! imax == TNE from 1D gridding
real, dimension(imax), intent(in)  :: h_old
real,                   intent(in) :: dt
real,                   intent(in) :: rain
real,                   intent(in) :: tolit
integer,                intent(in) :: qmax
real, dimension(imax), intent(out) :: h_new
character( len = 7 )               :: eta_0_BC, eta_1_BC
real,  optional,       intent(out) :: Qout, X_sheet
integer, optional,     intent(out) :: numit

! Paramaters
real, pointer :: K, b_pfc, por, n_mann

!SCALERS
INTEGER :: i, n, q
REAL    :: PF, PF1, Cw, Ce, Ce1, Cw1
REAL    :: hp, hs
REAL    :: cputime
real, dimension(:), pointer ::  X, Z, DX

!guess values for water thickness
REAL    :: h_itr(imax)
!linear system (tri-diagonal)
REAL    :: main(imax), super(imax), sub(imax), RHS(imax)
!solution
REAL    :: h_temp (imax) !,  h_new  (imax)
!convergence test
REAL    :: relchg(imax)
!post processing
REAL    :: head  (imax), hygrad (imax)           ! head and hydraulic gradient
REAL, dimension(imax)    :: q_pav, q_surf, q_tot ! fluxes
!summary info
INTEGER :: loc  ! location of max change
REAL    :: maxdiff      ! max change
!CHARACTERS
CHARACTER(8) DATE
CHARACTER(10) TIME

logical :: transition
real, dimension( imax, qmax) :: h_temp_hist, h_itr_hist !for monitoring the solution through the iteration
real :: relaxation_factor   !  Relaxation Factor
real, dimension( imax ) :: residual

real :: b  ! an extra value for b_pfc

real :: hs1, hs2, ds  ! Sheet flow MOC
real :: hp1, hp2, dx_moc ! PFC flow MOC
real :: cross_slope
integer, dimension(1) :: i_Zmax   !index of point with highest elevation
real :: eps_itr_tol

integer :: nip    ! number of interpolation points
!----------------------------------------
! Set pointers (used this to avoid changing variable names)

X => XCV
Z => ZCV
DX => EDX

K      =>      K_input
por    =>    por_input
b_pfc  =>  b_pfc_input
n_mann => n_mann_input

b = b_pfc
n = 1
i_Zmax = maxloc( Z )
!-----------------------------------------------------------------------------------
!SPATIAL GRID  (from GRID_1D_SECTION

! INITIALIZE ARRAYS
    !iteration array
    h_itr = h_old

    ! Linear system
    main  = 0.
    super = 0.
    sub   = 0.
    rhs   = 0.

    ! Summary arrays
    numit   = 0.
    maxdiff = 0.
    loc     = 0.

!-----------------------------------------------------------------------------------
! Solution using Crank-Nicolson with tri-diagonal matrix algorithm
! main, super & sub are diagonals of the coefficient matrix
! RHS is the right hand side of the linear system

!open( unit = 50, file = 'PF_smry.csv',  status = 'REPLACE')
!write(50,54) 'n/i', (/ (i,  i = 1, imax) /)

! open( unit = 110, file = '1DRunDetails.txt', status = 'REPLACE')

54 format( ( A, ','), 10000( I12, ',') )

!iteration loop
do q = 1, qmax

! UPSTREAM BOUNDARY
i = 1
! First cell
 PF  = F_por( h_old(i) )
 PF1 = F_por( h_itr(i) )

BC1: if( eta_1_BC .EQ. 'NO_FLOW') then
  ! NO FLOW BOUNDARY  Cw ---> 0
    Cw  = 0.
    Ce  = F_CC( X(i  ), DX(i  ), h_old(i  ), Z(i),     &
                X(i+1), DX(i+1), h_old(i+1), Z(i+1) )
    !these coefficints are updated as the iteration progresses
    Cw1 = 0.
    Ce1 = F_CC( X(i  ), DX(i  ), h_itr(i  ), Z(i),     &
                X(i+1), DX(i+1), h_itr(i+1), Z(i+1) )
    !Diagonals of coefficient matrix
    main (i) =  1  +  dt / 2 * PF1 * Cw1 / DX(i) &
                   +  dt / 2 * PF1 * Ce1 / DX(i)
    super(i) =      - dt / 2 * PF1 * Ce1 / DX(i)
    sub  (i) =      - dt / 2 * PF1 * Cw1 / DX(i)    ! will be zero
    !Right hand side of linearized system
               ! part that came from n level
    RHS  (i) =    h_old(i) + dt / 2.  * PF *                   &
             !  (  Cw / DX(i) * (  h_old(i-1) + Z(i-1)         &  !enforce BC
             !                   - h_old(i  ) - Z(i  ) )       &  !enforce BC
               ( + Ce / DX(i) * (  h_old(i+1) + z(i+1)         &
                                - h_old(i  ) - Z(i  ) )        &
                + rain  )                                      &
                ! part from n+1 level
                + dt / 2. * PF1 *                              &
            !   (   Cw1 / DX(i) * ( Z(i-1) - Z(i) )            &   !enforce BC
                ( + Ce1 / DX(i) * ( Z(i+1) - Z(i) )            &
                 + rain   )

elseif( eta_1_BC .EQ. 'MOC_KIN') then
        ! METHOD OF CHARCTERISTICS KINEMATIC BOUNDAARY
        ! cross slope is defined positive for use in SQRT
        cross_slope = ( Z(i+1) - Z(i) ) / ( X(i+1) - X(i) )
        ! If it comes out negative, a different BC is needed
        if( cross_slope .LT. 0.0) then
            write(*,*) 'PFC1DIMP: Different BC needed at eta = 1'
        endif
        if( h_old(i) .LE. b_pfc) then
                ! PFC FLOW MOC BC
                dx_moc =  K * (cross_slope) * dt / por
                !Interpolate up the drainage slope...make sure we have enough points
                nip = NINT(dx_moc / DX(1) ) + 2
!                write(110,*) 'eta_1_bc X=', (xcv(1) + dx_moc), &
!                                    'nip=', nip,               &
!                                     'KX=',   XCV(1:nip),      &
!                                     'KY=', h_old(1:nip)
                hp1 = F_Linterp(       X = (xcv(1) + dx_moc), &
                                 Known_X = XCV( 1:nip)      , &
                                 Known_Y = h_old(1:nip)     , &
                                       n = nip                  )
                if( hp1 .LT. 0.0) then
                        write(100,*) 'PFC1DIMP: eta_1_bc hp1=', hp1
                        stop
                endif
                hp2 = hp1 + rain * dt / por
                if( rain .LT. TINY ( rain )) then
                    ! Rainfall rate is effectively zero
                    hp2 = hp2
                else
                    ! Rainfall is non-zero, set a maximum value for hp2
                    ! the total drainage distance is the sum from the highest point in
                    ! the 1D domain to the end, this is why MAXLOC is used.
                    hp2 = min( hp2, sum( DX( i : i_Zmax(1) ))*rain/K/cross_slope)
                endif
                ! Fill in linear system
                main(i) = 1.
                RHS (i) = hp2
! write(100,*) 'PFC1DIMP: eta_BC = MOC_KIN i=',i, 'dx_moc=', dx_moc, 'hp1=', hp1, 'hp2=', hp2
         else
                !SHEET FLOW MOC BC
                hs2 = h_old(i) - b_pfc
                ! Handle zero rainfall
                if( rain .LT. TINY( rain ) ) then
                    ! no increase in flow rate along drainge path
                    ! ds is arbitray, so use the PFC value
                    ds =  K * (cross_slope) * dt / por
                else
                    ds = sqrt( cross_slope ) / n_mann / rain *    &
                         ( ( hs2 + rain * dt )**(5./3.) - hs2**(5./3.) )
                endif
                ! Interpolate up the slope to find hs1
                nip = NINT(ds / DX(1) ) + 2
!                write(110,*) 'eta_1_bc X=',(xcv(1) + ds), 'nip=', nip, 'KX=',   XCV(1:nip), 'KY=', h_old(1:nip)
                hs1 = F_Linterp(       X = (xcv(1) + ds),   &
                                 Known_X = XCV( 1:nip)  , &    !(/ 0.      ,     DX(i)  /) ,&
                                 Known_Y =  h_old(1:nip), &                            !(/ h_old(i), h_old(i+1) /), &
                                       n = nip ) - b_pfc
                ! Handle return to sheet flow
                if( hs1 .GT. 0.0 ) then
                    ! we have sheet flow
                    main(i) = 1.
                    RHS (i) =  b_pfc + ( hs1**(5./3.) + ( hs2 + rain*dt )**(5./3.) - hs2**(5./3.) )**0.6
                else
                    ! upstream point has sheet flow
                    ! use the PFC characteristic
                    main(i) = 1.
                    RHS (i) = hs1 + b_pfc + rain * dt / por
                end if
           end if
endif BC1

!Interior of domain
do i = 2, imax - 1
    PF  = F_por( h_old(i) )
    PF1 = F_por( h_itr(i) )
!        FUNCTION F_CC(    xin,  dxin,  hin, zin, &
!                         xout, dxout, hout, zout )
    !these coefficients are stationary (time level n)
    Cw  = F_CC( X(i  ), DX(i  ), h_old(i  ), Z(i),     &
                X(i-1), DX(i-1), h_old(i-1), Z(i-1) )
    Ce  = F_CC( X(i  ), DX(i  ), h_old(i  ), Z(i),     &
                X(i+1), DX(i+1), h_old(i+1), Z(i+1) )
    !these coefficints are updated as the iteration progresses
    Cw1 = F_CC( X(i  ), DX(i  ), h_itr(i  ), Z(i),     &
                X(i-1), DX(i-1), h_itr(i-1), Z(i-1) )
    Ce1 = F_CC( X(i  ), DX(i  ), h_itr(i  ), Z(i),     &
                X(i+1), DX(i+1), h_itr(i+1), Z(i+1) )

    !Diagonals of coefficient matrix
    main (i) =  1  +  dt / 2 * PF1 * Cw1 / DX(i) &
                   +  dt / 2 * PF1 * Ce1 / DX(i)
    super(i) =      - dt / 2 * PF1 * Ce1 / DX(i)
    sub  (i) =      - dt / 2 * PF1 * Cw1 / DX(i)
    !Right hand side of linearized system
                ! part that came from n level
    RHS  (i) =    h_old(i) + dt / 2.  * PF *                   &
               (  Cw / DX(i) * (  h_old(i-1) + z(i-1)          &
                                - h_old(i  ) - Z(i  ) )        &
                + Ce / DX(i) * (  h_old(i+1) + z(i+1)          &
                                - h_old(i  ) - Z(i  ) )        &
                + rain  )                                      &
                ! part from n+1 level
                + dt / 2. * PF1 *                              &
               (   Cw1 / DX(i) * ( z(i-1) - z(i) )             &
                 + Ce1 / DX(i) * ( z(i+1) - Z(i) )             &
                 + rain   )
 end do

! DOWNSTREAM BOUNDARY
i = imax
! use BC from input argument
BC0:if( eta_0_BC .EQ. 'NO_FLOW') then
    !NO FLOW BOUNDARY ---> Ce == 0
    !these coefficients are stationary (time level n)
    Cw  = F_CC( X(i  ), DX(i  ), h_old(i  ), Z(i),     &
                X(i-1), DX(i-1), h_old(i-1), Z(i-1) )
    Ce  = 0.0
    !these coefficints are updated as the iteration progresses
    Cw1 = F_CC( X(i  ), DX(i  ), h_itr(i  ), Z(i),     &
                X(i-1), DX(i-1), h_itr(i-1), Z(i-1) )
    Ce1 = 0.0
    !Diagonals of coefficient matrix
    main (i) =  1  +  dt / 2 * PF1 * Cw1 / DX(i) &
                   +  dt / 2 * PF1 * Ce1 / DX(i)
    super(i) =      - dt / 2 * PF1 * Ce1 / DX(i)
    sub  (i) =      - dt / 2 * PF1 * Cw1 / DX(i)
    !Right hand side of linearized system
                ! part that came from n level
    RHS  (i) =    h_old(i) + dt / 2.  * PF *                   &
               (  Cw / DX(i) * (  h_old(i-1) + z(i-1)          &
                                - h_old(i  ) - Z(i  ) )        &
             !   + Ce / DX(i) * (  h_old(i+1) + z(i+1)          &    !enforce BC
            !                    - h_old(i  ) - Z(i  ) )        &    !enforce BC
                + rain  )                                      &
                ! part from n+1 level
                + dt / 2. * PF1 *                               &
               (   Cw1 / DX(i) * ( z(i-1) - z(i) )             &
            !     + Ce1 / DX(i) * ( z(i+1) - Z(i) )             &    !enforce BC
                 + rain   )
  elseif( eta_0_BC .EQ. 'MOC_KIN') then
        ! METHOD OF CHARCTERISTICS KINEMATIC BOUNDAARY
        cross_slope = ( Z(i-1) - Z(i) ) / ( X(i) - X(i-1) )    ! cross slope is positive downwars for use in SQRT
        if( cross_slope .LT. 0.0) then
            write(*,*) 'PFC1DIMP: Different BC needed at eta = 0'
        endif
        if( h_old(i) .LE. b_pfc) then
                ! PFC FLOW MOC BC
                dx_moc =  K * (cross_slope) * dt / por       !NEED MAGNITUDE OF SLOPE AT CENTER OF EACH CELL
                nip = NINT(dx_moc / DX(imax) ) + 2
!                write(110,*) 'eta_0_BC X=', (XCV(imax) - dx_moc)  ,  &
!                                    'nip=', nip,                     &
!                                     'KX=', XCV( imax-nip+1:imax) ,  &
!                                     'KY=', h_old( imax-nip+1 : imax)

                hp1 = F_Linterp(       X = (XCV(imax) - dx_moc)   ,  &
                                 Known_X = (XCV( imax-nip+1:imax)),  &
                                 Known_Y = h_old( imax-nip+1 : imax) , &
                                       n = nip )
                if( hp1 .LT. 0.0) then
                        write(100,*) 'PFC1DIMP: eta_0_bc hp1=', hp1
                        stop
                endif
                hp2 = hp1 + rain * dt / por
                if( rain .LT. TINY ( rain )) then
                    ! Rainfall rate is effectively zero
                    hp2 = hp2
                else
                    ! Rainfall is non-zero, set a maximum value for hp2
                    ! the total drainage distance is the sum from the highest point in
                    ! the 1D domain to the end, this is why MAXLOC is used.
                    eta_0_hp2_max = sum( DX( i_Zmax(1) : i ))*rain/K/cross_slope
                    hp2 = min( hp2, eta_0_hp2_max)
                endif
                ! Fill in linear system
                main(i) = 1.
                RHS (i) = hp2
         else
                !SHEET FLOW MOC BC
                hs2 = h_old(i) - b_pfc
                ! Handle zero rainfall
                if( rain .LT. TINY( rain ) ) then
                    ! no increase in flow rate along drainge path
                    ! ds is arbitray, so use the PFC value
                    ds =  K * (cross_slope) * dt / por
                else
                    ds = sqrt( cross_slope ) / n_mann / rain *    &
                         ( ( hs2 + rain * dt )**(5./3.) - hs2**(5./3.) )
                endif
                ! Interpolate up the slope to find hs1
                nip = NINT(ds / DX(imax) ) + 2
!                write(110,*) 'eta_0_BC X=', (XCV(imax) - ds)         , &
!                                    'nip=', nip                      , &
!                                     'KX=', XCV( imax-nip+1:imax)    , &
!                                     'KY=', h_old( imax-nip+1 : imax)

                hs1 = F_Linterp(       X = (XCV(imax) - ds)          , &
                                 Known_X = (XCV( imax-nip+1:imax))   , &
                                 Known_Y = h_old( imax-nip+1 : imax) , &
                                       n = nip ) - b_pfc
                ! Handle return to sheet flow
                if( hs1 .GT. 0.0 ) then
                    ! we have sheet floe
                    main(i) = 1.
                    RHS (i) =  b_pfc + ( hs1**(5./3.) + ( hs2 + rain*dt )**(5./3.) - hs2**(5./3.) )**0.6
                else
                    ! upstream point has sheet flow
                    ! use the PFC characteristic
                    main(i) = 1.
                    RHS (i) = hs1 + b_pfc + rain * dt / por
                end if
           end if
  end if BC0

! TRANSITION CHECK
!   test to see if there is a transition to or from sheet flow
!   happening during this timestep.   Use under-relaxtion to
!   control oscillations during a transition timestep.

transition = .false.
do i = 1, imax
    pf = F_por( h_old(i) )
    pf1= F_por( h_itr(i) )
    if( (pf .GT. pf1) .OR. (pf .LT. pf1) ) then
        transition = .true.
!        write(110,*) 'PERFCODE: transition for cell i=', i, 'pf=', pf, 'pf1=', pf1
    endif
end do

if( transition .eqv. .true. ) then
    relaxation_factor = relax_tran
    eps_itr_tol = tolit * 10.
else
    relaxation_factor = relax
    eps_itr_tol = tolit
endif

        !Solve linear system
        CALL THOMAS(main, super, sub, RHS, h_temp, imax)

! Compute residual and relative change for this iteration
call MIXED_RESIDUAL( old     = h_itr       , &
                     new     = h_temp      , &
                     vmax    = imax        , &
                     res     = residual    , &
                     mixres  = relchg     , &
                     abs_tol = h_pfc_min   , &
                     rel_tol = eps_itr_tol         )

if( maxval( h_temp) .LT. TINY( h_temp(1) )  ) then
       write(*,*) 'PFC1DIMP: Zeroed out.  Writing system and stopping program'
       open( unit = 10, file = '1Dsystem.csv', status = 'REPLACE' )
       write(10,*) 'i,sub,main,super,rhs,h_temp,'
       do i = 1, imax
             write(10, 10) i, sub(i), main(i), super(i), RHS(i), h_temp(i)
       end do
       close( 10 )

       call write_vector( h_old, imax, 'h_old_1d.csv')
       STOP
10  FORMAT (  (I12, ','), 5(E12.7, ',') )

end if

!perform usual iteration check
IF (  ( maxval ( ABS( relchg ) ) .le. eps_itr_tol ) .AND.  &
      (F_L2_NORM( relchg, imax )   .le. eps_itr_tol )      ) then
        !  WRITE(*,*) 'Time step n = ', n,' converged in q = ', q, ' iterations.'
          EXIT
      end if

! Smith page 32

h_itr = h_itr + relaxation_factor * residual

!Store the result of this iteration
h_temp_hist( : , q ) = h_temp
h_itr_hist ( : , q ) = h_itr

! WRITE(110,*) 'ITERATION q=', q                     , &
!             'Max Change of', maxval( abs( relchg) ), &
!                     'at i=', maxloc( abs( relchg)) , &
!                'h_temp(i)=', h_temp( maxloc( abs( relchg)) ) , &
!                  'L2_Norm=', F_L2_NORM( relchg, imax)

!end iteration loop
end do

!update the old and new solutions
!At the end of the iteration, we have found values for the
!next time step.

h_new  = h_temp

!Store summary info for this timestep
numit   = q
loc     = maxloc ( abs( relchg ), dim=1 )
maxdiff = relchg ( loc  )

!Give Error if Iteration fails to converge
if (q .gt. qmax) then
  WRITE(*,*)   'PFC1DIMP: Iteration failed to converge. '
  write(100,*)  'PFC1DIMP: Iteration failed to converge. '
  CALL WRITE_MATRIX( h_temp_hist, imax, qmax, 'h_temp_hist_1D.csv')
  CALL WRITE_MATRIX( h_itr_hist , imax, qmax, 'h_itr_hist_1D.csv')

!          EXIT
end if

!close(50)   ! pf summary file
!close(110)  ! Run details file
!-----------------------------------------------------------------------------------
! P O S T   P R O C E S S I N G

!Compute head
head(:) = h_new(:) + Z(:)

!------------------------------------------------------
! HYDRAULIC GRADIENT AND FLUX through the whole domain
!------------------------------------------------------

!ETA = 1 BOUNDARY (1-sided approximation)
i = 1
hygrad(i) =  ( head(i) - head(i+1) )  /  ( X(i+1) - X(i) )
!In the pavement
hp = min( h_new(i), b )
q_pav (i) = K * hp * hygrad(i)
!on the surface
hs = max( 0., h_new(i) - b )
q_surf(i) = 1. / n_mann * hs ** (2./3.) * sqrt( abs( hygrad(i) ) ) * hs
q_tot(i) = q_pav(i) + q_surf(i)

!DOMAIN INTERIOR
do i = 2, imax - 1
    !hydrualic gradient
    hygrad(i) =  ( head(i-1) - head(i+1) )  /  ( X(i+1) - X(i-1) )
    !thickness in the pavement
    hp = min( h_new(i), b )
    q_pav (i) = K * hp * hygrad(i)
    !thickness on the surface
    hs = max( 0., h_new(i) - b )
    q_surf(i) = 1. / n_mann * hs**(2./3.) * sqrt( abs( hygrad(i) ) ) * hs
!             WRITE(*,*) 'i = ', i, 'hs = ', hs, 'q_surf =', q_surf(i)
    q_tot(i) = q_pav(i) + q_surf(i)
end do

! ETA = 0 ( 1 sided approximation)
i = imax
!hydrualic gradient
hygrad(i) =  ( head(i-1) - head(i) )  /  ( X(i) - X(i-1) )
!in the pavement
hp = min( h_new(i), b )
q_pav (i) = K * hp * hygrad(i)
!on the surface
hs = max( 0., h_new(i) - b )
q_surf(i) = 1. / n_mann * hs ** (2./3.) * sqrt( abs( hygrad(i) ) ) * hs
q_tot(i) = q_pav(i) + q_surf(i)

Qout = - q_tot( imax )  !make the flow out of the domain negative for consistency w/ 2D model
!-------------------------------------------------------------
! Locate transition to sheet flow
!-------------------------------------------------------------

if( maxval( h_new ) .LT. b_pfc ) then
    ! flow is everywhere in the pavement
    X_sheet = XCV(imax) + EDX(imax)/2.
else
    ! its out of the pavement somewhere so lets find where
    ! search from the left/upstream/eta=1 end of the domain and
    ! stop at the first transition
    findsheet: do i = 1, imax
    if( h_new( i ) .GE. b_pfc ) then
        X_sheet = X( i )
        exit findsheet
    end if

end do findsheet

endif

!-----------------------------------------------------------------------------------
!Format statements

100     FORMAT (100 ( F14.7, ',' ) )        !  Formatting for the actual output
200     FORMAT ( A, F10.4 )
300     FORMAT ( 2 (I12, ','), E12.7, ',', I12, ',' )

!-----------------------------------------------------------------------------------
        END subroutine pfc1Dimp
!===================================================================================
!       \\\\\\\\\\      E N D      S U B R O U T I N E  //////////
!       //////////          P F C 1 D I M P             \\\\\\\\\\
!===================================================================================

END MODULE pfc1Dsubs


      subroutine dt3q_d(d1,q2,t4,dedt3q)

      implicit double precision(a-h,o-z)

      dimension d1(3),q2(3,3),t4(3,3,3,3),dedt3q(3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(3,10),b(10)

      a(1,1)=t4(1,1,1,1)
      a(1,2)=t4(1,1,1,2)
      a(1,3)=t4(1,1,1,3)
      a(1,4)=t4(1,1,2,2)
      a(1,5)=t4(1,1,2,3)
      a(1,6)=t4(1,1,3,3)
      a(1,7)=t4(1,2,2,2)
      a(1,8)=t4(1,2,2,3)
      a(1,9)=t4(1,2,3,3)
      a(1,10)=t4(1,3,3,3)

      a(2,1)=t4(1,1,1,2)
      a(2,2)=t4(1,1,2,2)
      a(2,3)=t4(1,1,2,3)
      a(2,4)=t4(1,2,2,2)
      a(2,5)=t4(1,2,2,3)
      a(2,6)=t4(1,2,3,3)
      a(2,7)=t4(2,2,2,2)
      a(2,8)=t4(2,2,2,3)
      a(2,9)=t4(2,2,3,3)
      a(2,10)=t4(2,3,3,3)

      a(3,1)=t4(1,1,1,3)
      a(3,2)=t4(1,1,2,3)
      a(3,3)=t4(1,1,3,3)
      a(3,4)=t4(1,2,2,3)
      a(3,5)=t4(1,2,3,3)
      a(3,6)=t4(1,3,3,3)
      a(3,7)=t4(2,2,2,3)
      a(3,8)=t4(2,2,3,3)
      a(3,9)=t4(2,3,3,3)
      a(3,10)=t4(3,3,3,3)

      b(1)=d1(1)*q2(1,1)
      b(2)=2.d0*d1(1)*q2(1,2)+d1(2)*q2(1,1)
      b(3)=2.d0*d1(1)*q2(1,3)+d1(3)*q2(1,1)
      b(4)=2.d0*d1(2)*q2(1,2)+d1(1)*q2(2,2)
      b(5)=2.d0*(d1(1)*q2(2,3)+d1(2)*q2(1,3)+d1(3)*q2(1,2))
      b(6)=2.d0*d1(3)*q2(1,3)+d1(1)*q2(3,3)
      b(7)=d1(2)*q2(2,2)
      b(8)=2.d0*d1(2)*q2(2,3)+d1(3)*q2(2,2)
      b(9)=2.d0*d1(3)*q2(2,3)+d1(2)*q2(3,3)
      b(10)=d1(3)*q2(3,3)

      dedt3q(1)=a(1,1)*b(1)+a(1,2)*b(2)+a(1,3)*b(3)+a(1,4)*b(4)+
     .      a(1,5)*b(5)+a(1,6)*b(6)+a(1,7)*b(7)+a(1,8)*b(8)+a(1,9)*b(9)+
     .      a(1,10)*b(10)

      dedt3q(2)=a(2,1)*b(1)+a(2,2)*b(2)+a(2,3)*b(3)+a(2,4)*b(4)+
     .      a(2,5)*b(5)+a(2,6)*b(6)+a(2,7)*b(7)+a(2,8)*b(8)+a(2,9)*b(9)+
     .      a(2,10)*b(10)

      dedt3q(3)=a(3,1)*b(1)+a(3,2)*b(2)+a(3,3)*b(3)+a(3,4)*b(4)+
     .      a(3,5)*b(5)+a(3,6)*b(6)+a(3,7)*b(7)+a(3,8)*b(8)+a(3,9)*b(9)+
     .      a(3,10)*b(10)

      return
      end


! qinit routine for parabolic bowl problem, only single layer
SUBROUTINE teton_qinit(meqn,mbc,mx,my,xlower,ylower,dx,dy,q,maux,aux)

    use geoclaw_module, only: grav
    use reservoir_module

    implicit none

    ! Subroutine arguments
    integer, intent(in) :: meqn,mbc,mx,my,maux
    real(kind=8), intent(in) :: xlower,ylower,dx,dy
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    real(kind=8), intent(inout) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Parameters for problem
    REAL(kind=8), PARAMETER :: a = 1.d0
    REAL(kind=8), PARAMETER :: sigma = 0.5d0

    !! Original code`
    !! REAL(kind=8), PARAMETER :: xll = -112.3895d0
    !! REAL(kind=8), PARAMETER :: x0 = -111.5391666666667d0  !! x-coords of Teton Dam
    !! REAL(kind=8), PARAMETER :: x1 = -111.24d0  !! Left edge of domain
    !! REAL(kind=8), PARAMETER :: h0 = 1540.d0
    !! REAL(kind=8), PARAMETER :: h1 = 1720.d0

    !! 9/4/2017 : Using larger domain
    REAL(kind=8), PARAMETER :: xll = -112.34626736d0
    REAL(kind=8), PARAMETER :: x0 = -111.5391666666667d0  !! x-coords of Teton Dam
    REAL(kind=8), PARAMETER :: x1 = -111.24d0  !! Left edge of domain
    REAL(kind=8), PARAMETER :: h0 = 1560.d0
    REAL(kind=8), PARAMETER :: h1 = 1720.d0

    ! Other storage
    INTEGER :: i,j
    REAL(kind=8) :: omega,x,y,eta

    !! Capacity of reservoir at time of release : 251000 acre-feet
    !! 1 acre-foot = 1233.4829 m^3
    !! Conversion of deg2m2 = 8948239546.22

    !! Actual mass : 251000*1233.4829 = 309,604,207 (m^3)

    !! Total mass as reported by GeoClaw (using h0=1615, h1=1700)
    !!        is  27,298,685 (m^3)  (assuming mass reported by GeoClaw is in m^3)
    !! Total mass as reported by GeoClaw (using h0=1625.d0, h1 = 1700)
    !!        is 62,069,921  (m^3)
    !! 9/4/2017 (using deg2m2 conversion)
    !! Total mass as reported by GeoClaw (using h0=1540, h1 = 1720, maxlevel=6)
    !!      is mass = 263,167,751.82 m^3
    !! Total mass as reported by GeoClaw (using h0=1540, h1 = 1720, maxlevel=7)
    !!      is mass = 274,799,319.07 m^3

    CALL set_reservoir_path()

    DO i=1-mbc,mx+mbc
        x = xlower + (i - 0.5d0)*dx
        do j=1-mbc,my+mbc
           y = ylower + (j - 0.5d0) * dx
           q(1,i,j) = 0
           IF (x .GT. x0) THEN
              IF (point_in_poly(x,y)) THEN
                 eta = h0 + (h1-h0)/(x1-x0)*(x - x0)
                 q(1,i,j) =  MAX(0.d0,eta - aux(1,i,j))
              ENDIF
           ENDIF
           q(2,i,j) = 0.d0
           q(3,i,j) = 0.d0
        enddo
     ENDDO

   END SUBROUTINE teton_qinit


      real function bvalue ( t, bcoef, n, k, x, jderiv )
c  from  * a practical guide to splines *  by c. de boor
calls  interv
c
calculates value at  x	of  jderiv-th derivative of spline from b-repr.
c  the spline is taken to be continuous from the right.
c
c******  i n p u t ******
c  t, bcoef, n, k......forms the b-representation of the spline  f  to
c	 be evaluated. specifically,
c  t.....knot sequence, of length  n+k, assumed nondecreasing.
c  bcoef.....b-coefficient sequence, of length	n .
c  n.....length of  bcoef  and dimension of spline(k,t),
c	 a s s u m e d	positive .
c  k.....order of the spline .
c
c  w a r n i n g . . .	 the restriction  k .le. kmax (=20)  is imposed
c	 arbitrarily by the dimension statement for  aj, dl, dr  below,
c	 but is  n o w h e r e	c h e c k e d  for.
c
c  x.....the point at which to evaluate .
c  jderiv.....integer giving the order of the derivative to be evaluated
c	 a s s u m e d	to be zero or positive.
c
c******  o u t p u t  ******
c  bvalue.....the value of the (jderiv)-th derivative of  f  at  x .
c
c******  m e t h o d  ******
c     the nontrivial knot interval  (t(i),t(i+1))  containing  x  is lo-
c  cated with the aid of  interv . the	k  b-coeffs of	f  relevant for
c  this interval are then obtained from  bcoef (or taken to be zero if
c  not explicitly available) and are then differenced  jderiv  times to
c  obtain the b-coeffs of  (d**jderiv)f  relevant for that interval.
c  precisely, with  j = jderiv, we have from x.(12) of the text that
c
c     (d**j)f  =  sum ( bcoef(.,j)*b(.,k-j,t) )
c
c  where
c		    / bcoef(.), 		    ,  j .eq. 0
c		    /
c    bcoef(.,j)  =  / bcoef(.,j-1) - bcoef(.-1,j-1)
c		    / ----------------------------- ,  j .gt. 0
c		    /	 (t(.+k-j) - t(.))/(k-j)
c
c     then, we use repeatedly the fact that
c
c    sum ( a(.)*b(.,m,t)(x) )  =  sum ( a(.,x)*b(.,m-1,t)(x) )
c  with
c		  (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1)
c    a(.,x)  =	  ---------------------------------------
c		  (x - t(.))	  + (t(.+m-1) - x)
c
c  to write  (d**j)f(x)  eventually as a linear combination of b-splines
c  of order  1 , and the coefficient for  b(i,1,t)(x)  must then be the
c  desired number  (d**j)f(x). (see x.(17)-(19) of text).
c
c     parameter kmax = 20
      integer jderiv,k,n,   i,ilo,imk,j,jc,jcmin,jcmax,jj,kmj,km1,mflag
     *			   ,nmi,jdrvp1
      real bcoef(n),t(1),x,   aj(20),dl(20),dr(20),fkmj
c     real bcoef(n),t(1),x,   aj(kmax),dl(kmax),dr(kmax),fkmj
c     dimension t(n+k)
current fortran standard makes it impossible to specify the length of  t
c  precisely without the introduction of otherwise superfluous addition-
c  al arguments.
      bvalue = 0.
      if (jderiv .ge. k)		go to 99
c
c  *** find  i	 s.t.	1 .le. i .lt. n+k   and   t(i) .lt. t(i+1)   and
c      t(i) .le. x .lt. t(i+1) . if no such i can be found,  x	lies
c      outside the support of  the spline  f  and  bvalue = 0.
c      (the asymmetry in this choice of  i  makes  f  rightcontinuous)
      call interv ( t, n+k, x, i, mflag )
      if (mflag .ne. 0) 		go to 99
c  *** if k = 1 (and jderiv = 0), bvalue = bcoef(i).
      km1 = k - 1
      if (km1 .gt. 0)			go to 1
      bvalue = bcoef(i)
					go to 99
c
c  *** store the k b-spline coefficients relevant for the knot interval
c     (t(i),t(i+1)) in aj(1),...,aj(k) and compute dl(j) = x - t(i+1-j),
c     dr(j) = t(i+j) - x, j=1,...,k-1 . set any of the aj not obtainable
c     from input to zero. set any t.s not obtainable equal to t(1) or
c     to t(n+k) appropriately.
    1 jcmin = 1
      imk = i - k
      if (imk .ge. 0)			go to 8
      jcmin = 1 - imk
      do 5 j=1,i
    5	 dl(j) = x - t(i+1-j)
      do 6 j=i,km1
	 aj(k-j) = 0.
    6	 dl(j) = dl(i)
					go to 10
    8 do 9 j=1,km1
    9	 dl(j) = x - t(i+1-j)
c
   10 jcmax = k
      nmi = n - i
      if (nmi .ge. 0)			go to 18
      jcmax = k + nmi
      do 15 j=1,jcmax
   15	 dr(j) = t(i+j) - x
      do 16 j=jcmax,km1
	 aj(j+1) = 0.
   16	 dr(j) = dr(jcmax)
					go to 20
   18 do 19 j=1,km1
   19	 dr(j) = t(i+j) - x
c
   20 do 21 jc=jcmin,jcmax
   21	 aj(jc) = bcoef(imk + jc)
c
c		*** difference the coefficients  jderiv  times.
      if (jderiv .eq. 0)		go to 30
      do 23 j=1,jderiv
	 kmj = k-j
	 fkmj = float(kmj)
	 ilo = kmj
	 do 23 jj=1,kmj
	    aj(jj) = ((aj(jj+1) - aj(jj))/(dl(ilo) + dr(jj)))*fkmj
   23	    ilo = ilo - 1
c
c  *** compute value at  x  in (t(i),t(i+1)) of jderiv-th derivative,
c     given its relevant b-spline coeffs in aj(1),...,aj(k-jderiv).
   30 if (jderiv .eq. km1)		go to 39
      jdrvp1 = jderiv + 1
      do 33 j=jdrvp1,km1
	 kmj = k-j
	 ilo = kmj
	 do 33 jj=1,kmj
	    aj(jj) = (aj(jj+1)*dl(ilo) + aj(jj)*dr(jj))/(dl(ilo)+dr(jj))
   33	    ilo = ilo - 1
   39 bvalue = aj(1)
c
   99					return
      end


!   gfortran -cpp -O3 -flto ex_3.f90 -o ex_3
!   ./ex_3

!   "Convergence" testing: remap a smooth (Gaussian) profile
!   between perturbed grids and compute error in the L2-nrm.
!   Re-run with N = 50, 100, 200, ... etc (and N-tmp at 80%)
!   to assess the order of spatial accuracy. With NUll/WENO-
!   LIMIT, all methods should achieve their best-case O(h^p)
!   scaling.
!

#   include "../src/ppr_1d.f90"

    program ex

        use ppr_1d

        implicit none

        integer, parameter :: npos = 50 ! no. edge (old grid)
        integer, parameter :: ntmp = 40 ! no. edge (new grid)
        integer, parameter :: nvar = 1  ! no. variables to remap
        integer, parameter :: ndof = 1  ! no. FV DoF per cell
        integer :: ipos

    !------------------------------ position of cell edges !
        real*8  :: xpos(npos),xtmp(ntmp)
        real*8  :: xdel,xmid

    !-------------------------------- finite-volume arrays !

    !   Arrays represent a "block" of finite-volume tracers
    !   to remap. The 1st dim. is the no. of DoF per cell,
    !   NDOF=1 is a standard finite-volume scheme where the
    !   data is specified as cell means. NDOF>1 is reserved
    !   for future use with DG-style schemes. NVAR is the
    !   number of tracers to remap. Processing tracers in a
    !   batch is typically more efficient than one-by-one.
    !   The last dim. is the no. cells (layers) in the grid.

        real*8  :: init(ndof,nvar,npos-1)
        real*8  :: ftmp(ndof,nvar,ntmp-1)
        real*8  :: fdat(ndof,nvar,npos-1)

    !------------------------------ method data-structures !
        type(rmap_work) :: work
        type(rmap_opts) :: opts
        type(rcon_ends) :: bc_l(nvar)
        type(rcon_ends) :: bc_r(nvar)

    !------------------------------ define a simple domain !

        call linspace(0.d0,1.d0,npos,xpos)
        call linspace(0.d0,1.d0,ntmp,xtmp)

    !------------------------------ setup some simple data !

        do ipos = +1, npos-1

            xmid = xpos(ipos+0) * 0.5d+0 &
    &            + xpos(ipos+1) * 0.5d+0

            init(1,1,ipos) = &
    &   .8d+0 * exp( -75.0d+0 * (xmid - 0.275d+0) ** 2 ) &
    & + .9d+0 * exp(-100.0d+0 * (xmid - 0.500d+0) ** 2 ) &
    & + 1.d+0 * exp(-125.0d+0 * (xmid - 0.725d+0) ** 2 )

        end do

    !------------------------------ specify method options !

        opts%edge_meth = p5e_method     ! 3rd-order edge interp.
        opts%cell_meth = pqm_method     ! PPM method in cells
        opts%cell_lims = null_limit     ! monotone limiter

    !------------------------------ set BC.'s at endpoints !

        bc_l%bcopt = bcon_loose         ! "loose" = extrapolate
        bc_r%bcopt = bcon_loose

    !------------------------------ init. method workspace !

        call work%init(npos,nvar,opts)

    !------------------------------ re-map back-and-forth: !

        fdat = init

        do ipos = +1, +1000

    !------------------------------ re-map from dat-to-tmp !

        call rmap1d(npos,ntmp,nvar,ndof, &
        &           xpos,xtmp,fdat,ftmp, &
        &           bc_l,bc_r,work,opts)

    !------------------------------ re-map from tmp-to-dat !

        call rmap1d(ntmp,npos,nvar,ndof, &
        &           xtmp,xpos,ftmp,fdat, &
        &           bc_l,bc_r,work,opts)

        end do

    !------------------------------ clear method workspace !

        call work%free()

    !------------------------------ dump results to stdout !

        print*,"Cell data: [INIT] [RMAP] "

        do ipos = +1, npos-1

            print *, init(1,1,ipos) &
        &          , fdat(1,1,ipos)

        end do

        print*,"Conservation defect := " &
        &     , sum(init) - sum(fdat)

    !------------------------------ calc. errors in L2 nrm !

        xdel = (xpos(npos)-xpos(1))/(npos-1)

        print*,"Discrete (L2) Error := ",&
        sqrt(sum(xdel * (init(1,1,:) - fdat(1,1,:)) ** 2))

    end program


      program DRSSI
c>> 1994-10-19 DRSSI   Krogh  Changes to use M77CON
c>> 1991-11-19  DRSSI   CLL
c>> 1989-04-26  DRSSI   Snyder at JPL, Original Code
c--S replaces "?":  DR?SI, ?CI, ?CIN, ?SI
c
c     Demonstration driver for Sine and Cosine integrals.
c
      real             SCI, SCIN, SSI, X
      integer I
      external SCI, SCIN, SSI
c
c     Print values of Si(x), Ci(x) and Cin(x)
c     for X = 1.0 (1.0) 15.0
c
      print '(''  X'',11x,''Si(x)'',11x,''Ci(x)'',11x,''Cin(x)''/)'
      do 10 i = 1, 15
         x = real(i)
         print '(f4.0,3f16.7)', x, ssi(x), sci(x), scin(x)
   10 continue
      stop
      end


program test_simsphere
  use, intrinsic :: ieee_arithmetic
  use simsphere_mod
  use mod_testing, only: assert,initialize_tests,report_tests
  implicit none

  ! mod_testing test setup

  logical, dimension(:), allocatable :: tests
  logical :: test_failed
  integer :: n, ntests

  ! end mod_testing test setup

  integer :: i

  logical, parameter :: splint_test = .true.
  logical, parameter :: spline_test = .true.
  logical, parameter :: transm_ftabs_test = .true.
  logical, parameter :: transm_ftabs_test2 = .true.
  logical, parameter :: transm_ftscatT_test = .true.
  logical, parameter :: transm_ftscatT_test2 = .true.
  logical, parameter :: transm_fbscatT_test = .true.
  logical, parameter :: transm_fbscatT_test2 = .true.
  logical, parameter :: advect_func_test = .true.
!  logical :: air_test
  logical, parameter :: cond_test = .true.
  logical, parameter :: stomfs_test = .true.
  logical, parameter :: stomrs_test_hi_temp = .true.
  logical, parameter :: stomrs_test_lo_temp = .true.
  logical, parameter :: stomrs_test_hi_psi = .true.
  logical, parameter :: stomrs_test_lo_psi = .true.
  logical, parameter :: stomc_test = .true.
  logical, parameter :: you_star_test = .true.
  logical, parameter :: r_ohms_test = .true.
  logical, parameter :: windf_test = .true.
  logical, parameter :: stab_test = .true.
  logical, parameter :: stabh_test = .true.
  logical, parameter :: fstabh_test = .true.
  logical, parameter :: fstabm_test = .true.
  logical, parameter :: restrn_test = .true.
  logical, parameter :: psgcal_test = .true.
  logical, parameter :: vegflx_test = .true.
  logical, parameter :: avr_test_init1 = .true.
!  logical, parameter :: avr_test_init_not1 = .true.
  logical, parameter :: ozone_test = .true.
  logical, parameter :: co2flx_test = .true.
  logical, parameter :: veghot_test = .true.
  logical, parameter :: hot_test = .true.
  logical, parameter :: albedo_test = .true.
  logical, parameter :: intpol_test = .true.
  logical, parameter :: prfile_test = .true.
  logical, parameter :: f_control_test = .false.

! Tolerance for comparisons
  real, parameter :: eq_tol = 1e-6

! splint_test variables
  integer, parameter :: splint_max_array = 50
  real, parameter :: splint_expected = 1.5
  real :: splint_arg1(splint_max_array), splint_arg2(splint_max_array)
  real(kind=4), allocatable :: splint_arg3(:)
  integer :: splint_arg4, splint_arg5
  real :: splint_output

! spline_test variables
  integer, parameter :: spline_max_array = 50
  integer :: spline_arg3
  real, parameter :: spline_expected(62) =                            &
    (/-8.84081032E-07,1.76816206E-06,-6.18856711E-06,2.29861053E-05,  &
      -8.57558480E-05,3.20037303E-04,-1.19439338E-03,4.45753615E-03,  &
      -1.66357514E-02,6.20854683E-02,-6.20854646E-02,1.66357514E-02,  &
      -4.45753615E-03,1.19439315E-03,-3.20036663E-04,8.57535633E-05,  &
      -2.29775978E-05,6.15682848E-06,-1.64971721E-06,4.42040374E-07,  &
      -1.18444362E-07,3.17370699E-08,-8.50392201E-09,2.27861907E-09,  &
      -6.10554107E-10,1.63597469E-10,-4.38358100E-11,1.17457693E-11,  &
      -3.14726977E-12,8.43309526E-13,-2.25968590E-13,6.05648480E-14,  &
      -1.62907932E-14,4.59832376E-15,-2.10250179E-15,3.81168384E-15,  &
      -1.31442336E-14,4.87652521E-14,-1.81916778E-13,6.78901867E-13,  &
      -2.53369049E-12,9.45585971E-12,-3.52897503E-11,1.31703135E-10,  &
      -4.91522767E-10,1.83438786E-09,-6.84602863E-09,2.55497259E-08,  &
      -9.53528740E-08,3.55861772E-07,-1.32809419E-06,4.95651511E-06,  &
      -1.84979654E-05,6.90353481E-05,-2.57643434E-04,9.61538346E-04,  &
      -3.58850998E-03,1.33925015E-02,-4.99814972E-02,0.186533481,     &
      -0.696152449,2.59807634/)
  real :: spline_arg1(spline_max_array), spline_arg2(spline_max_array)
  real :: spline_arg4, spline_arg5
  real, allocatable :: spline_output(:)

! transm_ftabsT variables
  real :: transm_ftabs_arg1
  real, parameter :: transm_ftabs_expected = 0.722923875
  real, parameter :: transm_ftabs_expected2 = 0.437107921

! transm_ftscatT variables
  real :: transm_ftscatT_arg1
  real, parameter :: transm_ftscatT_expected = 0.553545594
  real, parameter :: transm_ftscatT_expected2 = 0.173223004

! transm_fbscatT variables
  real :: transm_fbscatT_arg1
  real, parameter :: transm_fbscatT_expected = 0.307550341
  real, parameter :: transm_fbscatT_expected2 = 0.304252803

! netrad_init_test variables
!  real, parameter :: aepsi_expected = 0.804384410
!  real, parameter :: aepsi_cloud_flag_expected = 1.02347386

! advect_test variables
  real, parameter :: advect_test_expected = 9.41291146E-05

! air_test variables
!  real, parameter :: air_test_expected = 0.0

! cond_test variables
  real, parameter :: cond_test_expected = 1.46884334

! stomfs_test variables
  real, parameter :: stomfs_test_expected = 1.58197677

! stomrs_test_* variables
  real, parameter :: stomrs_test_hi_temp_expected = 5000.0
  real, parameter :: stomrs_test_lo_temp_expected = 5000.0
  real, parameter :: stomrs_test_hi_psi_expected = 3.16395354
  real, parameter :: stomrs_test_lo_psi_expected = 7.90988398

! stomc_test variables
  real, parameter :: stomc_test_expected = 4.74593019

! you_star_test variables
  real, parameter :: you_star_test_expected = 1.73396431E-02
  real :: you_star_arg1, you_star_arg2, you_star_arg3, you_star_arg4, you_star_arg5

! r_ohms_test variables
  real, parameter :: r_ohms_test_expected = 42.6767731
  real :: r_ohms_arg1, r_ohms_arg2, r_ohms_arg3, r_ohms_arg4, r_ohms_arg5

! windf_test variables
  real, parameter :: windf_test_expected = 8.98633766
  real :: windf_arg1, windf_arg2, windf_arg3, windf_arg4, windf_arg5

! stab_test variables
  real, parameter :: stab_test_expected = 0.707106769
  real :: stab_arg1, stab_arg2

! stabh_test variables
  real, parameter :: stabh_test_expected = 0.741619825

! fstabh_test variables
  real, parameter :: fstabh_test_expected = -0.810930133
  real :: fstabh_arg1, fstabh_arg2

! fstabm_test variables
 real, parameter :: fstabm_test_expected = -0.572894096

! restrn_test variables
  real, parameter :: restrn_test_expected = 0.590972006
  real :: restrn_arg1, restrn_arg2, restrn_arg3, restrn_arg4

! psgcal_test variables
  real, parameter :: psgcal_test_expected = -2.14821539E-05

! vegflx_test variables
  real, parameter :: vegflx_test_expected = 0.986029029
  real :: vegflx_arg1

! avr_test_* variables
  real, parameter :: avr_test_init1_expected = 300.5
!  real, parameter :: avr_test_init_not1_expected = 20.0
  real :: avr_arg1, avr_arg2
  integer :: avr_arg3

! co2flx_test variables
  real, parameter :: co2flx_ccan_expected = 1.77409637
  real, parameter :: co2flx_fco2_expected = 3.13184571

! veghot_test variables
  real, parameter :: veghot_heatv_expected = 1.5
  real :: veghot_arg1, veghot_arg2

! hot_test variables
  real, parameter :: hot_caseI_expected = 2.49819231
  real, parameter :: hot_caseII_expected = 1.62364423
  real, parameter :: hot_caseIII_expected = 0.999096155
  real :: hot_arg1, hot_arg2, hot_arg3, hot_arg4

! albedo_test variables
  real, parameter :: albedo_caseI_expected = 0.396643847
  real, parameter :: albedo_caseII_expected = 0.396643847
  real, parameter :: albedo_caseIII_expected = 0.396643847
  real, parameter :: albedo_caseIV_expected = 0.396643847
  real :: albedo_test_arg1

! intpol_test variables
  real, dimension(50), parameter :: intpol_ug_exp =  &
           (/9.18181801,8.36363602,7.54545498,6.72727299,5.90909100, &
             5.09090948,4.27272749,3.45454597,2.63636398,1.81818199, &
             1.00000000,0.181818962,-0.636363029,-1.45454502,-2.27272701, &
             -3.09090805,-3.90909004,-4.72727203,-5.54545403,-6.36363602, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000/)
  real, dimension(50), parameter :: intpol_vg_exp =  &
           (/9.18181801,8.36363602,7.54545498,6.72727299,5.90909100, &
             5.09090948,4.27272749,3.45454597,2.63636398,1.81818199, &
             1.00000000,0.181818962,-0.636363029,-1.45454502,-2.27272701, &
             -3.09090805,-3.90909004,-4.72727203,-5.54545403,-6.36363602, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
             0.00000000,0.00000000,0.00000000,0.00000000,0.00000000/)
  real, dimension(50), parameter :: intpol_ugd_exp =  &
            (/9.57142830,7.42857170,5.28571463,3.14285755,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000/)
  real, dimension(50), parameter :: intpol_vgd_exp =  &
            (/9.57142830,7.42857170,5.28571463,3.14285755,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000, &
              0.00000000,0.00000000,0.00000000,0.00000000,0.00000000/)

! prfile_test variables
  real, dimension(51), parameter :: prfile_uf_exp = (/1.00000000,         &
              0.800000012,0.600000024,0.399999976,0.199999988,0.00000000, &
              0.200000003,0.400000006,0.600000024,0.800000012,1.00000000, &
              0.800000012,0.600000024,0.399999976,0.199999988,0.00000000, &
              0.200000003,0.400000006,0.600000024,0.800000012,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              0.800000012,0.600000024,0.399999976,0.199999988,0.00000000/)
  real, dimension(51), parameter :: prfile_vf_exp = (/1.00000000,         &
              0.800000012,0.600000024,0.399999976,0.199999988,0.00000000, &
              0.200000003,0.400000006,0.600000024,0.800000012,1.00000000, &
              0.800000012,0.600000024,0.399999976,0.199999988,0.00000000, &
              0.200000003,0.400000006,0.600000024,0.800000012,1.00000000, &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              1.00000000,1.00000000,1.00000000,1.00000000,1.00000000,     &
              0.800000012,0.600000024,0.399999976,0.199999988,0.00000000/)
  real, dimension(51), parameter :: prfile_tf_exp = (/1.00000000,0.800000012, &
        0.600000024,0.399999976,0.199999988,0.00000000,0.00000000,0.00000000, &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000/)
  real, dimension(51), parameter :: prfile_qf_exp = (/1.00000000,0.800000012, &
        0.600000024,0.399999976,0.199999988,0.00000000,0.00000000,0.00000000, &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,0.00000000,    &
        0.00000000/)
  real, parameter :: prfile_awind_exp = 1.41421354

! f_control variables
  integer, parameter :: iyr_expected = 89
  integer, parameter :: imo_expected = 8
  integer, parameter :: iday_expected = 4
  real, parameter :: tz_expected = 6
  real, parameter :: xlat_expected = 39.25
  real, parameter :: xlong_expected = 96.34
  real, parameter :: strtim_expected = 0530
  real, parameter :: timend_expected = 2330
  real, parameter :: outtt_expected = 30
  real, parameter :: slope_expected = 0
  real, parameter :: aspect_expected = 0
  real, parameter :: f_expected = 0.5
  real, parameter :: fsub_expected = 0.75
  real, parameter :: wmax_expected = 0.34
  real, parameter :: btemp_expected = 24.63
  real, parameter :: tp_expected = 13
  character, parameter :: dual_ti_expected = 'Y'
  real, parameter :: ti_a_expected = 12.0
  real, parameter :: ti_b_expected = 12.0
!  character, parameter :: albedo_gflag_expected = 'F'
  real, parameter :: albg_expected = 0.1
  real, parameter :: epsi_expected = 0.96
!  integer, parameter :: index_soils_expected = 5
  real, parameter :: omega_expected = 3.13
  real, parameter :: zo_expected = 0.05
!  real, parameter :: obst_hgt_expected = 1
!  logical, parameter :: cloud_flag_expected = .true.
  real, parameter :: cld_fract_expected = 1.4
  real, parameter :: frveg_expected = 1
  real, parameter :: xlai_expected = 0
  real, parameter :: epsf_expected = 0.96
!  character, parameter :: albedo_fflag_expected = 'N'
  real, parameter :: albf_expected = 0.1
  character, parameter :: stmtype_expected =  'L'
!  integer, parameter :: index_veggies_expected = 4
  real, parameter :: volrel_expected = 10
  real, parameter :: rmin_expected = 150
  real, parameter :: rcut_expected = 1000
  real, parameter :: wilt_expected = 0.08
  real, parameter :: vegheight_expected = 0.5
  real, parameter :: width_expected = 0.12
  character, parameter :: steady_expected = 'Y'
  real, parameter :: ci_expected = 300
  real, parameter :: co_expected = 330
  real, parameter :: coz_sfc_expected = 0
  real, parameter :: coz_air_expected = 0.08
!  real, parameter :: NOBS_pTq_expected = 12
!  real, parameter :: NOBS_wind_expected = 11
!  real, parameter :: station_height_expected = 0.886
!  real, parameter :: ugs_expected = 4.649
!  real, parameter :: vgs_expected = 8.445
!  real, parameter :: ps_expected(12) = (/967,24,5,949,24,5,900,23,3,850,24,8 /)
!  real, parameter :: ts_expected(12) = (/700,11,7,677,9,11,628,4,6,612,2,7/)
!  real, parameter :: dep_expected(12) = (/606,2,15,530,-7,17,460,-10,30,250,-40,30/)
!  real, parameter :: dd0_expected(11) = (/180,7,0,185,10,1,225,35,3,240,25/)
!  real, parameter :: ff0_expected(11) = (/5,225,15,7,215,15,9,230,30,14,240/)
!  real, parameter :: zh_expected(11) = (/25,20,245,44,30,255,43,41,195,14,54/)
  real, parameter :: ozone_flux_plant_expected = 581.332764
  real, parameter :: ozone_fglobal_expected = 10028.6299

! ieee_arithmetic setup -- choices: up, down, nearest, to zero
  if (ieee_support_rounding(IEEE_NEAREST)) then
    call ieee_set_rounding_mode(IEEE_NEAREST)
  end if

! mod_testing variable setup
  n = 1
  ntests = 48
  call initialize_tests(tests,ntests)
! end  mod_testing variable setup

!
! splint_test
!
  if (splint_test) then
    do i = 1,splint_max_array
      splint_arg1(i) = 2*i
      splint_arg2(i) = 2*i
    end do
    splint_arg4 = 12
    if (.not. allocated(splint_arg3)) then
      allocate(splint_arg3(splint_arg4))
      do i = 1,splint_arg4
        splint_arg3(i) = 2*i
      end do
    end if
    splint_arg5 = 3
    splint_output=splint(splint_arg1, splint_arg2, splint_arg3, splint_arg4, splint_arg5)
    tests(n) = assert(eq(splint_output,splint_expected), 'SPLINT')
    n = n + 1
    if (allocated(splint_arg3)) then
      deallocate(splint_arg3)
    end if
  end if

!
! spline_test
!
  if (spline_test) then
    do i = 1,62
      spline_arg1(i) = 2*i
      spline_arg2(i) = 2*i
    end do
    spline_arg3 = 62
    spline_arg4 = 1.0
    spline_arg5 = 2.5
    if (.not. allocated(spline_output)) then
      allocate(spline_output(spline_arg3))
    end if
    tests(n) = assert(eq(                                                   &
       spline(spline_arg1,spline_arg2,spline_arg3,spline_arg4,spline_arg5), &
       spline_expected) .eqv. .true., 'SPLINE')
    n = n + 1
    if (allocated(spline_output)) then
      deallocate(spline_output)
    end if
  end if

!
! transm_ftabs_test
!
! Test the "else" branch in ftabsT()

  if (transm_ftabs_test) then
    call ftabsT_init
    transm_ftabs_arg1 = 2.75401473
    tests(n) = assert(eq(ftabst(transm_ftabs_arg1),transm_ftabs_expected), 'ftabs() else')
    n = n + 1
  end if

!
! transm_ftabs_test2
!
! Test the "if" branch in ftabsT()

  if (transm_ftabs_test2) then
    call ftabsT_init
    transm_ftabs_arg1 = 11.0
    tests(n) = assert(eq(ftabst(transm_ftabs_arg1),transm_ftabs_expected2), 'ftabs() if')
    n = n + 1
  end if

!
! transm_ftscatT_test
!
! Test the "else" branch in ftscatT()

  if (transm_ftscatT_test) then
    call ftscatT_init
    transm_ftscatT_arg1 = 2.75401473
    tests(n) = assert(eq(ftscatT(transm_ftscatT_arg1),transm_ftscatT_expected), 'ftscatT() else')
    n = n + 1
  end if

!
! transm_ftscatT_test2
!
! Test the "if" branch in ftscatT()

  if (transm_ftscatT_test2) then
    call ftscatT_init
    transm_ftscatT_arg1 = 11.0
    tests(n) = assert(eq(ftscatT(transm_ftscatT_arg1),transm_ftscatT_expected2), 'ftscatT() if')
    n = n + 1
  end if

!
! transm_fbscatT_test
!
! Test the "else" branch in fbscatT()

  if (transm_fbscatT_test) then
    call fbscatT_init
    transm_fbscatT_arg1 = 2.75401473
    tests(n) = assert(eq(fbscatT(transm_fbscatT_arg1),transm_fbscatT_expected), 'fbscatT() else')
    n = n + 1
  end if

!
! transm_fbscatT_test2
!
! Test the "if" branch in fbscatT()

  if (transm_fbscatT_test2) then
    call fbscatT_init
    transm_fbscatT_arg1 = 11.0
    tests(n) = assert(eq(fbscatT(transm_fbscatT_arg1),transm_fbscatT_expected2), 'fbscatT() if')
    n = n + 1
  end if

!
! advect_func_test
!
  if (advect_func_test) then
    call advect_init
    tests(n) = assert(eq(advect(),advect_test_expected), 'advect()')
    n = n + 1
  end if

!
! cond_test
!
  if (cond_test) then
    call cond_init
    tests(n) = assert(eq(cond(),cond_test_expected),'cond()')
    n = n + 1
  end if

!
! stomfs_test
!
  if (stomfs_test) then
    call stomfs_init
    tests(n) = assert(eq(stomfs(sc, sol),stomfs_test_expected), 'stomfs()')
    n = n + 1
  end if

!
! stomrs_test_hi_temp
!
  if (stomrs_test_hi_temp) then
    call stomrs_init
    TF = MAXTEMP + 1.0
    tests(n) = assert(eq( &
               stomrs(ft,tf,rmin,mintemp,maxtemp,psisup,psiwc,b1,b2,psie,psice,fs), &
               stomrs_test_hi_temp_expected), 'stomrs_test_hi_temp_expected')
    n = n + 1
  end if

!
! stomrs_test_lo_temp
!
  if (stomrs_test_lo_temp) then
    call stomrs_init
    TF = MINTEMP - 1.0
    tests(n) = assert(eq( &
               stomrs(ft,tf,rmin,mintemp,maxtemp,psisup,psiwc,b1,b2,psie,psice,fs), &
               stomrs_test_lo_temp_expected), 'stomrs_test_lo_temp_expected')
    n = n + 1
  end if

!
! stomrs_test_hi_psi
!
  if (stomrs_test_hi_psi) then
    call stomrs_init
    TF = (MINTEMP + MAXTEMP)/2
    PSISUP = PSIWC + 1.0
    tests(n) = assert(eq( &
               stomrs(ft,tf,rmin,mintemp,maxtemp,psisup,psiwc,b1,b2,psie,psice,fs), &
               stomrs_test_hi_psi_expected), 'stomrs_test_hi_psi')
    n = n + 1
  end if

!
! stomrs_test_lo_psi
!
  if (stomrs_test_lo_psi) then
    call stomrs_init
    TF = (MINTEMP + MAXTEMP)/2
    PSISUP = PSIWC - 1.0
    tests(n) = assert(eq( &
               stomrs(ft,tf,rmin,mintemp,maxtemp,psisup,psiwc,b1,b2,psie,psice,fs), &
               stomrs_test_lo_psi_expected), 'stomrs_test_lo_psi')
    n = n + 1
  end if

!
! stomc_test
!

  if (stomc_test) then
    call stomc_init
    tests(n) = assert(eq(stomc(ft,rmin,b1,psice,fs),stomc_test_expected),'stomc_test')
    n = n + 1
  end if

!
! you_star_test
!

  if (you_star_test) then
    call you_star_init
    tests(n) = assert(eq( &
               you_star(you_star_arg1,you_star_arg2,you_star_arg3,you_star_arg4,you_star_arg5), &
               you_star_test_expected),'you_star_test')
    n = n + 1
  end if

!
! r_ohms_test
!

  if (r_ohms_test) then
    call r_ohms_init
    tests(n) = assert(eq( &
               r_ohms(r_ohms_arg1,r_ohms_arg2,r_ohms_arg3,r_ohms_arg4,r_ohms_arg5), &
               r_ohms_test_expected),'r_ohms_test')
    n = n + 1
  end if

!
! windf_test
!

  if (windf_test) then
    call windf_init
    tests(n) = assert(eq(windf(windf_arg1,windf_arg2,windf_arg3,windf_arg4,windf_arg5),windf_test_expected),'windf_test')
    n = n + 1
  end if

!
! stab_test
!

  if (stab_test) then
    call stab_init
    tests(n) = assert(eq(stab(stab_arg1,stab_arg2),stab_test_expected),'stab_test')
    n = n + 1
  end if

!
! stabh_test
!

  if (stabh_test) then
    ! stabh takes same argument as stab so we'll recycle initialization
    call stab_init
    tests(n) = assert(eq(stabh(stab_arg1,stab_arg2),stabh_test_expected),'stabh_test')
    n = n + 1
  end if

!
! fstabh_test
!

  if (fstabh_test) then
    call fstabh_init
    tests(n) = assert(eq(fstabh(fstabh_arg1,fstabh_arg2),fstabh_test_expected),'fstabh_test')
    n = n + 1
  end if

!
! fstabm_test
!

  if (fstabm_test) then
    ! fstabm takes the same arguments as fstabh so we'll recycle the initialization
    call fstabh_init
    tests(n) = assert(eq(fstabm(fstabh_arg1,fstabh_arg2),fstabm_test_expected,eq_tol),'fstabm_test')
    n = n + 1
  end if

!
! restrn_test
!

  if (restrn_test) then
    call restrn_init
    tests(n) = assert(eq(restrn(restrn_arg1,restrn_arg2,restrn_arg3,restrn_arg4),restrn_test_expected),'restrn()')
    n = n + 1
  end if

!
! psgcal_test
!

  if (psgcal_test) then
    call psgcal_init
    psig = psgcal(thmax,thv,cosbyb,psis)
    tests(n) = assert(eq(PSIG,psgcal_test_expected), 'psgcal_test')
    n = n + 1
  end if

!
! vegflx_test
!

  if (vegflx_test) then
    call vegflx_init
    call vegflx(vegflx_arg1)
    tests(n) = assert(eq(QAF,vegflx_test_expected), 'vegflx_test')
    n = n + 1
  end if

!
! avr_test_init1
!

  if (avr_test_init1) then
    call avr_init
    do i=1,10
    call avr(avr_arg1,avr_arg2,avr_arg3)
    avr_arg1 = avr_arg1+1
    end do
!    write(6,*) 'avr after 10 passes: avr_arg1, avr_arg2, avr_arg3: ',avr_arg1, &
!      avr_arg2, avr_arg3
    tests(n) = assert(eq(avr_arg2,avr_test_init1_expected), 'avr_test_init1')
    n = n + 1
  end if

!
! avr_test_init_not1
!

!  if (avr_test_init_not1) then
!    call avr_init
!    call avr(avr_arg1,avr_arg2,avr_arg3)
!    call avr(avr_arg1,avr_arg2,avr_arg3)
!    call avr(avr_arg1,avr_arg2,avr_arg3)
!    call avr(avr_arg1,avr_arg2,avr_arg3)
!    tests(n) = assert(eq(avr_arg2,avr_test_init_not1_expected), 'avr_test_init_not1')
!    n = n + 1
!  end if

!
! ozone_test
!

  if (ozone_test) then
    call ozone_init
    call ozone
    tests(n) = assert(eq(flux_plant,ozone_flux_plant_expected), 'ozone flux_plant')
    n = n + 1
    tests(n) = assert(eq(fglobal,ozone_fglobal_expected), 'ozone fglobal')
    n = n + 1
  end if

!
! co2flx_test
!

  if (co2flx_test) then
    call co2flx_init
    call co2flx
    tests(n) = assert(eq(ccan,co2flx_ccan_expected), 'co2flx ccan')
    n = n + 1
    tests(n) = assert(eq(fco2,co2flx_fco2_expected), 'co2flx fco2')
    n = n + 1
  end if

!
! veghot_test
!

  if (veghot_test) then
    call veghot_init
    call veghot(veghot_arg1, veghot_arg2)
    tests(n) = assert(eq(veghot_arg2,veghot_heatv_expected), 'veghot heatv')
    n = n + 1
  end if

!
! hot_test
!

  if (hot_test) then
    call hot_init
    ! Case I: FRVEG == 1 AND RNET > 0
    FRVEG = 1.0
    RNET = 1.0
    call hot(hot_arg1,hot_arg2,hot_arg3,hot_arg4)
    tests(n) = assert(eq(heat, hot_caseI_expected), 'hot case I')
    n = n + 1
    ! Case II: 1 > FRVEG > 0 AND RNET > 0
    FRVEG = 0.5
    RNET = 1.0
    call hot(hot_arg1,hot_arg2,hot_arg3,hot_arg4)
    tests(n) = assert(eq(heat, hot_caseII_expected), 'hot case II')
    n = n + 1
    ! Case III: All others
    FRVEG = 1.5
    RNET = 1.0
    call hot(hot_arg1,hot_arg2,hot_arg3,hot_arg4)
    tests(n) = assert(eq(heat, hot_caseIII_expected), 'hot case III')
    n = n + 1
  end if

!
! albedo_test (4 cases)
!

  if (albedo_test) then
    call albedo_init

!  Case I
    ALBG = 0.0
    ALBF = 0.0
    call albedo(albedo_test_arg1)
    tests(n) = assert(eq(ALBDOE,albedo_caseI_expected), 'albedo case I')
    n = n + 1

!  Case II
    ALBG = 20.0
    ALBF = 0.0
    call albedo(albedo_test_arg1)
    tests(n) = assert(eq(ALBDOE,albedo_caseII_expected), 'albedo case II')
    n = n + 1

!  Case III
    ALBG = 0.0
    ALBF = 20.0
    call albedo(albedo_test_arg1)
    tests(n) = assert(eq(ALBDOE,albedo_caseIII_expected), 'albedo case III')
    n = n + 1

!  Case IV
    ALBG = 46.0
    ALBF = 71.0
    call albedo(albedo_test_arg1)
    tests(n) = assert(eq(ALBDOE,albedo_caseIV_expected), 'albedo case IV')
    n = n + 1
  end if

!
! intpol_test (4 array variables)
!
  if (intpol_test) then
    call intpol_init
    call intpol
    tests(n) = assert(eq(ug,intpol_ug_exp) .eqv. .true., 'Intpol UG(50)')
    n = n + 1
    tests(n) = assert(eq(vg,intpol_vg_exp) .eqv. .true., 'Intpol VG(50)')
    n = n + 1
    tests(n) = assert(eq(ugd,intpol_ugd_exp) .eqv. .true., 'Intpol UGD(50)')
    n = n + 1
    tests(n) = assert(eq(vgd,intpol_vgd_exp) .eqv. .true., 'Intpol VGD(50)')
    n = n + 1
  end if

!
! prfile_test (4 array variables and scalar variable)
!

  if (prfile_test) then
    call prfile_init
    call prfile
    tests(n) = assert(eq(u_fine,prfile_uf_exp) .eqv. .true., 'PRFILE u_fine')
    n = n + 1
    tests(n) = assert(eq(v_fine,prfile_vf_exp) .eqv. .true., 'PRFILE v_fine')
    n = n + 1
    tests(n) = assert(eq(t_fine,prfile_tf_exp) .eqv. .true., 'PRFILE t_fine')
    n = n + 1
    tests(n) = assert(eq(q_fine,prfile_qf_exp) .eqv. .true., 'PRFILE q_fine')
    n = n + 1
    tests(n) = assert(eq(awind,prfile_awind_exp), 'PRFILE awind')
    n = n + 1
  end if

!
! f_control_test
!

  if (f_control_test) then
!    call start
    tests(n) = assert(iyr == iyr_expected, 'iyr')
    n = n + 1
    tests(n) = assert(imo == imo_expected, 'imo')
    n = n + 1
    tests(n) = assert(iday == iday_expected, 'iday')
    n = n + 1
    tests(n) = assert(eq(tz,tz_expected), 'tz')
    n = n + 1
    tests(n) = assert(eq(xlat,xlat_expected), 'xlat')
    n = n + 1
    tests(n) = assert(eq(xlong,xlong_expected), 'xlong')
    n = n + 1
    tests(n) = assert(eq(strtim,strtim_expected), 'strtim')
    n = n + 1
    tests(n) = assert(eq(timend,timend_expected), 'timend')
    n = n + 1
    tests(n) = assert(eq(outtt,outtt_expected), 'outtt')
    n = n + 1
    tests(n) = assert(eq(slope,slope_expected), 'slope')
    n = n + 1
    tests(n) = assert(eq(aspect,aspect_expected), 'aspect')
    n = n + 1
    tests(n) = assert(eq(f,f_expected), 'f')
    n = n + 1
    tests(n) = assert(eq(fsub,fsub_expected), 'f_sub')
    n = n + 1
    tests(n) = assert(eq(wmax,wmax_expected), 'wmax')
    n = n + 1
    tests(n) = assert(eq(btemp,btemp_expected), 'btemp')
    n = n + 1
    tests(n) = assert(eq(tp,tp_expected), 'tp')
    n = n + 1
    tests(n) = assert(dual_ti == dual_ti_expected, 'dual_ti')
    n = n + 1
    tests(n) = assert(eq(ti_a,ti_a_expected), 'ti_a')
    n = n + 1
    tests(n) = assert(eq(ti_b,ti_b_expected), 'ti_b')
    n = n + 1
!    tests(n) = assert(albedo_gflag == albedo_gflag_expected, 'albedo_gflag')
!    n = n + 1
    tests(n) = assert(eq(albg,albg_expected), 'albg')
    n = n + 1
    tests(n) = assert(eq(epsi,epsi_expected), 'epsi')
    n = n + 1
!    tests(n) = assert(index_soils == index_soils_expected, 'index_soils')
!    n = n + 1
    tests(n) = assert(eq(omega,omega_expected), 'omega')
    n = n + 1
    tests(n) = assert(eq(zo,zo_expected), 'zo')
    n = n + 1
!    tests(n) = assert(obst_hgt == obst_hgt_expected, 'obst_hgt')
!    n = n + 1
!    tests(n) = assert(cloud_flag == cloud_flag_expected, 'cloud_flag')
!    n = n + 1
    tests(n) = assert(cld_fract == cld_fract_expected, 'cld_fract')
    n = n + 1
    tests(n) = assert(eq(frveg,frveg_expected), 'frveg')
    n = n + 1
    tests(n) = assert(eq(xlai,xlai_expected), 'xlai')
    n = n + 1
    tests(n) = assert(eq(epsf,epsf_expected), 'epsf')
    n = n + 1
!    tests(n) = assert(albedo_fflag == albedo_fflag_expected, 'albedo_flag')
!    n = n + 1
    tests(n) = assert(eq(albf,albf_expected), 'albf')
    n = n + 1
    tests(n) = assert(stmtype == stmtype_expected, 'stmtype')
    n = n + 1
!    tests(n) = assert(index_veggies == index_veggies_expected, 'index_veggies')
!    n = n + 1
    tests(n) = assert(eq(volrel,volrel_expected), 'volrel')
    n = n + 1
    tests(n) = assert(eq(rmin,rmin_expected), 'rmin')
    n = n + 1
    tests(n) = assert(eq(rcut,rcut_expected), 'rcut')
    n = n + 1
    tests(n) = assert(eq(wilt,wilt_expected), 'wilt')
    n = n + 1
    tests(n) = assert(eq(vegheight,vegheight_expected), 'vegheight')
    n = n + 1
    tests(n) = assert(eq(width,width_expected), 'width')
    n = n + 1
    tests(n) = assert(steady == steady_expected, 'steady')
    n = n + 1
    tests(n) = assert(eq(ci,ci_expected), 'ci')
    n = n + 1
    tests(n) = assert(eq(co,co_expected), 'co')
    n = n + 1
    tests(n) = assert(eq(coz_sfc,coz_sfc_expected), 'coz_sfc')
    n = n + 1
    tests(n) = assert(eq(coz_air,coz_air_expected), 'coz_air')
    n = n + 1
!    call snding
!    tests(n) = assert(NOBS_pTq == NOBS_pTq_expected, 'NOBS_pTq')
!    n = n + 1
!    tests(n) = assert(NOBS_wind == NOBS_wind_expected, 'NOBS_wind')
!    n = n + 1
!    tests(n) = assert(station_height == station_height_expected, 'station_height')
!    n = n + 1
!    tests(n) = assert(ugs == ugs_expected, 'ugs')
!    n = n + 1
!    tests(n) = assert(vgs == vgs_expected, 'vgs')
!    n = n + 1
!    tests(n) = assert(ps == ps_expected, 'ps')
!    n = n + 1
!    tests(n) = assert(ts == ts_expected, 'ts')
!    n = n + 1
!    tests(n) = assert(dep == dep_expected, 'dep')
!    n = n + 1
!    tests(n) = assert(dd0 == dd0_expected, 'dd0')
!    n = n + 1
!    tests(n) = assert(ff0 == ff0_expected, 'ff0')
!    n = n + 1
!    tests(n) = assert(zh == zh_expected, 'zh')
!    n = n + 1
  end if

! Report test summary
  test_failed = .false.
  call report_tests(tests,test_failed)
  if (test_failed) stop 1

contains
  subroutine ftabsT_init
    OMEGA = 3.13
    ABSTBL(9) = 0.718309104
    ABSTBL(10) = 0.707092881
    ABSTBL(46) = 0.437107921
    PS1 = 967.0
    return
  end subroutine ftabsT_init

  subroutine ftscatT_init
    OMEGA = 3.13
    SCATBL(9) = 0.548576415
    SCATBL(10) = 0.527300596
    SCATBL(46) = 0.173223004
    PS1 = 967.0
    return
  end subroutine ftscatT_init

  subroutine fbscatT_init
    OMEGA = 3.13
    BSCTBL(9) = 0.307897508
    BSCTBL(10) = 0.307446688
    BSCTBL(46) = 0.304252803
    PS1 = 967.0
    return
  end subroutine fbscatT_init

  subroutine advect_init
    CF = 9.19953891E-05
    OTEMP = 295.149994
    VGD(5) = 8.41951942
    VGD(3) = 8.43165302
    VGD(1) = 8.44378662
    UGD(5) = 13.0658665
    UGD(3) = 9.05783463
    UGD(1) = 5.04980326
    return
  end subroutine advect_init

  subroutine cond_init
    RKS = 6.60699987
    THV = 1.00000000
    THMAX = 0.338999987
    COSBYB = 2.78999996
    return
  end subroutine cond_init

  subroutine stomfs_init
    sc = 1.0
    sol = 1.0
    return
  end subroutine stomfs_init

  subroutine stomrs_init
    RMIN = 1.0
    MINTEMP = 1.0
    MAXTEMP = 100.0
    PSIWC = 1.0
    PSIE = 1.0
    PSICE = 2.0
    B1 = 1.0
    B2 = 2.0
    call stomfs_init
    FS = stomfs(sc,sol)
    return
  end subroutine stomrs_init

  subroutine stomc_init
    B1 = 1.0
    PSICE = 2.0
    RMIN = 1.0
    call stomfs_init
    FS = stomfs(sc,sol)
    return
  end subroutine stomc_init

  subroutine you_star_init
    you_star_arg1 = 0.1
    you_star_arg2 = 1.0
    you_star_arg3 = 2.0
    you_star_arg4 = 3.0
    you_star_arg5 = karman
    return
  end subroutine you_star_init

  subroutine r_ohms_init
    r_ohms_arg1 = 0.1
    r_ohms_arg2 = 1.0
    r_ohms_arg3 = 2.0
    r_ohms_arg4 = 3.0
    r_ohms_arg5 = karman
    return
  end subroutine r_ohms_init

  subroutine windf_init
    windf_arg1 = 1.0
    windf_arg2 = 2.0
    windf_arg3 = 3.0
    windf_arg4 = 4.0
    windf_arg5 = karman
    return
  end subroutine windf_init

  subroutine stab_init
    ! also used to test stabh
    stab_arg1 = 0.1
    stab_arg2 = 2.0
    return
  end subroutine stab_init

  subroutine fstabh_init
    ! also used to test fstabm
    fstabh_arg1 = 1.0
    fstabh_arg2 = 2.0
    return
  end subroutine fstabh_init

  subroutine restrn_init
    restrn_arg1 = 1.0
    restrn_arg2 = 2.0
    restrn_arg3 = 3.0
    restrn_arg4 = karman
    return
  end subroutine

  subroutine psgcal_init
    THMAX = 0.338999987
    THV = 1.0
    COSBYB = 2.78999996
    PSIS = 1.0
    return
  end subroutine psgcal_init

  subroutine vegflx_init
    vegflx_arg1 = 0.3
    TAF = 10.0
    CHF = 10.0
    F = 100.0
    CHG = 0.1
    QAF = 0.5
    HG = 1.0
    CHG = 100.5
    XLEF = 1.2
    CHA = 100.0
    TA = 0.4
    CHF = 10.0
    TF = 1.0
    RST = 1.0
    QA = 100.0
    QSTF = 10.0
    return
  end subroutine vegflx_init

  subroutine avr_init
    avr_arg1 = 293.0
    avr_arg3 = 1
    return
  end subroutine avr_init

  subroutine ozone_init
    USTAR = 1.0
    UTEN = 1.0
    UAF = 0.5
    XLAI = 2.0
    RAF = 1.0
    RCUT = 1.0
    RST = 1.0
    CHG = 2.0
    RZASCR = 1.0
    COZ_AIR = 1.0
    frveg = 0.5
    sumo3 = 0.1
    return
  end subroutine ozone_init

  subroutine co2flx_init
    USTAR = 1.0
    UTEN = 2.0
    UAF = 1.0
    XLAI = 1.0
    RZASCR = 2.0
    RAF = 1.0
    RST = 1.0
    CO = 2.0
    CI = 1.0
    FRVEG = 0.5
    return
  end subroutine co2flx_init

  subroutine veghot_init
    TF = 1.0
    TAF = 1.0
    CHF = 1.0
    CHG = 1.0
    HF = 1.0
    TT(2) = 1.0
    Z(2) = 1.0
    LAMBDA = 1.0
    RNETG = 3.0
    XLEG = 1.0
    veghot_arg1 = 1.0
    veghot_arg2 = 1.0
  end subroutine veghot_init

  subroutine hot_init
    hot_arg2 = 4.0
    hot_arg3 = 2.0
    hot_arg4 = 1.0
    LAMBDA = 1.0
    ATEMP = 2.0
    TT(2) = 1.0
    Z(2) = 1.0
    TF = 1.0
    TAF = 1.0
    CHF = 1.0
    CHG = 1.0
    HF = 1.0
    RNETG = 3.0
    XLEG = 1.0
    GBL_sum = 1.0
    return
  end subroutine hot_init

  subroutine albedo_init
    albedo_test_arg1 = -0.510662317
    XLAI = 1.0
    FRVEG = 1.0
    WGG = 100.0
    WMAX = 1230.0
    return
  end subroutine albedo_init

  subroutine intpol_init
    NTRP = 10
    VGS = 10.0
    UGS = 10.0
    VD = 1.0
    UD = 1.0
    VGD(NTRP) = 1.0
    UGD(NTRP) = 1.0
    return
  end subroutine intpol_init

  subroutine prfile_init
    integer :: i

    call advect_init
    call intpol_init

    ud = 0.0
    vd = 0.0
    ud(1) = 1.0
    vd(1) = 1.0
    ud(3) = 1.0
    vd(3) = 1.0
    do i = 5, NTRP
      ud(i) = 1.0
      vd(i) = 1.0
    end do
    td(1) = 1.0
    qd(1) = 1.0
    return
  end subroutine prfile_init

end program test_simsphere


      SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD,
     $                   NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To extract from the (N+P)-by-(M+N) system
C                  ( B  A )
C                  ( D  C )
C     an (NU+MU)-by-(M+NU) "reduced" system
C                  ( B' A')
C                  ( D' C')
C     having the same transmission zeros but with D' of full row rank.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of state variables.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     RO      (input/output) INTEGER
C             On entry,
C             = P     for the original system;
C             = MAX(P-M, 0) for the pertransposed system.
C             On exit, RO contains the last computed rank.
C
C     SIGMA   (input/output) INTEGER
C             On entry,
C             = 0  for the original system;
C             = M  for the pertransposed system.
C             On exit, SIGMA contains the last computed value sigma in
C             the algorithm.
C
C     SVLMAX  (input) DOUBLE PRECISION
C             During each reduction step, the rank-revealing QR
C             factorization of a matrix stops when the estimated minimum
C             singular value is smaller than TOL * MAX(SVLMAX,EMSV),
C             where EMSV is the estimated maximum singular value.
C             SVLMAX >= 0.
C
C     ABCD    (input/output) DOUBLE PRECISION array, dimension
C             (LDABCD,M+N)
C             On entry, the leading (N+P)-by-(M+N) part of this array
C             must contain the compound input matrix of the system.
C             On exit, the leading (NU+MU)-by-(M+NU) part of this array
C             contains the reduced compound input matrix of the system.
C
C     LDABCD  INTEGER
C             The leading dimension of array ABCD.
C             LDABCD >= MAX(1,N+P).
C
C     NINFZ   (input/output) INTEGER
C             On entry, the currently computed number of infinite zeros.
C             It should be initialized to zero on the first call.
C             NINFZ >= 0.
C             On exit, the number of infinite zeros.
C
C     INFZ    (input/output) INTEGER array, dimension (N)
C             On entry, INFZ(i) must contain the current number of
C             infinite zeros of degree i, where i = 1,2,...,N, found in
C             the previous call(s) of the routine. It should be
C             initialized to zero on the first call.
C             On exit, INFZ(i) contains the number of infinite zeros of
C             degree i, where i = 1,2,...,N.
C
C     KRONL   (input/output) INTEGER array, dimension (N+1)
C             On entry, this array must contain the currently computed
C             left Kronecker (row) indices found in the previous call(s)
C             of the routine. It should be initialized to zero on the
C             first call.
C             On exit, the leading NKROL elements of this array contain
C             the left Kronecker (row) indices.
C
C     MU      (output) INTEGER
C             The normal rank of the transfer function matrix of the
C             original system.
C
C     NU      (output) INTEGER
C             The dimension of the reduced system matrix and the number
C             of (finite) invariant zeros if D' is invertible.
C
C     NKROL   (output) INTEGER
C             The number of left Kronecker indices.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR (or RQ) factorization with column (or row) pivoting
C             whose estimated condition number is less than 1/TOL.
C             NOTE that when SVLMAX > 0, the estimated ranks could be
C             less than those defined above (see SVLMAX).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(M,P))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N),
C                               MIN(P,N) + MAX(3*P-1,N+P,N+M) ).
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     REFERENCES
C
C     [1] Svaricek, F.
C         Computation of the Structural Invariants of Linear
C         Multivariable Systems with an Extended Version of
C         the Program ZEROS.
C         System & Control Letters, 6, pp. 261-266, 1985.
C
C     [2] Emami-Naeini, A. and Van Dooren, P.
C         Computation of Zeros of Linear Multivariable Systems.
C         Automatica, 18, pp. 415-430, 1982.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
C     Supersedes Release 2.0 routine AB08BZ by F. Svaricek.
C
C     REVISIONS
C
C     V. Sima, Oct. 1997; Feb. 1998, Jan. 2009, Apr. 2009, Apr. 2011.
C     A. Varga, May 1999; May 2001.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, Kronecker indices, multivariable
C     system, orthogonal transformation, structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDABCD, LDWORK, M, MU, N, NINFZ, NKROL,
     $                  NU, P, RO, SIGMA
      DOUBLE PRECISION  SVLMAX, TOL
C     .. Array Arguments ..
      INTEGER           INFZ(*), IWORK(*), KRONL(*)
      DOUBLE PRECISION  ABCD(LDABCD,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY
      INTEGER           I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU,
     $                  MPM, NP, RANK, RO1, TAU, WRKOPT
      DOUBLE PRECISION  T
C     .. Local Arrays ..
      DOUBLE PRECISION  SVAL(3)
C     .. External Subroutines ..
      EXTERNAL          DLAPMT, DLARFG, DLASET, DLATZM, DORMQR, DORMRQ,
     $                  MB03OY, MB03PY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      NP   = N + P
      MPM  = MIN( P, M )
      INFO = 0
      LQUERY = ( LDWORK.EQ.-1 )
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN
         INFO = -4
      ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN
         INFO = -5
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN
         INFO = -8
      ELSE IF( NINFZ.LT.0 ) THEN
         INFO = -9
      ELSE
         JWORK = MAX( 1,      MPM + MAX( 3*M - 1, N ),
     $                MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) )
         IF( LQUERY ) THEN
            IF( M.GT.0 ) THEN
               CALL DORMQR( 'Left', 'Transpose', P, N, MPM, ABCD,
     $                      LDABCD, DWORK, ABCD, LDABCD, DWORK, -1,
     $                      INFO )
               WRKOPT = MAX( JWORK, MPM + INT( DWORK(1) ) )
            ELSE
               WRKOPT = JWORK
            END IF
            CALL DORMRQ( 'Right', 'Transpose', NP, N, MIN( P, N ), ABCD,
     $                   LDABCD, DWORK, ABCD, LDABCD, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, MIN( P, N ) + INT( DWORK(1) ) )
            CALL DORMRQ( 'Left', 'NoTranspose', N, M+N, MIN( P, N ),
     $                   ABCD, LDABCD, DWORK, ABCD, LDABCD, DWORK, -1,
     $                   INFO )
            WRKOPT = MAX( WRKOPT, MIN( P, N ) + INT( DWORK(1) ) )
         ELSE IF( LDWORK.LT.JWORK ) THEN
            INFO = -18
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB08NX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
      MU = P
      NU = N
C
      IZ = 0
      IK = 1
      MM1 = M + 1
      ITAU = 1
      NKROL = 0
      WRKOPT = 1
C
C     Main reduction loop:
C
C            M   NU                  M     NU
C      NU  [ B   A ]           NU  [ B     A ]
C      MU  [ D   C ]  -->    SIGMA [ RD   C1 ]   (SIGMA = rank(D) =
C                             TAU  [ 0    C2 ]    row size of RD)
C
C                                    M   NU-RO  RO
C                            NU-RO [ B1   A11  A12 ]
C                     -->      RO  [ B2   A21  A22 ]  (RO = rank(C2) =
C                            SIGMA [ RD   C11  C12 ]   col size of LC)
C                             TAU  [ 0     0   LC  ]
C
C                                      M   NU-RO
C                            NU-RO [ B1   A11 ]     NU := NU - RO
C                                  [----------]     MU := RO + SIGMA
C                     -->      RO  [ B2   A21 ]      D := [B2;RD]
C                            SIGMA [ RD   C11 ]      C := [A21;C11]
C
   20 IF ( MU.EQ.0 )
     $   GO TO 80
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      RO1 = RO
      MNU = M + NU
      IF ( M.GT.0 ) THEN
         IF ( SIGMA.NE.0 ) THEN
            IROW = NU + 1
C
C           Compress rows of D.  First exploit triangular shape.
C           Workspace: need   M+N-1.
C
            DO 40 I1 = 1, SIGMA
               CALL DLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, T )
               CALL DLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, T,
     $                      ABCD(IROW,I1+1), ABCD(IROW+1,I1+1), LDABCD,
     $                      DWORK )
               IROW = IROW + 1
   40       CONTINUE
            CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO,
     $                   ABCD(NU+2,1), LDABCD )
         END IF
C
C        Continue with Householder with column pivoting.
C
C        The rank of D is the number of (estimated) singular values
C        that are greater than TOL * MAX(SVLMAX,EMSV). This number
C        includes the singular values of the first SIGMA columns.
C        Integer workspace: need   M;
C        Workspace: need   min(RO1,M) + 3*M - 1.  RO1 <= P.
C
         IF ( SIGMA.LT.M ) THEN
            JWORK = ITAU + MIN( RO1, M )
            I1    = SIGMA + 1
            IROW  = NU + I1
            CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL,
     $                   SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU),
     $                   DWORK(JWORK), INFO )
            WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 )
C
C           Apply the column permutations to matrices B and part of D.
C
            CALL DLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD,
     $                   IWORK )
C
            IF ( RANK.GT.0 ) THEN
C
C              Apply the Householder transformations to the submatrix C.
C              Workspace: need   min(RO1,M) + NU;
C                         prefer min(RO1,M) + NU*NB.
C
               CALL DORMQR( 'Left', 'Transpose', RO1, NU, RANK,
     $                      ABCD(IROW,I1), LDABCD, DWORK(ITAU),
     $                      ABCD(IROW,MM1), LDABCD, DWORK(JWORK),
     $                      LDWORK-JWORK+1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
               IF ( RO1.GT.1 )
     $            CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO,
     $                         ZERO, ABCD(IROW+1,I1), LDABCD )
               RO1 = RO1 - RANK
            END IF
         END IF
      END IF
C
      TAU = RO1
      SIGMA = MU - TAU
C
C     Determination of the orders of the infinite zeros.
C
      IF ( IZ.GT.0 ) THEN
         INFZ(IZ) = INFZ(IZ) + RO - TAU
         NINFZ = NINFZ + IZ*( RO - TAU )
      END IF
      IF ( RO1.EQ.0 )
     $   GO TO 80
      IZ = IZ + 1
C
      IF ( NU.LE.0 ) THEN
         MU = SIGMA
         NU = 0
         RO = 0
      ELSE
C
C        Compress the columns of C2 using RQ factorization with row
C        pivoting, P * C2 = R * Q.
C
         I1 = NU + SIGMA + 1
         MNTAU = MIN( TAU, NU )
         JWORK = ITAU + MNTAU
C
C        The rank of C2 is the number of (estimated) singular values
C        greater than TOL * MAX(SVLMAX,EMSV).
C        Integer Workspace: need TAU;
C        Workspace: need min(TAU,NU) + 3*TAU - 1.
C
         CALL MB03PY( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK,
     $                SVAL, IWORK, DWORK(ITAU), DWORK(JWORK), INFO )
         WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 )
         IF ( RANK.GT.0 ) THEN
            IROW = I1 + TAU - RANK
C
C           Apply Q' to the first NU columns of [A; C1] from the right.
C           Workspace: need   min(TAU,NU) + NU + SIGMA; SIGMA <= P;
C                      prefer min(TAU,NU) + (NU  + SIGMA)*NB.
C
            CALL DORMRQ( 'Right', 'Transpose', I1-1, NU, RANK,
     $                   ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1),
     $                   ABCD(1,MM1), LDABCD, DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C           Apply Q to the first NU rows and M + NU columns of [ B  A ]
C           from the left.
C           Workspace: need   min(TAU,NU) + M + NU;
C                      prefer min(TAU,NU) + (M + NU)*NB.
C
            CALL DORMRQ( 'Left', 'NoTranspose', NU, MNU, RANK,
     $                   ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1),
     $                   ABCD, LDABCD, DWORK(JWORK), LDWORK-JWORK+1,
     $                   INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
            CALL DLASET( 'Full', RANK, NU-RANK, ZERO, ZERO,
     $                   ABCD(IROW,MM1), LDABCD )
            IF ( RANK.GT.1 )
     $         CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO,
     $                      ABCD(IROW+1,MM1+NU-RANK), LDABCD )
         END IF
C
         RO = RANK
      END IF
C
C     Determine the left Kronecker indices (row indices).
C
      KRONL(IK) = KRONL(IK) + TAU - RO
      NKROL = NKROL + KRONL(IK)
      IK = IK + 1
C
C     C and D are updated to [A21 ; C11] and [B2 ; RD].
C
      NU = NU - RO
      MU = SIGMA + RO
      IF ( RO.NE.0 )
     $   GO TO 20
C
   80 CONTINUE
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of AB08NX ***
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape10tet(xi,et,ze,xl,xsj,shp,iflag)
!
!     shape functions and derivatives for a 10-node quadratic
!     isoparametric tetrahedral element. 0<=xi,et,ze<=1,xi+et+ze<=1.
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions and
!              the Jacobian determinant
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian determinant
!
      implicit none
!
      integer i,j,k,iflag
!
      real*8 shp(4,10),xs(3,3),xsi(3,3),xl(3,10),sh(3),xi,et,ze,xsj,a
!
!     shape functions and their glocal derivatives
!
!     shape functions
!
      a=1.d0-xi-et-ze
      shp(4, 1)=(2.d0*a-1.d0)*a
      shp(4, 2)=xi*(2.d0*xi-1.d0)
      shp(4, 3)=et*(2.d0*et-1.d0)
      shp(4, 4)=ze*(2.d0*ze-1.d0)
      shp(4, 5)=4.d0*xi*a
      shp(4, 6)=4.d0*xi*et
      shp(4, 7)=4.d0*et*a
      shp(4, 8)=4.d0*ze*a
      shp(4, 9)=4.d0*xi*ze
      shp(4,10)=4.d0*et*ze
!
      if(iflag.eq.1) return
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1, 1)=1.d0-4.d0*a
      shp(1, 2)=4.d0*xi-1.d0
      shp(1, 3)=0.d0
      shp(1, 4)=0.d0
      shp(1, 5)=4.d0*(a-xi)
      shp(1, 6)=4.d0*et
      shp(1, 7)=-4.d0*et
      shp(1, 8)=-4.d0*ze
      shp(1, 9)=4.d0*ze
      shp(1,10)=0.d0
!
!     local derivatives of the shape functions: eta-derivative
!
      shp(2, 1)=1.d0-4.d0*a
      shp(2, 2)=0.d0
      shp(2, 3)=4.d0*et-1.d0
      shp(2, 4)=0.d0
      shp(2, 5)=-4.d0*xi
      shp(2, 6)=4.d0*xi
      shp(2, 7)=4.d0*(a-et)
      shp(2, 8)=-4.d0*ze
      shp(2, 9)=0.d0
      shp(2,10)=4.d0*ze
!
!     local derivatives of the shape functions: zeta-derivative
!
      shp(3, 1)=1.d0-4.d0*a
      shp(3, 2)=0.d0
      shp(3, 3)=0.d0
      shp(3, 4)=4.d0*ze-1.d0
      shp(3, 5)=-4.d0*xi
      shp(3, 6)=0.d0
      shp(3, 7)=-4.d0*et
      shp(3, 8)=4.d0*(a-ze)
      shp(3, 9)=4.d0*xi
      shp(3,10)=4.d0*et
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,10
            xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant
!
      xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2))
     &   -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1))
     &   +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1))
!
      if(iflag.eq.2) return
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
      xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj
      xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj
      xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj
      xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj
      xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj
      xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj
      xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj
      xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj
      xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj
!
!     computation of the global derivatives of the shape functions
!
      do k=1,10
        do j=1,3
          sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j)
        enddo
        do j=1,3
          shp(j,k)=sh(j)
        enddo
      enddo
!
      return
      end