PROGRAM test_as241
IMPLICIT NONE
INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6, 30),  &
                      dp = SELECTED_REAL_KIND(12, 60)

REAL (sp)  :: p_single, z_single
REAL (dp)  :: p_dble, z_dble
INTEGER    :: ifault

INTERFACE
  SUBROUTINE ppnd7 (p, normal_dev, ifault)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: sp = SELECTED_REAL_KIND(6, 30)
    REAL (sp), INTENT(IN)   :: p
    INTEGER, INTENT(OUT)    :: ifault
    REAL (sp), INTENT(OUT)  :: normal_dev
  END SUBROUTINE ppnd7
  SUBROUTINE ppnd16 (p, normal_dev, ifault)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)   :: p
    INTEGER, INTENT(OUT)    :: ifault
    REAL (dp), INTENT(OUT)  :: normal_dev
  END SUBROUTINE ppnd16
END INTERFACE

DO
  WRITE(*, *)'Enter area under normal curve: '
  READ(*, *) p_dble
  p_single = p_dble
  CALL ppnd7(p_single, z_single, ifault)
  IF (ifault /= 0) THEN
    WRITE(*, '(1x, "IFAULT =", i3)') ifault
    CYCLE
  END IF
  CALL ppnd16(p_dble, z_dble, ifault)
  IF (ifault /= 0) THEN
    WRITE(*, '(1x, "IFAULT =", i3)') ifault
    CYCLE
  END IF
  WRITE(*, '(1x, a, f11.6, 2x, a, f16.11)')   &
        'Low prec. result =',  z_single, ' High prec. result =', z_dble
END DO
STOP

END PROGRAM test_as241

SUBROUTINE ppnd7 (p, normal_dev, ifault)

! ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3, 477- 484.

! Produces the normal deviate Z corresponding to a given lower tail area of P;
! Z is accurate to about 1 part in 10**7.

! The hash sums below are the sums of the mantissas of the coefficients.
! They are included for use in checking transcription.

! This ELF90-compatible version by Alan Miller - 20 August 1996
! N.B. The original algorithm is as a function; this is a subroutine

IMPLICIT NONE

INTEGER, PARAMETER      :: sp = SELECTED_REAL_KIND(6, 30)
REAL (sp), INTENT(IN)   :: p
INTEGER, INTENT(OUT)    :: ifault
REAL (sp), INTENT(OUT)  :: normal_dev

! Local variables

REAL (sp) :: zero = 0.0, one = 1.0, half = 0.5, split1 = 0.425,  &
             split2 = 5.0, const1 = 0.180625, const2 = 1.6, q, r

! Coefficients for P close to 0.5

REAL (sp) :: a0 = 3.3871327179E+00, a1 = 5.0434271938E+01, &
                   a2 = 1.5929113202E+02, a3 = 5.9109374720E+01, &
                   b1 = 1.7895169469E+01, b2 = 7.8757757664E+01, &
                   b3 = 6.7187563600E+01
! HASH SUM AB          32.3184577772

! Coefficients for P not close to 0, 0.5 or 1.

REAL (sp) :: c0 = 1.4234372777E+00, c1 = 2.7568153900E+00, &
             c2 = 1.3067284816E+00, c3 = 1.7023821103E-01, &
             d1 = 7.3700164250E-01, d2 = 1.2021132975E-01
! HASH SUM CD    15.7614929821

! Coefficients for P near 0 or 1.

REAL (sp) :: e0 = 6.6579051150E+00, e1 = 3.0812263860E+00, &
             e2 = 4.2868294337E-01, e3 = 1.7337203997E-02, &
             f1 = 2.4197894225E-01, f2 = 1.2258202635E-02
! HASH SUM EF    19.4052910204

ifault = 0
q = p - half
IF (ABS(q) <= split1) THEN
  r = const1 - q * q
  normal_dev = q * (((a3 * r + a2) * r + a1) * r + a0) / &
               (((b3 * r + b2) * r + b1) * r + one)
  RETURN
ELSE
  IF (q < zero) THEN
    r = p
  ELSE
    r = one - p
  END IF
  IF (r <= zero) THEN
    ifault = 1
    normal_dev = zero
    RETURN
  END IF
  r = SQRT(-LOG(r))
  IF (r <= split2) THEN
    r = r - const2
    normal_dev = (((c3 * r + c2) * r + c1) * r + c0) / ((d2 * r + d1) * r + one)
  ELSE
    r = r - split2
    normal_dev = (((e3 * r + e2) * r + e1) * r + e0) / ((f2 * r + f1) * r + one)
  END IF
  IF (q < zero) normal_dev = - normal_dev
  RETURN
END IF
END SUBROUTINE ppnd7

SUBROUTINE ppnd16 (p, normal_dev, ifault)

! ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3

! Produces the normal deviate Z corresponding to a given lower
! tail area of P; Z is accurate to about 1 part in 10**16.

! The hash sums below are the sums of the mantissas of the
! coefficients.   They are included for use in checking
! transcription.

! This ELF90-compatible version by Alan Miller - 20 August 1996
! N.B. The original algorithm is as a function; this is a subroutine

IMPLICIT NONE

INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
REAL (dp), INTENT(IN)   :: p
INTEGER, INTENT(OUT)    :: ifault
REAL (dp), INTENT(OUT)  :: normal_dev

! Local variables

REAL (dp) :: zero = 0.d0, one = 1.d0, half = 0.5d0,  &
             split1 = 0.425d0, split2 = 5.d0, const1 = 0.180625d0, &
             const2 = 1.6d0, q, r

! Coefficients for P close to 0.5

REAL (dp) :: a0 = 3.3871328727963666080D0, &
             a1 = 1.3314166789178437745D+2, &
             a2 = 1.9715909503065514427D+3, &
             a3 = 1.3731693765509461125D+4, &
             a4 = 4.5921953931549871457D+4, &
             a5 = 6.7265770927008700853D+4, &
             a6 = 3.3430575583588128105D+4, &
             a7 = 2.5090809287301226727D+3, &
             b1 = 4.2313330701600911252D+1, &
             b2 = 6.8718700749205790830D+2, &
             b3 = 5.3941960214247511077D+3, &
             b4 = 2.1213794301586595867D+4, &
             b5 = 3.9307895800092710610D+4, &
             b6 = 2.8729085735721942674D+4, &
             b7 = 5.2264952788528545610D+3
! HASH SUM AB    55.8831928806149014439

! Coefficients for P not close to 0, 0.5 or 1.

REAL (dp) :: c0 = 1.42343711074968357734D0, &
             c1 = 4.63033784615654529590D0, &
             c2 = 5.76949722146069140550D0, &
             c3 = 3.64784832476320460504D0, &
             c4 = 1.27045825245236838258D0, &
             c5 = 2.41780725177450611770D-1, &
             c6 = 2.27238449892691845833D-2, &
             c7 = 7.74545014278341407640D-4, &
             d1 = 2.05319162663775882187D0, &
             d2 = 1.67638483018380384940D0, &
             d3 = 6.89767334985100004550D-1, &
             d4 = 1.48103976427480074590D-1, &
             d5 = 1.51986665636164571966D-2, &
             d6 = 5.47593808499534494600D-4, &
             d7 = 1.05075007164441684324D-9
! HASH SUM CD    49.33206503301610289036

! Coefficients for P near 0 or 1.

REAL (dp) :: e0 = 6.65790464350110377720D0, &
             e1 = 5.46378491116411436990D0, &
             e2 = 1.78482653991729133580D0, &
             e3 = 2.96560571828504891230D-1, &
             e4 = 2.65321895265761230930D-2, &
             e5 = 1.24266094738807843860D-3, &
             e6 = 2.71155556874348757815D-5, &
             e7 = 2.01033439929228813265D-7, &
             f1 = 5.99832206555887937690D-1, &
             f2 = 1.36929880922735805310D-1, &
             f3 = 1.48753612908506148525D-2, &
             f4 = 7.86869131145613259100D-4, &
             f5 = 1.84631831751005468180D-5, &
             f6 = 1.42151175831644588870D-7, &
             f7 = 2.04426310338993978564D-15
! HASH SUM EF    47.52583317549289671629

ifault = 0
q = p - half
IF (ABS(q) <= split1) THEN
  r = const1 - q * q
  normal_dev = q * (((((((a7*r + a6)*r + a5)*r + a4)*r + a3)*r + a2)*r + a1)*r + a0) / &
           (((((((b7*r + b6)*r + b5)*r + b4)*r + b3)*r + b2)*r + b1)*r + one)
  RETURN
ELSE
  IF (q < zero) THEN
    r = p
  ELSE
    r = one - p
  END IF
  IF (r <= zero) THEN
    ifault = 1
    normal_dev = zero
    RETURN
  END IF
  r = SQRT(-LOG(r))
  IF (r <= split2) THEN
    r = r - const2
    normal_dev = (((((((c7*r + c6)*r + c5)*r + c4)*r + c3)*r + c2)*r + c1)*r + c0) / &
             (((((((d7*r + d6)*r + d5)*r + d4)*r + d3)*r + d2)*r + d1)*r + one)
  ELSE
    r = r - split2
    normal_dev = (((((((e7*r + e6)*r + e5)*r + e4)*r + e3)*r + e2)*r + e1)*r + e0) / &
             (((((((f7*r + f6)*r + f5)*r + f4)*r + f3)*r + f2)*r + f1)*r + one)
  END IF
  IF (q < zero) normal_dev = - normal_dev
  RETURN
END IF
END SUBROUTINE ppnd16


c     DRMATPR
c>> 2006-04-02 DRMATPR Krogh Added checks with exponents.
c>> 2001-05-22 DRMATPR Krogh Minor change for making .f90 version.
c>> 1991-11-22 DRMATPR  Krogh Initial Code.
c
      integer LWIDTH, LUNIT, NUMDIG, M, N, I, J
      parameter (LWIDTH=79)
      parameter (LUNIT=0)
      parameter (NUMDIG = 0)
      parameter (M = 4)
      parameter (N = 3)
c
      integer A(M,N)
      real B(M,N)
      double precision C1(M,N), C2(M,N), C3(M,N)
c
      data ((A(I,J),J=1,N),I=1,M) / 1,2,3,4,5,6,7,8,9,10,11,12 /
      data ((B(I,J),J=1,N),I=1,M) / 1.,2.,3.,4.,5.,6.,7.,8.,9.,
     *                              10.,11.,12. /
      data ((C1(I,J),J=1,N),I=1,M) / 1.D0,2.D0,3.D0,4.D0,5.D0,
     *                              6.D0,7.D0,8.D0,9.D0,10.D0,
     *                              11.D0,12.D0 /
      data ((C2(I,J),J=1,N),I=1,M) / 1.D0,2.D0,3.D0,4.D0,5.D0,
     *                              6.D0,7.D0,8.D99,9.D0,10.D0,
     *                              -11.D0,12.D0 /
      data ((C3(I,J),J=1,N),I=1,M) / 1.D0,2.D0,3.D0,4.D0,5.D0,
     *                              6.D0,7.D0,8.D123,9.D0,10.D0,
     *                              11.D0,12.D0 /
c
      call IMATPR (A,M,M,N,'0 IMATPR.. A(,)=', LWIDTH, LUNIT)
      call SMATPR (B,M,M,N,'0 SMATPR.. B(,)=', LWIDTH, LUNIT, NUMDIG)
      call DMATPR (C1,M,M,N,'0 DMATPR.. C1(,)=', LWIDTH, LUNIT, NUMDIG)
      call DMATPR (C2,M,M,N,'0 DMATPR.. C2(,)=', LWIDTH, LUNIT, NUMDIG)
      call DMATPR (C3,M,M,N,'0 DMATPR.. C3(,)=', LWIDTH, LUNIT, NUMDIG)
      stop
c
      end


! This test was created from /home/xr3/gitrepos/exercism/problem-specifications/exercises/difference-of-squares/canonical-data.json
! version: 1.2.0
!

program difference_of_squares_test_main
  use TesterMain
  use difference_of_squares
  implicit none

  ! Test 1: square of sum 1
  call assert_equal(1, square_of_sum(1), "square of sum 1")
  ! Test 2: square of sum 5
  call assert_equal(225, square_of_sum(5), "square of sum 5")
  ! Test 3: square of sum 100
  call assert_equal(25502500, square_of_sum(100), "square of sum 100")
  ! Test 1: sum of squares 1
  call assert_equal(1, sum_of_squares(1), "sum of squares 1")
  ! Test 2: sum of squares 5
  call assert_equal(55, sum_of_squares(5), "sum of squares 5")
  ! Test 3: sum of squares 100
  call assert_equal(338350, sum_of_squares(100), "sum of squares 100")
  ! Test 1: difference of squares 1
  call assert_equal(0, difference(1), "difference of squares 1")
  ! Test 2: difference of squares 5
  call assert_equal(170, difference(5), "difference of squares 5")
  ! Test 3: difference of squares 100
  call assert_equal(25164150, difference(100), "difference of squares 100")

  call test_report()

end program


program gsl_quad
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env, only : error_unit
    use :: functions_mod, only : func
    implicit none
    type, bind(C) :: gsl_function_t
        type(c_funptr) :: function
        type(c_ptr) :: params
    end type gsl_function_t
    interface
        function gsl_integration_workspace_alloc(ws_size) result(ws_ptr) bind(C)
            use, intrinsic :: iso_c_binding
            implicit none
            integer(kind=c_size_t), value :: ws_size
            type(c_ptr) :: ws_ptr
        end function gsl_integration_workspace_alloc
    end interface
    interface
        subroutine gsl_integration_workspace_free(ws_ptr) bind(C)
            use, intrinsic :: iso_c_binding
            implicit none
            type(c_ptr), value :: ws_ptr
        end subroutine gsl_integration_workspace_free
    end interface
    interface
        function gsl_integration_qag(f, a, b, epsabs, epsrel, limit, key, &
                                     workspace, result, abserr) result(istat) bind(C)
            use, intrinsic :: iso_c_binding
            implicit none
            type(c_ptr), value :: f
            real(kind=c_double), value :: a, b, epsabs, epsrel
            integer(kind=c_size_t), value :: limit
            integer(kind=c_int) :: key
            type(c_ptr), value :: workspace
            type(c_ptr), value :: result, abserr
            integer(kind=c_int) :: istat
        end function gsl_integration_qag
    end interface
    real(kind=c_double), dimension(3), target :: params
    type(gsl_function_t), target :: gsl_function
    integer(kind=c_size_t), parameter :: ws_size = 1000
    type(c_ptr) :: ws_ptr
    real(kind=c_double), parameter :: a = -2.0, b = 2.0, epsabs = 0.0, epsrel = 1.0e-7
    integer(kind=c_size_t), parameter :: limit = ws_size
    integer(Kind=c_int), parameter :: key = 5
    real(kind=c_double), target :: result, abserr
    integer(kind=c_int) :: istat

    ! initialize GSL function
    gsl_function%function = c_funloc(func)
    gsl_function%params = c_loc(params)

    ! initialize function parameters
    params = [ 1.0, -2.0, 3.0 ]

    ! create integration workspace
    ws_ptr = gsl_integration_workspace_alloc(ws_size)
    if (.not. c_associated(ws_ptr)) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate workspace'
        stop 1
    end if

    ! perform integration
    istat = gsl_integration_qag(c_loc(gsl_function), a, b, epsabs, epsrel, limit, key, &
                                ws_ptr, c_loc(result), c_loc(abserr))

    ! print result and error
    print '(2(A, E16.7))', 'result = ', result, ', abserr = ', abserr

    ! free integration workspace
    call gsl_integration_workspace_free(ws_ptr)

end program gsl_quad


!
!     -------------------------------------------------------------
!      S I X J 4
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
!                                                                  *
!     | JC/2  JE/2  JD/2 |                                         *
!     | JB/2  JF/2    4  |                                         *
!                                                                  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
!
      SUBROUTINE SIXJ4(JC, JE, JD, JB, JF, ITIK, SI)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:06:26  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ixjtik_I
      USE gracah1_I
      USE sixj2_I
      USE sixj3_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: JC
      INTEGER  :: JE
      INTEGER  :: JD
      INTEGER  :: JB
      INTEGER  :: JF
      INTEGER , INTENT(IN) :: ITIK
      REAL(DOUBLE)  :: SI
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(DOUBLE) :: A, C, E, D, B, F, X1, X2, X3, S2, S3
!-----------------------------------------------
      SI = ZERO
      IF (ITIK /= 0) THEN
!
!     CHESKED TRIANGULAR CONDITIONS
!
         IF (IXJTIK(JC,JE,JD,JB,JF,8) == 0) RETURN
      ENDIF
      IF (IXJTIK(JC,JE,JD,JB,JF,6) == 0) THEN
         CALL GRACAH1 (JC, JE, JF, JB, JD, 8, SI)
         IF (MOD(JC + JE + JF + JB,4) /= 0) SI = -SI
      ELSE
         A = THREE
         C = DBLE(JC)*HALF
         E = DBLE(JE)*HALF
         D = DBLE(JD)*HALF
         B = DBLE(JB)*HALF
         F = DBLE(JF)*HALF
         X1 = A*DSQRT((A + B + E + TWO)*(A - B + E + ONE)*(A + B - E + ONE)*((-&
            A) + B + E)*(A + C + F + TWO)*(A - C + F + ONE)*(A + C - F + ONE)*(&
            (-A) + C + F))
         X2 = (A + ONE)*DSQRT((A + B + E + ONE)*(A - B + E)*(A + B - E)*((-A)&
             + B + E + ONE)*(A + C + F + ONE)*(A - C + F)*(A + C - F)*((-A) + C&
             + F + ONE))
         X3 = (TWO*A + ONE)*(TWO*(A*(A + ONE)*D*(D + ONE) - B*(B + ONE)*C*(C + &
            ONE) - E*(E + ONE)*F*(F + ONE)) + (A*(A + ONE) - B*(B + ONE) - E*(E&
             + ONE))*(A*(A + ONE) - C*(C + ONE) - F*(F + ONE)))
         IF (DABS(X2) < EPS) THEN
            S2 = ZERO
         ELSE
            CALL SIXJ2 (JC, JE, JD, JB, JF, 0, S2)
         ENDIF
         IF (DABS(X3) < EPS) THEN
            S3 = ZERO
         ELSE
            CALL SIXJ3 (JC, JE, JD, JB, JF, 0, S3)
         ENDIF
         SI = (X3*S3 - X2*S2)/X1
      ENDIF
      RETURN
      END SUBROUTINE SIXJ4


!==========================================================================
elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, &
                                                    v_p, iflag)
! =========================================================================
!
!  Calculates three first-order derivatives of specific volume (v).
!  Note that this function uses the computationally-efficient
!  expression for specific volume (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  v_SA  =  The first derivative of specific volume with respect to
!           Absolute Salinity at constant CT & p.       [ J/(kg (g/kg)^2) ]
!  v_CT  =  The first derivative of specific volume with respect to
!           CT at constant SA and p.                     [ J/(kg K(g/kg)) ]
!  v_P   =  The first derivative of specific volume with respect to
!           P at constant SA and CT.                         [ J/(kg K^2) ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
integer, intent(in), optional :: iflag
real (r8), intent(out), optional :: v_sa, v_ct, v_p

integer :: i
logical :: flags(3)
real (r8) :: v_ct_part, v_p_part, v_sa_part, xs, ys, z

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

if (present(iflag)) then
    do i = 1, 3
        flags(i) = btest(iflag,i)
    end do
else
    flags = .true.
end if

if (present(v_sa) .and. flags(1)) then

    v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) &
           + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) &
           + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 &
           + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) &
           + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) &
           + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 &
           + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) &
           + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 &
           + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) &
           + z*(b003 +  b103*xs + b013*ys + b004*z)))

    v_sa = 0.5_r8*gsw_sfac*v_sa_part/xs

end if

if (present(v_ct) .and. flags(2)) then

    v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) &
             + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) &
             + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 &
             + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) &
             + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) &
             + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 &
             + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) &
             + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 &
             + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) &
             + z*(a003 + a103*xs + a013*ys + a004*z)))

    v_ct = 0.025_r8*v_ct_part

end if

if (present(v_p) .and. flags(3)) then

    v_p_part = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) &
        + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 &
        + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) &
        + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 &
        + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) &
        + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) &
        + z*( c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) &
        + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z))))

    v_p = 1e-8_r8*v_p_part

end if

return
end subroutine

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


!*==slags2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such that the rows of the transformed A and B are parallel.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAGS2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
!                          SNV, CSQ, SNQ )
!
!       .. Scalar Arguments ..
!       LOGICAL            UPPER
!       REAL               A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
!      $                   SNU, SNV
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
!> that if ( UPPER ) then
!>
!>           U**T *A*Q = U**T *( A1 A2 )*Q = ( x  0  )
!>                             ( 0  A3 )     ( x  x  )
!> and
!>           V**T*B*Q = V**T *( B1 B2 )*Q = ( x  0  )
!>                            ( 0  B3 )     ( x  x  )
!>
!> or if ( .NOT.UPPER ) then
!>
!>           U**T *A*Q = U**T *( A1 0  )*Q = ( x  x  )
!>                             ( A2 A3 )     ( 0  x  )
!> and
!>           V**T*B*Q = V**T*( B1 0  )*Q = ( x  x  )
!>                           ( B2 B3 )     ( 0  x  )
!>
!> The rows of the transformed A and B are parallel, where
!>
!>   U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
!>       ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
!>
!> Z**T denotes the transpose of Z.
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPPER
!> \verbatim
!>          UPPER is LOGICAL
!>          = .TRUE.: the input matrices A and B are upper triangular.
!>          = .FALSE.: the input matrices A and B are lower triangular.
!> \endverbatim
!>
!> \param[in] A1
!> \verbatim
!>          A1 is REAL
!> \endverbatim
!>
!> \param[in] A2
!> \verbatim
!>          A2 is REAL
!> \endverbatim
!>
!> \param[in] A3
!> \verbatim
!>          A3 is REAL
!>          On entry, A1, A2 and A3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix A.
!> \endverbatim
!>
!> \param[in] B1
!> \verbatim
!>          B1 is REAL
!> \endverbatim
!>
!> \param[in] B2
!> \verbatim
!>          B2 is REAL
!> \endverbatim
!>
!> \param[in] B3
!> \verbatim
!>          B3 is REAL
!>          On entry, B1, B2 and B3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix B.
!> \endverbatim
!>
!> \param[out] CSU
!> \verbatim
!>          CSU is REAL
!> \endverbatim
!>
!> \param[out] SNU
!> \verbatim
!>          SNU is REAL
!>          The desired orthogonal matrix U.
!> \endverbatim
!>
!> \param[out] CSV
!> \verbatim
!>          CSV is REAL
!> \endverbatim
!>
!> \param[out] SNV
!> \verbatim
!>          SNV is REAL
!>          The desired orthogonal matrix V.
!> \endverbatim
!>
!> \param[out] CSQ
!> \verbatim
!>          CSQ is REAL
!> \endverbatim
!>
!> \param[out] SNQ
!> \verbatim
!>          SNQ is REAL
!>          The desired orthogonal matrix Q.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE SLAGS2(Upper,A1,A2,A3,B1,B2,B3,Csu,Snu,Csv,Snv,Csq,Snq)
      IMPLICIT NONE
!*--SLAGS2155
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      LOGICAL Upper
      REAL A1 , A2 , A3 , B1 , B2 , B3 , Csq , Csu , Csv , Snq , Snu ,  &
     &     Snv
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      REAL a , aua11 , aua12 , aua21 , aua22 , avb11 , avb12 , avb21 ,  &
     &     avb22 , csl , csr , d , s1 , s2 , snl , snr , ua11r , ua22r ,&
     &     vb11r , vb22r , b , c , r , ua11 , ua12 , ua21 , ua22 ,      &
     &     vb11 , vb12 , vb21 , vb22
!     ..
!     .. External Subroutines ..
      EXTERNAL SLARTG , SLASV2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     ..
!     .. Executable Statements ..
!
      IF ( Upper ) THEN
!
!        Input matrices A and B are upper triangular matrices
!
!        Form matrix C = A*adj(B) = ( a b )
!                                   ( 0 d )
!
         a = A1*B3
         d = A3*B1
         b = A2*B1 - A1*B2
!
!        The SVD of real 2-by-2 triangular C
!
!         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
!         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
!
         CALL SLASV2(a,b,d,s1,s2,snr,csr,snl,csl)
!
         IF ( ABS(csl)>=ABS(snl) .OR. ABS(csr)>=ABS(snr) ) THEN
!
!           Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
!           and (1,2) element of |U|**T *|A| and |V|**T *|B|.
!
            ua11r = csl*A1
            ua12 = csl*A2 + snl*A3
!
            vb11r = csr*B1
            vb12 = csr*B2 + snr*B3
!
            aua12 = ABS(csl)*ABS(A2) + ABS(snl)*ABS(A3)
            avb12 = ABS(csr)*ABS(B2) + ABS(snr)*ABS(B3)
!
!           zero (1,2) elements of U**T *A and V**T *B
!
            IF ( (ABS(ua11r)+ABS(ua12))==ZERO ) THEN
               CALL SLARTG(-vb11r,vb12,Csq,Snq,r)
            ELSEIF ( aua12/(ABS(ua11r)+ABS(ua12))                       &
     &               <=avb12/(ABS(vb11r)+ABS(vb12)) ) THEN
               CALL SLARTG(-ua11r,ua12,Csq,Snq,r)
            ELSE
               CALL SLARTG(-vb11r,vb12,Csq,Snq,r)
            ENDIF
!
            Csu = csl
            Snu = -snl
            Csv = csr
            Snv = -snr
!
         ELSE
!
!           Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
!           and (2,2) element of |U|**T *|A| and |V|**T *|B|.
!
            ua21 = -snl*A1
            ua22 = -snl*A2 + csl*A3
!
            vb21 = -snr*B1
            vb22 = -snr*B2 + csr*B3
!
            aua22 = ABS(snl)*ABS(A2) + ABS(csl)*ABS(A3)
            avb22 = ABS(snr)*ABS(B2) + ABS(csr)*ABS(B3)
!
!           zero (2,2) elements of U**T*A and V**T*B, and then swap.
!
            IF ( (ABS(ua21)+ABS(ua22))==ZERO ) THEN
               CALL SLARTG(-vb21,vb22,Csq,Snq,r)
            ELSEIF ( aua22/(ABS(ua21)+ABS(ua22))                        &
     &               <=avb22/(ABS(vb21)+ABS(vb22)) ) THEN
               CALL SLARTG(-ua21,ua22,Csq,Snq,r)
            ELSE
               CALL SLARTG(-vb21,vb22,Csq,Snq,r)
            ENDIF
!
            Csu = snl
            Snu = csl
            Csv = snr
            Snv = csr
!
         ENDIF
!
      ELSE
!
!        Input matrices A and B are lower triangular matrices
!
!        Form matrix C = A*adj(B) = ( a 0 )
!                                   ( c d )
!
         a = A1*B3
         d = A3*B1
         c = A2*B3 - A3*B2
!
!        The SVD of real 2-by-2 triangular C
!
!         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
!         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
!
         CALL SLASV2(a,c,d,s1,s2,snr,csr,snl,csl)
!
         IF ( ABS(csr)>=ABS(snr) .OR. ABS(csl)>=ABS(snl) ) THEN
!
!           Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
!           and (2,1) element of |U|**T *|A| and |V|**T *|B|.
!
            ua21 = -snr*A1 + csr*A2
            ua22r = csr*A3
!
            vb21 = -snl*B1 + csl*B2
            vb22r = csl*B3
!
            aua21 = ABS(snr)*ABS(A1) + ABS(csr)*ABS(A2)
            avb21 = ABS(snl)*ABS(B1) + ABS(csl)*ABS(B2)
!
!           zero (2,1) elements of U**T *A and V**T *B.
!
            IF ( (ABS(ua21)+ABS(ua22r))==ZERO ) THEN
               CALL SLARTG(vb22r,vb21,Csq,Snq,r)
            ELSEIF ( aua21/(ABS(ua21)+ABS(ua22r))                       &
     &               <=avb21/(ABS(vb21)+ABS(vb22r)) ) THEN
               CALL SLARTG(ua22r,ua21,Csq,Snq,r)
            ELSE
               CALL SLARTG(vb22r,vb21,Csq,Snq,r)
            ENDIF
!
            Csu = csr
            Snu = -snr
            Csv = csl
            Snv = -snl
!
         ELSE
!
!           Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
!           and (1,1) element of |U|**T *|A| and |V|**T *|B|.
!
            ua11 = csr*A1 + snr*A2
            ua12 = snr*A3
!
            vb11 = csl*B1 + snl*B2
            vb12 = snl*B3
!
            aua11 = ABS(csr)*ABS(A1) + ABS(snr)*ABS(A2)
            avb11 = ABS(csl)*ABS(B1) + ABS(snl)*ABS(B2)
!
!           zero (1,1) elements of U**T*A and V**T*B, and then swap.
!
            IF ( (ABS(ua11)+ABS(ua12))==ZERO ) THEN
               CALL SLARTG(vb12,vb11,Csq,Snq,r)
            ELSEIF ( aua11/(ABS(ua11)+ABS(ua12))                        &
     &               <=avb11/(ABS(vb11)+ABS(vb12)) ) THEN
               CALL SLARTG(ua12,ua11,Csq,Snq,r)
            ELSE
               CALL SLARTG(vb12,vb11,Csq,Snq,r)
            ENDIF
!
            Csu = snr
            Snu = csr
            Csv = snl
            Snv = csl
!
         ENDIF
!
      ENDIF
!
!
!     End of SLAGS2
!
      END SUBROUTINE SLAGS2


 module module_tropopause
      implicit none
      private
      public :: tropopause_init
      public :: tropopause_driver
      save
      integer, parameter :: r8 = selected_real_kind(12)
      real(r8), parameter :: pi =3.14159265358979323846_r8
      real(r8), parameter :: mb2Pa = 100._r8
      real(r8), parameter :: d2r = pi/180._r8
      real(r8), parameter :: zero = 0._r8
      real(r8), parameter :: twopi = pi*2._r8
      integer, parameter :: NOTFOUND = -1
      integer :: iend
      integer :: jend
      integer :: tropo_month_n
      integer :: tropo_lon_n
      integer :: tropo_lat_n
      type tropo_type
          real(r8), pointer :: tropo_p_loc(:,:,:)
          logical :: is_allocated
      end type tropo_type
      type(tropo_type), allocatable :: tropo_bc(:)
      real(r8),parameter :: CONST_BOLTZ = 1.38065e-23_r8
      real(r8),parameter :: CONST_AVOGAD = 6.02214e26_r8
      real(r8),parameter :: CONST_RGAS = CONST_AVOGAD*CONST_BOLTZ
      real(r8),parameter :: CONST_MWDAIR = 28.966_r8
      real(r8),parameter :: CONST_RDAIR = CONST_RGAS/CONST_MWDAIR
      real(r8),parameter :: CONST_CPDAIR = 1.00464e3_r8
      real(r8),parameter :: gravit = 9.80616_r8
      real(r8),parameter :: rair = CONST_RDAIR
      real(r8),parameter :: cappa = CONST_RDAIR/CONST_CPDAIR
      real(r8),parameter :: cnst_kap = cappa
      real(r8),parameter :: cnst_faktor = -gravit/rair
      real(r8),parameter :: cnst_ka1 = cnst_kap - 1._r8
      contains
      subroutine tropopause_driver( id, dtstep, current_date_char, &
                                    t_phy, p_phy, p8w, zmid, z8w, &
                                    tropo_lev, tropo_p, tropo_z, &
                                    ids, ide, jds, jde, kds, kde, &
                                    ims, ime, jms, jme, kms, kme, &
                                    its, ite, jts, jte, kts, kte )
      implicit none
      integer, intent(in ) :: id, &
                                ids,ide, jds,jde, kds,kde, &
                                ims,ime, jms,jme, kms,kme, &
                                its,ite, jts,jte, kts,kte
      real, intent(in ) :: dtstep
      real, dimension( ims:ime, kms:kme, jms:jme ), &
               intent(in ) :: t_phy, &
                                p_phy, &
                                zmid, &
                                z8w, &
                                p8w
      real, dimension( ims:ime, jms:jme ), &
               intent(inout) :: tropo_p, &
                                tropo_z
      integer, dimension( ims:ime, jms:jme ), &
               intent(inout) :: tropo_lev
      CHARACTER (LEN=256),intent(in) :: current_date_char
      integer :: i, j, k
      iend = min(ite,ide-1)
      jend = min(jte,jde-1)
      tropo_lev(its:iend,jts:jend) = NOTFOUND
      call tropopause_twmo (id, t_phy, p_phy, p8w, zmid, z8w, &
                            tropo_lev, tropo_p, tropo_z, &
                            ids,ide, jds,jde, kds,kde, &
                            ims,ime, jms,jme, kms,kme, &
                            its,ite, jts,jte, kts,kte )
      if ( any(tropo_lev(its:iend,jts:jend) == NOTFOUND) ) then
         call tropopause_climate (id, current_date_char, &
                                  p_phy, p8w, zmid, z8w, &
                                  tropo_lev, tropo_p, tropo_z, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte )
      end if
   end subroutine tropopause_driver
      subroutine tropopause_init (id, xlat, xlon, config_flags, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte )
      use module_interpolate, only : lininterp_init, lininterp, interp_type, lininterp_finish
      use module_configure, only : grid_config_rec_type
      implicit none
      integer, intent(in) :: id, &
                             ids,ide, jds,jde, kds,kde, &
                             ims,ime, jms,jme, kms,kme, &
                             its,ite, jts,jte, kts,kte
      real, intent(in) :: xlat(ims:ime, jms:jme)
      real, intent(in) :: xlon(ims:ime, jms:jme)
      type(grid_config_rec_type), intent(in) :: config_flags
      type(interp_type) :: lon_wgts, lat_wgts
      integer :: max_dom
      integer :: astat
      integer :: ncid
      integer :: varid
      integer :: dimid(3)
      integer :: start(3)
      integer :: count(3)
      integer :: dimid_lon
      integer :: dimid_lat
      integer :: dimid_month
      integer :: ndims
      character(len=128) :: err_msg
      character(len=64) :: filename
      character(len=3) :: id_num
      character(len=80) :: attribute
      real(r8), allocatable :: tropo_p_in(:,:,:)
      real(r8), allocatable :: tropo_lat(:)
      real(r8), allocatable :: tropo_lon(:)
      real(r8) :: wrf_lon(1)
      real(r8) :: wrf_lat(1)
      real(r8) :: tmp_out(1)
      integer :: i, j, m
      CHARACTER(LEN=132) :: message
      LOGICAL , EXTERNAL :: wrf_dm_on_monitor
include 'netcdf.inc'
      iend = min(ite,ide-1)
      jend = min(jte,jde-1)
   if( id == 1 .and. .not. allocated(tropo_bc) ) then
       CALL nl_get_max_dom( 1,max_dom )
       allocate(tropo_bc(max_dom),stat=astat )
       if( astat /= 0 ) then
          CALL wrf_message( 'tropopause_init: failed to allocate tropo_bc' )
          CALL wrf_abort
       end if
       tropo_bc(:)%is_allocated = .false.
  endif
tropo_bc_allocated : &
  if( .not. tropo_bc(id)%is_allocated ) then
master_proc : &
   IF( wrf_dm_on_monitor() ) THEN
      write(id_num,'(i3)') 100+id
      write(message,*) 'tropopause_init: intializing domain ' // id_num(2:3)
      call wrf_message( trim(message) )
      filename = config_flags%trop_lev_inname
      if( filename == ' ' ) then
        call wrf_message( 'tropopause_init: input filename not specified in namelist' )
        call wrf_abort
      endif
      err_msg = 'tropopause_init: failed to open file ' // trim(filename)
      call handle_ncerr( nf_open( trim(filename), nf_noclobber, ncid ), trim(err_msg) )
      write(message,*) 'tropopause_init: open filename= ',filename
      call wrf_message( trim(message) )
      err_msg = 'tropopause_init: failed to get time id'
      call handle_ncerr( nf_inq_dimid( ncid, 'time', dimid_month ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to get time'
      call handle_ncerr( nf_inq_dimlen( ncid, dimid_month, tropo_month_n ), trim(err_msg) )
      if( tropo_month_n /= 12 )then
       write(message,*) 'tropopause_init: number of months = ',tropo_month_n,'; expecting 12'
       call wrf_message( trim(message) )
       call wrf_abort
      end if
      err_msg = 'tropopause_init: failed to get lat id'
      call handle_ncerr( nf_inq_dimid( ncid, 'lat', dimid_lat ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to get lat'
      call handle_ncerr( nf_inq_dimlen( ncid, dimid_lat, tropo_lat_n ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to get lon id'
      call handle_ncerr( nf_inq_dimid( ncid, 'lon', dimid_lon ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to get lon'
      call handle_ncerr( nf_inq_dimlen( ncid, dimid_lon, tropo_lon_n ), trim(err_msg) )
   END IF master_proc
      CALL wrf_dm_bcast_integer ( tropo_month_n , 1 )
      CALL wrf_dm_bcast_integer ( tropo_lat_n , 1 )
      CALL wrf_dm_bcast_integer ( tropo_lon_n , 1 )
      allocate( tropo_lat(tropo_lat_n), stat=astat )
      if( astat /= 0 ) then
         call wrf_message( 'tropopause_init: failed to allocate tropo_lat' )
         call wrf_abort
      end if
      allocate( tropo_lon(tropo_lon_n), stat=astat )
      if( astat /= 0 ) then
         call wrf_message( 'tropopause_init: failed to allocate tropo_lon' )
         call wrf_abort
      end if
      allocate( tropo_p_in(tropo_lon_n,tropo_lat_n,tropo_month_n), stat=astat )
      if( astat /= 0 ) then
         call wrf_message( 'tropopause_init: failed to allocate tropo_p_in' )
         call wrf_abort
      end if
      allocate( tropo_bc(id)%tropo_p_loc(its:iend,jts:jend,tropo_month_n), stat=astat )
      if( astat /= 0 ) then
         call wrf_message( 'tropopause_init: failed to allocate tropo_bc(id)%tropo_p_loc' )
         call wrf_abort
      end if
      tropo_bc(id)%is_allocated = .true.
master_proc_a : &
   IF ( wrf_dm_on_monitor() ) THEN
      err_msg = 'tropopause_init: failed to get lat variable id'
      call handle_ncerr( nf_inq_varid( ncid, 'lat', varid ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to read lat variable'
      call handle_ncerr( nf_get_var_double( ncid, varid, tropo_lat ), trim(err_msg) )
     tropo_lat(:) = tropo_lat(:) * d2r
      err_msg = 'tropopause_init: failed to get lon variable id'
      call handle_ncerr( nf_inq_varid( ncid, 'lon', varid ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to read lon variable'
      call handle_ncerr( nf_get_var_double( ncid, varid, tropo_lon ), trim(err_msg) )
      tropo_lon(:) = tropo_lon(:) * d2r
      err_msg = 'tropopause_init: failed to get trop_p variable id'
      call handle_ncerr( nf_inq_varid( ncid, 'trop_p', varid ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to get ndims of trop_p variable'
      call handle_ncerr( nf_inq_varndims( ncid, varid, ndims ), trim(err_msg) )
      if( ndims /= 3 ) then
         write(message,*) 'tropopause_init: error! variable trop_p has ndims = ',ndims,', expecting 3'
         call wrf_message( trim(message) )
         call wrf_abort
      end if
      err_msg = 'tropopause_init: failed to get dimid of vmr variable'
      call handle_ncerr( nf_inq_vardimid( ncid, varid, dimid ), trim(err_msg) )
      if( dimid(1) /= dimid_lon .or. dimid(2) /= dimid_lat .or. &
          dimid(3) /= dimid_month )then
          write(message,*) 'tropopause_init: error! dimensions in wrong order for variable trop_p,'// &
               'expecting (lon,lat,month)'
          call wrf_message( trim(message) )
          call wrf_abort
      end if
      err_msg = 'tropopause_init: failed to read trop_p variable'
      call handle_ncerr( nf_get_var_double( ncid, varid, tropo_p_in ), trim(err_msg) )
      err_msg = 'tropopause_init: failed to close file ' // trim(filename)
      call handle_ncerr( nf_close( ncid ), trim(err_msg) )
   END IF master_proc_a
      CALL wrf_dm_bcast_double ( tropo_lat, size(tropo_lat) )
      CALL wrf_dm_bcast_double ( tropo_lon, size(tropo_lon) )
      CALL wrf_dm_bcast_double ( tropo_p_in, size(tropo_p_in) )
      do i = its,iend
        do j = jts,jend
          wrf_lat(1) = xlat(i,j)*d2r
          wrf_lon(1) = xlon(i,j)
          if( wrf_lon(1) < 0.0_r8 ) wrf_lon(1) = wrf_lon(1) + 360.0_r8
          wrf_lon(1) = wrf_lon(1)*d2r
          call lininterp_init( tropo_lon, tropo_lon_n, wrf_lon, 1, 2, lon_wgts, zero, twopi )
          call lininterp_init( tropo_lat, tropo_lat_n, wrf_lat, 1, 1, lat_wgts )
          do m = 1,tropo_month_n
            call lininterp( tropo_p_in(:,:,m), tropo_lon_n, tropo_lat_n, &
                            tmp_out, 1 , lon_wgts, lat_wgts)
            tropo_bc(id)%tropo_p_loc(i,j,m) = tmp_out(1)
          end do
        end do
      end do
      call lininterp_finish( lon_wgts )
      call lininterp_finish( lat_wgts )
      deallocate(tropo_lon)
      deallocate(tropo_lat)
      deallocate(tropo_p_in)
      call wrf_message( ' ' )
      write(message,*) 'tropopause_init: DONE intialized domain ',id
      call wrf_message( trim(message) )
      call wrf_message( ' ' )
endif tropo_bc_allocated
      end subroutine tropopause_init
      subroutine handle_ncerr( ret, mes )
      implicit none
      integer, intent(in) :: ret
      character(len=*), intent(in) :: mes
include 'netcdf.inc'
      if( ret /= nf_noerr ) then
         call wrf_message( trim(mes) )
         call wrf_message( trim(nf_strerror(ret)) )
         call wrf_abort
      end if
      end subroutine handle_ncerr
  subroutine tropopause_twmo (id, t_phy, p_phy, p8w, zmid, z8w, &
                              tropo_lev, tropo_p,tropo_z, &
                              ids,ide, jds,jde, kds,kde, &
                              ims,ime, jms,jme, kms,kme, &
                              its,ite, jts,jte, kts,kte )
      implicit none
      integer, intent(in) :: id, &
                             ids,ide, jds,jde, kds,kde, &
                             ims,ime, jms,jme, kms,kme, &
                             its,ite, jts,jte, kts,kte
      real, dimension( ims:ime , kms:kme , jms:jme ), &
            intent(in) :: t_phy, &
                             p_phy, &
                             zmid, &
                             z8w, &
                             p8w
      real, dimension( ims:ime, jms:jme ), &
               intent(inout) :: tropo_p, &
                                tropo_z
      integer, dimension( ims:ime, jms:jme ), &
               intent(inout) :: tropo_lev
    real, dimension( kts:kte) :: t_temp
    real, dimension( kts:kte) :: p_temp
    real(r8), parameter :: gamma = -0.002_r8
    real(r8), parameter :: plimu = 45000._r8
    real(r8), parameter :: pliml = 7500._r8
    integer :: i
    integer :: j
    integer :: k
    integer :: kk
    integer :: pLev
    real(r8) :: tP
    real(r8) :: dZdlogP
    pLev = kte - kts + 1
    do i = its,iend
    do j = jts,jend
       do k = kts,kte
          kk = pLev - k + 1
          t_temp(kk) = t_phy(i,k,j)
          p_temp(kk) = p_phy(i,k,j)
       end do
       call twmo(pLev, t_temp, p_temp, plimu, pliml, gamma, tP)
       if (tP > 0) then
          do k = kts,kte-1
             if (tP >= p8w(i,k,j)) then
                tropo_lev(i,j) = k - 1
                tropo_p (i,j) = tP
                exit
             end if
          end do
          k = k - 1
          if (tropo_p(i,j) == p_phy(i,k,j)) then
             tropo_z(i,j)= zmid(i,k,j)
          else if (tropo_p(i,j) < p_phy(i,k,j)) then
             if ( k > kts ) then
                dZdlogP = (zmid(i,k,j) - z8w(i,k-1,j)) / &
                          (log(p_phy(i,k,j)) - log(p8w(i,k-1,j)) )
                tropo_z(i,j)= zmid(i,k,j) + (log(tropo_p(i,j)) - log(p_phy(i,k,j))) * dZdlogP
             end if
          else
             if ( k < kte ) then
                dZdlogP = (zmid(i,k,j) - z8w(i,k,j)) / &
                          (log(p_phy(i,k,j)) - log(p8w(i,k,j)) )
                tropo_z(i,j)= zmid(i,k,j) + (log(tropo_p(i,j)) - log(p_phy(i,k,j))) * dZdlogP
             end if
          end if
       end if
    end do
    end do
  end subroutine tropopause_twmo
  subroutine twmo(level, t, p, plimu, pliml, gamma, trp)
    integer, intent(in) :: level
    real, intent(in), dimension(level) :: t, p
    real(r8), intent(in) :: plimu, pliml, gamma
    real(r8), intent(out) :: trp
    real(r8), parameter :: deltaz = 2000.0_r8
    real(r8) :: pmk, pm, a, b, tm, dtdp, dtdz
    real(r8) :: ag, bg, ptph
    real(r8) :: pm0, pmk0, dtdz0
    real(r8) :: p2km, asum, aquer
    real(r8) :: pmk2, pm2, a2, b2, tm2, dtdp2, dtdz2
    integer :: icount, jj
    integer :: j
    trp=-99.0_r8
lev_loop : &
    do j=level,2,-1
      pmk= .5_r8 * (p(j-1)**cnst_kap+p(j)**cnst_kap)
      pm = pmk**(1/cnst_kap)
      a = (t(j-1)-t(j))/(p(j-1)**cnst_kap-p(j)**cnst_kap)
      b = t(j)-(a*p(j)**cnst_kap)
      tm = a * pmk + b
      dtdp = a * cnst_kap * (pm**cnst_ka1)
      dtdz = cnst_faktor*dtdp*pm/tm
      if( j == level .or. dtdz <= gamma .or. pm > plimu ) then
        pm0 = pm
        pmk0 = pmk
        dtdz0 = dtdz
        cycle lev_loop
      endif
      if (dtdz0 < gamma) then
        ag = (dtdz-dtdz0) / (pmk-pmk0)
        bg = dtdz0 - (ag * pmk0)
        ptph = exp(log((gamma-bg)/ag)/cnst_kap)
      else
        ptph = pm
      endif
      if( ptph < pliml .or. ptph > plimu ) then
        pm0 = pm
        pmk0 = pmk
        dtdz0 = dtdz
        cycle lev_loop
      endif
      p2km = ptph + deltaz*(pm/tm)*cnst_faktor
      asum = 0.0_r8
      icount = 0
lev_loop_a : &
      do jj=j,2,-1
        pmk2 = .5_r8 * (p(jj-1)**cnst_kap+p(jj)**cnst_kap)
        pm2 = pmk2**(1/cnst_kap)
        if( pm2 > ptph ) then
          cycle lev_loop_a
        endif
        if( pm2 < p2km ) then
          trp = ptph
          exit lev_loop
        endif
        a2 = (t(jj-1)-t(jj))
        a2 = a2/(p(jj-1)**cnst_kap-p(jj)**cnst_kap)
        b2 = t(jj)-(a2*p(jj)**cnst_kap)
        tm2 = a2 * pmk2 + b2
        dtdp2 = a2 * cnst_kap * (pm2**(cnst_kap-1))
        dtdz2 = cnst_faktor*dtdp2*pm2/tm2
        asum = asum+dtdz2
        icount = icount+1
        aquer = asum/float(icount)
        if( aquer <= gamma ) then
          pm0 = pm
          pmk0 = pmk
          dtdz0 = dtdz
          exit lev_loop_a
        endif
      enddo lev_loop_a
    enddo lev_loop
  end subroutine twmo
  subroutine tropopause_climate (id, current_date_char, &
                                 p_phy, p8w, zmid, z8w, &
                                 tropo_lev, tropo_p, tropo_z, &
                                 ids,ide, jds,jde, kds,kde, &
                                 ims,ime, jms,jme, kms,kme, &
                                 its,ite, jts,jte, kts,kte )
      implicit none
      integer, intent(in) :: id, &
                             ids,ide, jds,jde, kds,kde, &
                             ims,ime, jms,jme, kms,kme, &
                             its,ite, jts,jte, kts,kte
      real, dimension( ims:ime , kms:kme , jms:jme ), &
            intent(in) :: p_phy, &
                             zmid, &
                             z8w, &
                             p8w
      real, dimension( ims:ime, jms:jme ), &
               intent(inout) :: tropo_p, &
                                tropo_z
      integer, dimension( ims:ime, jms:jme ), &
               intent(inout) :: tropo_lev
      CHARACTER (LEN=256),intent(in) :: current_date_char
    real :: del_time
    integer :: last
    integer :: next
    real(r8) :: tP
    real(r8) :: dZdlogP
    integer :: i
    integer :: j
    integer :: k
    CHARACTER(LEN=132) :: message
    if (any(tropo_lev(its:iend,jts:jend) == NOTFOUND)) then
       call get_time_interp_factors( current_date_char, last, next, del_time )
       do i = its,iend
       do j = jts,jend
          if (tropo_lev(i,j) == NOTFOUND) then
             tP = tropo_bc(id)%tropo_p_loc(i,j,last) &
                + (tropo_bc(id)%tropo_p_loc(i,j,next) &
                - tropo_bc(id)%tropo_p_loc(i,j,last))*del_time
             if (tP > 0) then
                do k = kts,kte-1
                   if (tP >= p8w(i,k,j)) then
                      tropo_lev(i,j) = k - 1
                      tropo_p (i,j) = tP
                      exit
                   end if
                end do
                k = k - 1
                if (tropo_p(i,j) == p_phy(i,k,j)) then
                   tropo_z(i,j)= zmid(i,k,j)
                else if (tropo_p(i,j) < p_phy(i,k,j)) then
                   if ( k > kts ) then
                      dZdlogP = (zmid(i,k,j) - z8w(i,k-1,j)) / &
                                (log(p_phy(i,k,j)) - log(p8w(i,k-1,j)) )
                      tropo_z(i,j)= zmid(i,k,j) + (log(tropo_p(i,j)) - log(p_phy(i,k,j))) * dZdlogP
                   end if
                else
                   if ( k < kte ) then
                      dZdlogP = (zmid(i,k,j) - z8w(i,k,j)) / &
                                (log(p_phy(i,k,j)) - log(p8w(i,k,j)) )
                      tropo_z(i,j)= zmid(i,k,j) + (log(tropo_p(i,j)) - log(p_phy(i,k,j))) * dZdlogP
                   end if
                end if
             end if
          end if
       end do
       end do
    end if
    if (any(tropo_lev(its:iend,jts:jend) == NOTFOUND)) then
       write(message,*) 'tropopause_climate: Warning: some tropopause levels still NOTFOUND'
    else
       write(message,*) 'tropopause_climate: Warning: Done finding tropopause'
    end if
    call wrf_message( trim(message) )
  end subroutine tropopause_climate
      subroutine get_time_interp_factors(current_date_char , last, next, del_time )
      use module_date_time, only : get_julgmt
      implicit none
      CHARACTER (LEN=256),intent(in) :: current_date_char
      integer, intent(out) :: next, last
      real, intent(out) :: del_time
      integer, parameter :: day_of_year(12) = (/ 16, 45, 75, 105, 136, 166, 197, &
                                                 228, 258, 289, 319, 350 /)
      integer :: julyr , julday
      real :: gmt
      real :: calday
      integer :: m
      call get_julgmt ( current_date_char, julyr, julday, gmt )
      calday = real(julday) + gmt
      if( calday < day_of_year(1) ) then
         next = 1
         last = 12
         del_time = (365. + calday - day_of_year(12)) &
                / (365. + day_of_year(1) - day_of_year(12))
      else if( calday >= day_of_year(12) ) then
         next = 1
         last = 12
         del_time = (calday - day_of_year(12)) &
                / (365. + day_of_year(1) - day_of_year(12))
      else
         do m = 11,1,-1
            if( calday >= day_of_year(m) ) then
               exit
            end if
         end do
         last = m
         next = m + 1
         del_time = (calday - day_of_year(m)) / (day_of_year(m+1) - day_of_year(m))
      end if
      del_time = max( min( 1.,del_time ),0. )
      end subroutine get_time_interp_factors
      end module module_tropopause


*> \brief \b DCABS1
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       DOUBLE PRECISION FUNCTION DCABS1(Z)
*
*       .. Scalar Arguments ..
*       COMPLEX*16 Z
*       ..
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] Z
*> \verbatim
*>          Z is COMPLEX*16
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_blas_level1
*
*  =====================================================================
      DOUBLE PRECISION FUNCTION DCABS1(Z)
*
*  -- Reference BLAS level1 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      COMPLEX*16 Z
*     ..
*     ..
*  =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC ABS,DBLE,DIMAG
*
      DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z))
      RETURN
      END


!
! gsstep
!

module gsstep
  implicit none
  public gsstep_fwd_shift_dense
  public gsstep_bwd_shift_dense
  public gsstep_fwd_shift_csr
  public gsstep_bwd_shift_csr
  public gsstep_fwd_shift_csc
  public gsstep_bwd_shift_csc
!!!
  public gsstep_fwd_shift_dense_mat
  public gsstep_bwd_shift_dense_mat
  public gsstep_fwd_shift_csr_mat
  public gsstep_bwd_shift_csr_mat
  public gsstep_fwd_shift_csc_mat
  public gsstep_bwd_shift_csc_mat
!!!
  private gsstep_fwd_shift_csr_notrans
  private gsstep_fwd_shift_csr_trans
  private gsstep_bwd_shift_csr_notrans
  private gsstep_bwd_shift_csr_trans

contains

! Kahan sum

  subroutine kahan_sum(sum, x, c)
    double precision, intent(in) :: x
    double precision, intent(inout) :: sum, c
    double precision :: t, y
    y = x - c
    t = sum + y
    c = (t - sum) - y
    sum = t
  end subroutine kahan_sum

!  SOR step for solving the following linear equation
!
!         alpha * trans(A - sigma I) * x = b
!
!         The step computes
!
!         fwd
!         x := (D/omega + L)^(-1) (b/alpha - (U - D (1-omega)/omega - sigma I) * x)
!
!         bwd
!         x := (D/omega + U)^(-1) (b/alpha - (L - D (1-omega)/omega - sigma I) * x)
!
!         A: square matrix
!         x: vector (in; initial vector for the step, out; updated vector)
!         b: constant vector

subroutine gsstep_fwd_shift_dense(trans, n, alpha, A, lda, sigma, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, lda, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, A(1:lda,1:n), b(1:incb,1:n)
  double precision, intent(inout) :: x(1:incx,1:n)

  integer :: i, j
  double precision :: tmpx, tmpd, c

  select case (trans)
    case ('N', 'n')
      do i = 1, n
        tmpd = 0.0d0
        c = 0.0d0
        tmpx = b(1,i) / alpha
        do j = 1, n
          if (i == j) then
            tmpd = A(i,j)
!            tmpx = tmpx + sigma * x(1,j)
            call kahan_sum(tmpx, sigma * x(1,j), c)
          else
!            tmpx = tmpx - A(i,j) * x(1,j)
            call kahan_sum(tmpx, - A(i,j) * x(1,j), c)
          end if
        end do
        x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
      end do
    case ('T', 't')
      do j = 1, n
        tmpd = 0.0d0
        c = 0.0d0
        tmpx = b(1,j) / alpha
        do i = 1, n
          if (i == j) then
            tmpd = A(i,j)
!            tmpx = tmpx + sigma * x(1,i)
            call kahan_sum(tmpx, sigma * x(1,j), c)
          else
!            tmpx = tmpx - A(i,j) * x(1,i)
            call kahan_sum(tmpx, - A(i,j) * x(1,i), c)
          end if
        end do
        x(1,j) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,j)
      end do
  end select
end subroutine gsstep_fwd_shift_dense

!!!!

subroutine gsstep_fwd_shift_csr(trans, n, alpha, spA, rowptr, colind, nnz, &
  sigma, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:incb,1:n)
  integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
  double precision, intent(inout) :: x(1:incx,1:n)

  select case (trans)
    case ('N', 'n')
      call gsstep_fwd_shift_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
        sigma, omega, b, incb, x, incx)
    case ('T', 't')
      call gsstep_fwd_shift_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
        sigma, omega, b, incb, x, incx)
  end select
end subroutine gsstep_fwd_shift_csr

subroutine gsstep_fwd_shift_csc(trans, n, alpha, spA, colptr, rowind, nnz, &
  sigma, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:incb,1:n)
  integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
  double precision, intent(inout) :: x(1:incx,1:n)

  select case (trans)
    case ('N', 'n')
      call gsstep_fwd_shift_csr_trans(n, alpha, spA, colptr, rowind, nnz, &
        sigma, omega, b, incb, x, incx)
    case ('T', 't')
      call gsstep_fwd_shift_csr_notrans(n, alpha, spA, colptr, rowind, nnz, &
        sigma, omega, b, incb, x, incx)
  end select
end subroutine gsstep_fwd_shift_csc

!!! private

subroutine gsstep_fwd_shift_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
  sigma, omega, b, incb, x, incx)
  use sparse
  integer, parameter :: base = sparse_base_index
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(base:*), b(1:incb,base:base+n-1)
  integer, intent(in) :: rowptr(base:*), colind(base:*)
  double precision, intent(inout) :: x(1:incx,base:base+n-1)

  integer :: i, j, z
  double precision :: tmpd, tmpx
  double precision :: c

  do i = base, base+n-1
    tmpd = 0.0d0
    c = 0.0d0
    tmpx = b(1,i) / alpha
    do z = rowptr(i), rowptr(i+1)-1
      j = colind(z)
      if (i == j) then
        tmpd = spA(z)
!!        tmpx = tmpx + sigma * x(1,i)
        call kahan_sum(tmpx, sigma * x(1,i), c)
      else
!!        tmpx = tmpx - spA(z) * x(1,j)
        call kahan_sum(tmpx, - spA(z) * x(1,j), c)
      end if
    end do
    x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
  end do
end subroutine gsstep_fwd_shift_csr_notrans

subroutine gsstep_fwd_shift_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
  sigma, omega, b, incb, x, incx)
  use sparse
  integer, parameter :: base = sparse_base_index
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(base:*), b(1:incb,base:base+n-1)
  integer, intent(in) :: rowptr(base:*), colind(base:*)
  double precision, intent(inout) :: x(1:incx,base:base+n-1)

  integer :: i, j, z
  double precision :: tmp(base:base+n-1)
  double precision :: c(base:base+n-1)
  integer :: diag(base:base+n-1)

  tmp = 0.0d0
  c = 0.0d0
  call daxpy(n, 1.0/alpha, b, incb, tmp, 1)
  do i = base, base+n-1
    do z = rowptr(i), rowptr(i+1)-1
      j = colind(z)
      if (i == j) then
        diag(i) = z
!        tmp(i) = tmp(i) + sigma * x(1,i)
        call kahan_sum(tmp(i), sigma * x(1,i), c(i))
        exit
      else
!        tmp(j) = tmp(j) - spA(z) * x(1,i)
        call kahan_sum(tmp(j), - spA(z) * x(1,i), c(j))
      end if
    end do
  end do

  do i = base, base+n-1
    x(1,i) = omega * tmp(i) / spA(diag(i)) + (1.0d0 - omega) * x(1,i)
    do z = diag(i)+1, rowptr(i+1)-1
      j = colind(z)
!      tmp(j) = tmp(j) - spA(z) * x(1,i)
      call kahan_sum(tmp(j), - spA(z) * x(1,i), c(j))
    end do
  end do
end subroutine gsstep_fwd_shift_csr_trans

!!!! bwd

subroutine gsstep_bwd_shift_dense(trans, n, alpha, A, lda, sigma, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, lda, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, A(1:lda,1:n), b(1:incb,1:n)
  double precision, intent(inout) :: x(1:incx,1:n)

  integer :: i, j
  double precision :: tmpx, tmpd, c

  select case (trans)
    case ('N', 'n')
      do i = n, 1, -1
        tmpd = 0.0d0
        c = 0.0d0
        tmpx = b(1,i) / alpha
        do j = n, 1, -1
          if (i == j) then
            tmpd = A(i,j)
!            tmpx = tmpx + sigma * x(1,j)
            call kahan_sum(tmpx, sigma * x(1,j), c)
          else
!            tmpx = tmpx - A(i,j) * x(1,j)
            call kahan_sum(tmpx, - A(i,j) * x(1,j), c)
          end if
        end do
        x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
      end do
    case ('T', 't')
      do j = n, 1, -1
        tmpd = 0.0d0
        c = 0.0d0
        tmpx = b(1,j) / alpha
        do i = n, 1, -1
          if (i == j) then
            tmpd = A(i,j)
!            tmpx = tmpx + sigma * x(1,i)
            call kahan_sum(tmpx, sigma * x(1,i), c)
          else
!            tmpx = tmpx - A(i,j) * x(1,i)
            call kahan_sum(tmpx, - A(i,j) * x(1,i), c)
          end if
        end do
        x(1,j) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,j)
      end do
  end select
end subroutine gsstep_bwd_shift_dense

!!!!

subroutine gsstep_bwd_shift_csr(trans, n, alpha, spA, rowptr, colind, nnz, &
  sigma, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:incb,1:n)
  integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
  double precision, intent(inout) :: x(1:incx,1:n)

  select case (trans)
    case ('N', 'n')
      call gsstep_bwd_shift_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
        sigma, omega, b, incb, x, incx)
    case ('T', 't')
      call gsstep_bwd_shift_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
        sigma, omega, b, incb, x, incx)
  end select
end subroutine gsstep_bwd_shift_csr

subroutine gsstep_bwd_shift_csc(trans, n, alpha, spA, colptr, rowind, nnz, &
  sigma, omega, b, incb, x, incx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:incb,1:n)
  integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
  double precision, intent(inout) :: x(1:incx,1:n)

  select case (trans)
    case ('N', 'n')
      call gsstep_bwd_shift_csr_trans(n, alpha, spA, colptr, rowind, nnz, &
        sigma, omega, b, incb, x, incx)
    case ('T', 't')
      call gsstep_bwd_shift_csr_notrans(n, alpha, spA, colptr, rowind, nnz, &
        sigma, omega, b, incb, x, incx)
  end select
end subroutine gsstep_bwd_shift_csc

!!! private

subroutine gsstep_bwd_shift_csr_notrans(n, alpha, spA, rowptr, colind, nnz, &
  sigma, omega, b, incb, x, incx)
  use sparse
  integer, parameter :: base = sparse_base_index
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(base:*), b(1:incb,base:base+n-1)
  integer, intent(in) :: rowptr(base:*), colind(base:*)
  double precision, intent(inout) :: x(1:incx,base:base+n-1)

  integer :: i, j, z
  double precision :: tmpd, tmpx, c

  do i = base+n-1, base, -1
    tmpd = 0.0d0
    c = 0.0d0
    tmpx = b(1,i) / alpha
    do z = rowptr(i+1)-1, rowptr(i), -1
      j = colind(z)
      if (i == j) then
        tmpd = spA(z)
!        tmpx = tmpx + sigma * x(1,i)
        call kahan_sum(tmpx, sigma * x(1,i), c)
      else
!        tmpx = tmpx - spA(z) * x(1,j)
        call kahan_sum(tmpx, - spA(z) * x(1,j), c)
      end if
    end do
    x(1,i) = omega * tmpx / tmpd + (1.0d0 - omega) * x(1,i)
  end do
end subroutine gsstep_bwd_shift_csr_notrans

subroutine gsstep_bwd_shift_csr_trans(n, alpha, spA, rowptr, colind, nnz, &
  sigma, omega, b, incb, x, incx)
  use sparse
  integer, parameter :: base = sparse_base_index
  integer, intent(in) :: n, nnz, incb, incx
  double precision, intent(in) :: alpha, sigma, omega, spA(base:*), b(1:incb,base:base+n-1)
  integer, intent(in) :: rowptr(base:*), colind(base:*)
  double precision, intent(inout) :: x(1:incx,base:base+n-1)

  integer :: i, j, z
  double precision :: tmp(base:base+n-1)
  double precision :: c(base:base+n-1)
  integer :: diag(base:base+n-1)

  tmp = 0.0d0
  c = 0.0d0
  call daxpy(n, 1.0/alpha, b, incb, tmp, 1)
  do i = base+n-1, base, -1
    do z = rowptr(i+1)-1, rowptr(i), -1
      j = colind(z)
      if (i == j) then
        diag(i) = z
!        tmp(i) = tmp(i) + sigma * x(1,i)
        call kahan_sum(tmp(i), sigma * x(1,i), c(i))
        exit
      else
!        tmp(j) = tmp(j) - spA(z) * x(1,i)
        call kahan_sum(tmp(j), - spA(z) * x(1,i), c(j))
      end if
    end do
  end do

  do i = base+n-1, base, -1
    x(1,i) = omega * tmp(i) / spA(diag(i)) + (1.0d0 - omega) * x(1,i)
    do z = diag(i)-1, rowptr(i), -1
      j = colind(z)
!      tmp(j) = tmp(j) - spA(z) * x(1,i)
      call kahan_sum(tmp(j), - spA(z) * x(1,i), c(j))
    end do
  end do
end subroutine gsstep_bwd_shift_csr_trans

!!!!! matrix

subroutine gsstep_fwd_shift_dense_mat(trans, n, nrhs, alpha, A, lda, sigma, omega, b, ldb, x, ldx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nrhs, lda, ldb, ldx
  double precision, intent(in) :: alpha, sigma, omega, A(1:lda,1:n), b(1:ldb,1:n)
  double precision, intent(inout) :: x(1:ldx,1:n)

  integer :: i

  do i = 1, nrhs
    call gsstep_fwd_shift_dense(trans, n, alpha, A, lda, sigma, omega, b(1,i), 1, x(1,i), 1)
  end do
end subroutine gsstep_fwd_shift_dense_mat

subroutine gsstep_fwd_shift_csr_mat(trans, n, nrhs, alpha, spA, rowptr, colind, nnz, sigma, omega, b, ldb, x, ldx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nrhs, nnz, ldb, ldx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:ldb,1:n)
  integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
  double precision, intent(inout) :: x(1:ldx,1:n)

  integer :: i

  do i = 1, nrhs
    call gsstep_fwd_shift_csr(trans, n, alpha, spA, rowptr, colind, nnz, sigma, omega, b(1,i), 1, x(1,i), 1)
  end do
end subroutine gsstep_fwd_shift_csr_mat

subroutine gsstep_fwd_shift_csc_mat(trans, n, nrhs, alpha, spA, colptr, rowind, nnz, sigma, omega, b, ldb, x, ldx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nrhs, nnz, ldb, ldx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:ldb,1:n)
  integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
  double precision, intent(inout) :: x(1:ldx,1:n)

  integer :: i

  do i = 1, nrhs
    call gsstep_fwd_shift_csc(trans, n, alpha, spA, colptr, rowind, nnz, sigma, omega, b(1,i), 1, x(1,i), 1)
  end do
end subroutine gsstep_fwd_shift_csc_mat

!!!!! matrix

subroutine gsstep_bwd_shift_dense_mat(trans, n, nrhs, alpha, A, lda, sigma, omega, b, ldb, x, ldx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nrhs, lda, ldb, ldx
  double precision, intent(in) :: alpha, sigma, omega, A(1:lda,1:n), b(1:ldb,1:n)
  double precision, intent(inout) :: x(1:ldx,1:n)

  integer :: i

  do i = 1, nrhs
    call gsstep_bwd_shift_dense(trans, n, alpha, A, lda, sigma, omega, b(1,i), 1, x(1,i), 1)
  end do
end subroutine gsstep_bwd_shift_dense_mat

subroutine gsstep_bwd_shift_csr_mat(trans, n, nrhs, alpha, spA, rowptr, colind, nnz, sigma, omega, b, ldb, x, ldx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nrhs, nnz, ldb, ldx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:ldb,1:n)
  integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
  double precision, intent(inout) :: x(1:ldx,1:n)

  integer :: i

  do i = 1, nrhs
    call gsstep_bwd_shift_csr(trans, n, alpha, spA, rowptr, colind, nnz, sigma, omega, b(1,i), 1, x(1,i), 1)
  end do
end subroutine gsstep_bwd_shift_csr_mat

subroutine gsstep_bwd_shift_csc_mat(trans, n, nrhs, alpha, spA, colptr, rowind, nnz, sigma, omega, b, ldb, x, ldx)
  character, intent(in) :: trans
  integer, intent(in) :: n, nrhs, nnz, ldb, ldx
  double precision, intent(in) :: alpha, sigma, omega, spA(1:nnz), b(1:ldb,1:n)
  integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
  double precision, intent(inout) :: x(1:ldx,1:n)

  integer :: i

  do i = 1, nrhs
    call gsstep_bwd_shift_csc(trans, n, alpha, spA, colptr, rowind, nnz, sigma, omega, b(1,i), 1, x(1,i), 1)
  end do
end subroutine gsstep_bwd_shift_csc_mat

end module gsstep


module boundary

  use mpi

  implicit none

contains

subroutine boundarypsi(psi, m, n, b, h, w, comm)

  integer :: m, n, b, h, w, comm

  double precision, dimension(0:m+1, 0:n+1) :: psi

  integer :: size, rank, ierr, i, j
  integer :: jstart, jstop

  call mpi_comm_size(comm, size, ierr)
  call mpi_comm_rank(comm, rank, ierr)

  jstart = n*rank + 1
  jstop  = jstart + n - 1

!  Set the boundary conditions on the bottom edge

  if (rank == 0) then

     do i = b+1, b+w-1
        psi(i, 0) = float(i-b)
     end do

     do i = b+w, m
        psi(i, 0) = float(w)
     end do

  end if

!  Set the boundary conditions on the right hand side

  do j = 1, h

     if (j .ge. jstart .and. j .le. jstop) then
        psi(m+1,j-jstart+1) = float(w)
     end if

  end do

  do j = h+1, h+w-1

     if (j .ge. jstart .and. j .le. jstop) then
        psi(m+1,j-jstart+1) = float(w-j+h)
     end if

  end do

end subroutine boundarypsi

subroutine boundaryzet(zet, psi, m, n, comm)

  integer :: m, n, comm

  double precision, dimension(0:m+1, 0:n+1) :: zet, psi

  integer :: size, rank, ierr, i, j

  call mpi_comm_size(comm, size, ierr)
  call mpi_comm_rank(comm, rank, ierr)

! Set the zeta boundary conditions which depend on psi

  do j = 1, n

     zet(0,  j) = 2.0*(psi(1,j) - psi(0,  j))
     zet(m+1,j) = 2.0*(psi(m,j) - psi(m+1,j))

  end do

  if (rank == 0) then

     do i = 1, m
        zet(i,0) = 2.0*(psi(i,  1)-psi(i,0))
     end do

  end if

  if (rank == size-1) then

     do i = 1, m
        zet(i,n+1) = 2.0*(psi(i,n)-psi(i,n+1))
     end do

  end if

end subroutine boundaryzet

subroutine haloswap(x, m, n, comm)

  integer :: m, n, comm, rank, uprank, dnrank, size, ierr

  double precision :: x(0:m+1, 0:n+1)

  integer, parameter :: tag = 1

  integer, dimension(MPI_STATUS_SIZE) :: status

  call mpi_comm_size(comm, size, ierr)
  call mpi_comm_rank(comm, rank, ierr)

!  No need to halo swap for serial code

  if (size > 1) then

!  Send upper boundaries and receive lower ones

     if (rank == 0) then

        call mpi_send(x(1,n), m, MPI_DOUBLE_PRECISION, rank+1, &
                     tag, comm, ierr)

     else if (rank == size-1) then

        call mpi_recv(x(1,0), m, MPI_DOUBLE_PRECISION, rank-1, &
                      tag, comm, status, ierr)
     else

        call mpi_sendrecv(x(1,n), m, MPI_DOUBLE_PRECISION, rank+1, tag, &
                          x(1,0), m, MPI_DOUBLE_PRECISION, rank-1, tag, &
                          comm, status, ierr)

     end if

!  Send lower boundaries and receive upper ones

     if (rank == 0) then

        call mpi_recv(x(1,n+1), m, MPI_DOUBLE_PRECISION, rank+1, &
                      tag, comm, status, ierr)

     else if (rank == size-1) then

        call mpi_send(x(1,1), m, MPI_DOUBLE_PRECISION, rank-1, &
                     tag, comm, ierr)

     else

        call mpi_sendrecv(x(1,1)  , m, MPI_DOUBLE_PRECISION, rank-1, tag, &
                         x(1,n+1), m, MPI_DOUBLE_PRECISION, rank+1, tag, &
                         comm, status, ierr)
     end if

end if

end subroutine haloswap

end module boundary


      subroutine arcc1(xm,ym,xf,yf,j,r,jb)
C     subroutine    arcc1     01/04/76
      common/gfbftr/xtr,ytr
      equivalence(xtr,x0),(ytr,y0)
      a=sqrt((x0-xf)**2+(y0-yf)**2)
      b=sqrt((xf-xm)**2+(yf-ym)**2)
      if(ivest(a,0.,.000001))   3,8,10
   10 c=sqrt((xm-x0)**2+(ym-y0)**2)
      p=(a+b+c)/2
      s2=p*(p-a)*(p-b)*(p-c)
      if(ivest(s2,0.,.000001))   3,9,11
   11 s1=sqrt(s2)
      r=(a*b*c)/(4*s1)
      z=sqrt((p-b)*(p-c)/(p*(p-a)))
      alpha=2*atan(z)/0.01745329
      jb=1
      if(ivest(alpha,90.,0.000001)  .gt.0) jb=0
      s=(x0-xf)*(ym-yf)-(xm-xf)*(y0-yf)
      if(ivest(s,0.,.000001))   5,3,6
    5 r=-r
    6 if(j.le.0) goto 3
      jb=1-jb
      r=-r
      goto 3
    8 r=b/2
      jb=1
      goto 3
    9 r=0
      jb=0
    3 return
      end


MODULE B85_scattIso
!---------------------------------------------------------------------
!
!    File:         B85_scattIso.f90
!    Module:       B85_scattIso
!    Type:         Module w/ Funcstions and Routines
!    Author:       R. Chu, Dept. Phys. & Astronomy
!                  U. Tennesee, Knoxville
!
!    Created:      8/16/18
!
!    WeakLib ver:  weaklib/External/Utilities/Opacities/Bruenn85
!
!    Purpose:      The zero and first legendre coefs for the n-type
!                  neutrino isoenergetic scattering on nucleon and
!                  nuclei kernel considering the physics in Bruenn 85.
!
!    CONTAINS:     Function  TotalIsoScatteringKernel
!
!    Input arguments:
!                  energy  : neutrino energy [MeV]
!                  rho     : matter density [g cm^{-3}]
!                  T       : matter temperature [K]
!                  xh      : heavy nucleus mass fraction
!                  A       : heavy nucleus mass number
!                  Z       : heavy nucleus charge number
!                  xn      : free neutron mass fraction
!                  xp      : free proton mass fraction
!                  l       : order of the legendre coefs/moment
!
!    Output arguments:
!                  TotalIsoScatteringKernel
!
!    Modules used:
!                  wlKindModule
!                  wlExtPhysicalConstantsModule
!                  wlExtNumericalModule
!                  ( function fexp is called )
!
!---------------------------------------------------------------------

  USE wlKindModule, ONLY: dp
  USE wlExtPhysicalConstantsModule, ONLY: &
      h, kMeV, therm1, therm2, dmnp, me, mbG, mp, mn, cvel_inv, &
      cvel, ergmev, cv_p, cv_n, ca_p, ca_n, gf, hbarc, cv, ca
  USE wlExtNumericalModule, ONLY: &
      pi, half, twpi, zero, one

  IMPLICIT NONE

  PUBLIC TotalIsoScatteringKernel

CONTAINS

  REAL(dp) FUNCTION TotalIsoScatteringKernel &
                      ( energy, rho, T, xh, A, Z, xn, xp, l )
!---------------------------------------------------------------------
! Purpose:
!   To compute the zero and first legendre coefs for the any-type
!   neutrino isoenergetic scattering kernel. On both nucleon and
!   nuclei.
! Ref:
!   Mezzacappa & Bruenn(1993) AJ 405
!   Bruenn(1985) AJSS 58
!---------------------------------------------------------------------
!--------------------------------------------------------------
!   Input Variables
!--------------------------------------------------------------
  USE, INTRINSIC :: ieee_arithmetic, ONLY: IEEE_IS_NAN

  IMPLICIT NONE
    REAL(dp), INTENT(in) :: energy, rho, T, xh, A, Z, xn, xp
    INTEGER, INTENT(in)  :: l
!--------------------------------------------------------------
!   Physical Constants
!--------------------------------------------------------------
    REAL(dp)             :: N, nucleiTP, & !'TP' for thermal parameter
                            nucleonTP, nucleiExp, Cv0, Cv1,&
                            etann, etapp, Npara
!---------------------------------------------------------------------
!   Local Variables
!---------------------------------------------------------------------
    REAL(dp) :: ISNucleiKernel_0, ISNucleonKernel_0, &
                ISNucleiKernel_1, ISNucleonKernel_1, &
                tempC0, TempC1
    INTEGER  :: nquad = 20

        N       =   A - Z
       Cv0      =   half * ( cv_p + cv_n)
       Cv1      =   cv_p - cv_n
     Npara      =   twpi * cvel_inv**4.0 * energy**2.0 / h**3.0

    nucleiExp   =   4.0_dp * 4.8_dp * 10**(-6.0_dp) * &
                    A**(2.0_dp/3.0_dp) * energy**2.0
    nucleiExp   =   MAX( nucleiExp, SQRT( TINY( 1.0_dp ) ) )

    IF ( xh == zero ) THEN

      nucleiTP  =   zero

    ELSE

      nucleiTP  =   ( (twpi*gf)**2 / h ) * ( rho*xh/mbG ) * &
                    A * ( Cv0 - ( (N-Z)*Cv1 )/(2.0_dp*A) )**2
    END IF

    nucleonTP   =   ( twpi * gf )**2 / h

!------------------------------
!  scattering on nuclei
!------------------------------

    tempC0 = IntegralESNuclei( nucleiExp, 0, nquad )
    tempC1 = IntegralESNuclei( nucleiExp, 1, nquad )

    ISNucleiKernel_0 = nucleiTP * tempC0 / 2.0_dp

    ISNucleiKernel_1 = nucleiTP * tempC1 * 3.0_dp / 2.0_dp

    IF ( IEEE_IS_NAN(ISNucleiKernel_0) .or. IEEE_IS_NAN(ISNucleiKernel_1)  ) THEN
     WRITE(*,*) "ERROR AT B85.f90 MARK 1003 !"
     WRITE(*,*) "nucleiExp is ", nucleiExp
     WRITE(*,*) "ISNucleiKernel_0 ", ISNucleiKernel_0
     WRITE(*,*) "ISNucleiKernel_1 ", ISNucleiKernel_1
     STOP
    END IF

!--------------------------------------
!   Scattering on Nucleons
!-------------------------------------

    CALL etaxx( rho, T, xn, xp, etann, etapp )

    ISNucleonKernel_0 = (2.0_dp) * nucleonTP * &
                        ( etann * ( cv_n**2 + 3.0_dp * ca_n**2) + &
                          etapp * ( cv_p**2 + 3.0_dp * ca_p**2) )

    ISNucleonKernel_1 = (2.0_dp / 3.0_dp) * nucleonTP * &
                        ( etann * ( cv_n**2 - ca_n**2) + &
                          etapp * ( cv_p**2 - ca_p**2) )

    IF ( IEEE_IS_NAN(ISNucleonKernel_0) .or. IEEE_IS_NAN(ISNucleonKernel_1)  ) &
    THEN
      WRITE(*,*) "ERROR AT B85.f90 MARK 1004 !"
      WRITE(*,*) "etann is ", etann
      WRITE(*,*) "etapp is ", etapp
      WRITE(*,*) "ISNucleonKernel_0 ", ISNucleonKernel_0
      WRITE(*,*) "ISNucleonKernel_1 ", ISNucleonKernel_1
      STOP
    END IF

    IF ( l == 0 ) THEN

     TotalIsoScatteringKernel = Npara * ( ISNucleiKernel_0 &
                                        + ISNucleonKernel_0 )

    ELSE IF ( l == 1) THEN

     TotalIsoScatteringKernel = Npara * ( ISNucleiKernel_1 &
                                        + ISNucleonKernel_1 )

    ELSE

      WRITE(*,*) "ERROR: Unable to provide Legendre Moment with &
                         l other than 0 and 1 "
    END IF

    IF ( IEEE_IS_NAN(TotalIsoScatteringKernel) ) THEN
      WRITE(*,*) "TotalIsoScatteringKernel is NAN! "
      WRITE(*,*) "l is", l
      WRITE(*,*) "ISNucleiKernel_0 + ISNucleonKernel_0 ", &
                  ISNucleiKernel_0 + ISNucleonKernel_0
      WRITE(*,*) "ISNucleiKernel_1 + ISNucleonKernel_1 ", &
                  ISNucleiKernel_1 + ISNucleonKernel_1
      STOP
    END IF

    RETURN

  END FUNCTION TotalIsoScatteringKernel

  FUNCTION IntegralESNuclei( a, l, nquad )

  IMPLICIT NONE
    REAL(dp), INTENT(in)       :: a
    INTEGER,  INTENT(in)       :: l, nquad

    REAL(dp), DIMENSION(nquad) :: roots, weights
    REAL(dp)                   :: IntegralESNuclei, buffer, func
    INTEGER                    :: ii

    CALL gaquad( nquad, roots, weights, -1.0_dp , 1.0_dp )

    buffer = 0.0

    IF ( l == 0 ) THEN

      DO ii = 1, nquad
        func   =  ( 1.0 + roots(ii) ) * EXP( a * ( roots(ii) - 1.0 ) )
        buffer =  buffer + weights(ii) * func
      END DO

    ELSE IF ( l == 1 ) THEN

      DO ii = 1, nquad
        func   =  roots(ii) * ( roots(ii) + 1.0 ) &
                  * EXP( a * ( roots(ii) - 1.0 ) )
        buffer =  buffer + weights(ii) * func
      END DO

    ELSE

       WRITE(*,*) "ERROR when calling IntegralESNuclei function."

    END IF

    IntegralESNuclei = buffer

  END FUNCTION IntegralESNuclei

  SUBROUTINE etaxx( rho, T, xn, xp, etann, etapp )

  IMPLICIT NONE
!---------------------------------------------------------------------
!        Input variables.
!---------------------------------------------------------------------
  REAL(dp), INTENT(in)    :: rho      ! density (g/cm3)
  REAL(dp), INTENT(in)    :: T        ! temperature [K]
  REAL(dp), INTENT(in)    :: xn       ! neutron mass fraction
  REAL(dp), INTENT(in)    :: xp       ! proton mass fraction

!---------------------------------------------------------------------
!        Output variables.
!---------------------------------------------------------------------
  REAL(dp), INTENT(out)   :: etann
                              ! neutron number corrected for blocking
  REAL(dp), INTENT(out)   :: etapp
                              ! proton number corrected for blocking

!---------------------------------------------------------------------
!        Local variables
!--------------------------------------------------------------------
  REAL(dp)                :: nn
                   ! neutron number uncorrected for blocking (cm^{-3})
  REAL(dp)                :: np
                   ! proton number uncorrected for blocking (cm^{-3})
  REAL(dp)                :: d_n
                   ! neutron number uncorrected for blocking (fm^{-3})
  REAL(dp)                :: d_p
                   ! proton number uncorrected for blocking (fm^{-3})
  REAL(dp)                :: efn            ! degenerate expression
  REAL(dp)                :: efp            ! degenerate expression
  REAL(dp)                :: etanndgnt      ! nondegenerate expression
  REAL(dp)                :: etappdgnt      ! nondegenerate expression
  REAL(dp)                :: mpG, mnG
  REAL(dp), PARAMETER     :: tthird = 2.d0/3.d0

  mpG  =  mp * ergmev * cvel_inv * cvel_inv ! proton mass [g]
  mnG  =  mn * ergmev * cvel_inv * cvel_inv ! neutron mass [g]
  nn   =  xn * rho/mpG
  np   =  xp * rho/mnG

  IF ( nn < zero  .or.  np < zero ) THEN
    WRITE(*,*) "ERROR! nn or np less than zero."
  END IF

!---------------------------------------------------------------------
!  etann, etanp (analytic approximation)
!---------------------------------------------------------------------
  IF ( nn == zero ) THEN

     etann      =  0.0_dp

  ELSE

     d_n        =  nn * 1.d-39
     efn        =  ( hbarc**2/( 2.d+00 * mn ) ) &
                   * ( 3.d+00 * pi**2 * d_n )**tthird
     etanndgnt  =  1.5d+00 * ( kMev * T/efn )
     etann      =  nn * etanndgnt/DSQRT( 1.d+00 + etanndgnt**2 )

  END IF

  IF ( np == zero ) THEN

     etapp      =  0.0_dp

  ELSE

     d_p        =  np * 1.d-39
     efp        =  ( hbarc**2/( 2.d+00 * mp ) ) &
                   * ( 3.d+00 * pi**2 * d_p )**tthird
     etappdgnt  =  1.5d+00 * ( kMev * T/efp )
     etapp      =  np * etappdgnt/DSQRT( 1.d+00 + etappdgnt**2 )

  END IF

  END SUBROUTINE etaxx

END MODULE B85_scattIso


      SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct the block Hankel expansion T of a multivariable
C     parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k)
C     is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NH1     (input) INTEGER
C             The number of rows in each parameter M(k).  NH1 >= 0.
C
C     NH2     (input) INTEGER
C             The number of columns in each parameter M(k).  NH2 >= 0.
C
C     NR      (input) INTEGER
C             The number of parameters required in each column of the
C             block Hankel expansion matrix T.  NR >= 0.
C
C     NC      (input) INTEGER
C             The number of parameters required in each row of the
C             block Hankel expansion matrix T.  NC >= 0.
C
C     H       (input) DOUBLE PRECISION array, dimension
C             (LDH,(NR+NC-1)*NH2)
C             The leading NH1-by-(NR+NC-1)*NH2 part of this array must
C             contain the multivariable sequence M(k), where k = 1,2,
C             ...,(NR+NC-1). Specifically, each parameter M(k) is an
C             NH1-by-NH2 matrix whose (i,j)-th element must be stored in
C             H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,NH1).
C
C     T       (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC)
C             The leading NH1*NR-by-NH2*NC part of this array contains
C             the block Hankel expansion of the multivariable sequence
C             M(k).
C
C     LDT     INTEGER
C             The leading dimension of array T.  LDT >= MAX(1,NH1*NR).
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     METHOD
C
C     The NH1-by-NH2 dimensional parameters M(k) of a multivariable
C     sequence are arranged into a matrix T in Hankel form such that
C
C
C              | M(1)   M(2)    M(3)    . . .  M(NC)     |
C              |                                         |
C              | M(2)   M(3)    M(4)    . . .  M(NC+1)   |
C         T =  |  .      .       .              .        |.
C              |  .      .       .              .        |
C              |  .      .       .              .        |
C              |                                         |
C              | M(NR)  M(NR+1) M(NR+2) . . .  M(NR+NC-1)|
C
C     REFERENCES
C
C     [1] Johvidov, J.S.
C         Hankel and Toeplitz Matrices and Forms: Algebraic Theory,
C         (translated by G.P.A. Thijsse, I. Gohberg, ed.).
C         Birkhaeuser, Boston, 1982.
C
C     NUMERICAL ASPECTS
C
C     The time taken is approximately proportional to
C     NH1 x NH2 x NR x NC.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TF01CD by S. Van Huffel, Katholieke
C     Univ. Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Hankel matrix, multivariable system.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, LDT, NC, NH1, NH2, NR
C     .. Array Arguments ..
      DOUBLE PRECISION  H(LDH,*), T(LDT,*)
C     .. Local Scalars ..
      INTEGER           IH, IT, JT, NROW
C     .. External Subroutines ..
      EXTERNAL          DLACPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( NH1.LT.0 ) THEN
         INFO = -1
      ELSE IF( NH2.LT.0 ) THEN
         INFO = -2
      ELSE IF( NR.LT.0 ) THEN
         INFO = -3
      ELSE IF( NC.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN
         INFO = -6
      ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TF01OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( NH1, NH2, NR, NC ).EQ.0 )
     $   RETURN
C
C     Construct the first block column of T.
C
      IH = 1
      NROW = (NR-1)*NH1
C
      DO 10 IT = 1, NROW+NH1, NH1
         CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,1), LDT )
         IH = IH + NH2
   10 CONTINUE
C
C     Construct the remaining block columns of T.
C
      DO 20 JT = NH2+1, NC*NH2, NH2
         CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT-NH2), LDT, T(1,JT),
     $                LDT )
         CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT),
     $                LDT )
         IH = IH + NH2
   20 CONTINUE
C
      RETURN
C *** Last line of TF01OD ***
      END


!*****************************************************************************************
!> author: Jacob Williams
!
!  IAU orientation models for the Earth and planets.
!
!# See also
!  1. NAIF SPICE pck.html documentation
!  2. "Report of the IAU Working Group on Cartographic Coordinates
!     and Rotational Elements: 2009", Celestial Mechanics and
!     Dynamical Astronomy, February 2011, Vol 109, Issue 2, p 101-135.
!
!@warning Not Finished.
!
!@todo Use a class to provide access to the different models

    module iau_orientation_module

    use kind_module
    use numbers_module
    use conversion_module

    implicit none

    private

    public :: iau_rotation_matrix  !base routine
    public :: icrf_to_iau_earth
    public :: icrf_to_iau_moon

    !test routines:
    public :: iau_test

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

!*****************************************************************************************
!> author: Jacob Williams
!  date: 2/3/2015
!
!  Returns the rotation matrix for a coordinate transformation from
!  the International Celestial Reference Frame (ICRF) frame to the
!  IAU rotating frame associated with a body.
!  The IAU orientation models use three Euler angles to describe
!  the pole and prime meridian location (ra, dec, and w).

    pure function iau_rotation_matrix(w,dec,ra) result(rotmat)

    use vector_module, only: rotation_matrix,x_axis,y_axis,z_axis

    implicit none

    real(wp),intent(in)     :: w         !! right ascension of the pole [rad]
    real(wp),intent(in)     :: dec       !! declination of the pole [rad]
    real(wp),intent(in)     :: ra        !! prime meridian location [rad]
    real(wp),dimension(3,3) :: rotmat    !! the rotation matrix

    real(wp),parameter :: pi2 = pi / two

    real(wp),dimension(3,3) :: tmp

    !it is a 3-1-3 rotation:
    tmp    = matmul( rotation_matrix(x_axis,pi2-dec), rotation_matrix(z_axis,pi2+ra) )
    rotmat = matmul( rotation_matrix(z_axis,w), tmp )

    end function iau_rotation_matrix
!*****************************************************************************************

!
! TO DO:
!... also need to add computation of rotmatdot
! see: ftp://naif.jpl.nasa.gov/pub/naif/toolkit_docs/FORTRAN/spicelib/tisbod.html
!

!*****************************************************************************************
!> author: Jacob Williams
!  date: 2/3/2015
!
!  Rotation matrix from ICRF to IAU_EARTH.

    pure function icrf_to_iau_earth(et) result(rotmat)

    implicit none

    real(wp),intent(in)     :: et        !! ephemeris time [sec]
    real(wp),dimension(3,3) :: rotmat    !! the rotation matrix

    real(wp) :: w,dec,ra,d,t

    d = et * sec2day     !interval in days from the J2000 epoch
    t = et * sec2century !interval in Julian centuries (36525 days) from the J2000 epoch

    ra  = (         - 0.641_wp * t          ) * deg2rad
    dec = ( 90.0_wp - 0.557_wp * t          ) * deg2rad
    w   = ( 190.147_wp + 360.9856235_wp * d ) * deg2rad

    rotmat = iau_rotation_matrix(w,dec,ra)

    end function icrf_to_iau_earth
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/5/2016
!
!  Rotation matrix from ICRF to IAU_MOON.

    pure function icrf_to_iau_moon(et) result(rotmat)

    implicit none

    real(wp),intent(in)     :: et        !! ephemeris time [sec]
    real(wp),dimension(3,3) :: rotmat    !! the rotation matrix

    real(wp) :: w,dec,ra,d,t
    real(wp) :: e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12,e13

    d = et * sec2day     !interval in days from the J2000 epoch
    t = et * sec2century !interval in Julian centuries (36525 days) from the J2000 epoch

    ! Nutation/precession angles:
    e1  = ( 125.045_wp - 0.0529921_wp  * d ) * deg2rad
    e2  = ( 250.089_wp - 0.1059842_wp  * d ) * deg2rad
    e3  = ( 260.008_wp + 13.0120009_wp * d ) * deg2rad
    e4  = ( 176.625_wp + 13.3407154_wp * d ) * deg2rad
    e5  = ( 357.529_wp + 0.9856003_wp  * d ) * deg2rad
    e6  = ( 311.589_wp + 26.4057084_wp * d ) * deg2rad
    e7  = ( 134.963_wp + 13.0649930_wp * d ) * deg2rad
    e8  = ( 276.617_wp + 0.3287146_wp  * d ) * deg2rad
    e9  = ( 34.226_wp  + 1.7484877_wp  * d ) * deg2rad
    e10 = ( 15.134_wp  - 0.1589763_wp  * d ) * deg2rad
    e11 = ( 119.743_wp + 0.0036096_wp  * d ) * deg2rad
    e12 = ( 239.961_wp + 0.1643573_wp  * d ) * deg2rad
    e13 = ( 25.053_wp  + 12.9590088_wp * d ) * deg2rad

    ra  = ( 269.9949_wp + 0.0031_wp * t &
            - 3.8787_wp * sin(E1 ) &
            - 0.1204_wp * sin(E2 ) &
            + 0.0700_wp * sin(E3 ) &
            - 0.0172_wp * sin(E4 ) &
            + 0.0072_wp * sin(E6 ) &
            - 0.0052_wp * sin(E10) &
            + 0.0043_wp * sin(E13) ) * deg2rad

    dec = ( 66.5392_wp + 0.0130_wp * t &
            + 1.5419_wp * cos(E1 ) &
            + 0.0239_wp * cos(E2 ) &
            - 0.0278_wp * cos(E3 ) &
            + 0.0068_wp * cos(E4 ) &
            - 0.0029_wp * cos(E6 ) &
            + 0.0009_wp * cos(E7 ) &
            + 0.0008_wp * cos(E10) &
            - 0.0009_wp * cos(E13) ) * deg2rad

    w = ( 38.3213_wp + 13.17635815_wp * d - 1.4e-12_wp * d**2 &
          + 3.5610_wp * sin(E1 ) &
          + 0.1208_wp * sin(E2 ) &
          - 0.0642_wp * sin(E3 ) &
          + 0.0158_wp * sin(E4 ) &
          + 0.0252_wp * sin(E5 ) &
          - 0.0066_wp * sin(E6 ) &
          - 0.0047_wp * sin(E7 ) &
          - 0.0046_wp * sin(E8 ) &
          + 0.0028_wp * sin(E9 ) &
          + 0.0052_wp * sin(E10) &
          + 0.0040_wp * sin(E11) &
          + 0.0019_wp * sin(E12) &
          - 0.0044_wp * sin(E13) ) * deg2rad

    rotmat = iau_rotation_matrix(w,dec,ra)

    end function icrf_to_iau_moon
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 2/3/2015
!
!  Unit test routine for iau_module.

    subroutine iau_test()

    implicit none

    real(wp)                :: et
    real(wp),dimension(3,3) :: rotmat

    integer :: i

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' iau_test'
    write(*,*) '---------------'
    write(*,*) ''

    et     = 1000.0_wp               !epoch [sec from J2000]
    rotmat = icrf_to_iau_earth(et)   !rotation matrix from J2000 to IAU_EARTH

    write(*,*) '---icrf_to_iau_earth---'
    write(*,*) 'et    =',et
    write(*,*) 'rotmat='
    do i=1,3
        write(*,*) rotmat(i,:)
    end do

    ! ---icrf_to_iau_earth---
    ! et    =   1000.0000000000000
    ! rotmat=
    !  0.24742305587604752      -0.96890754534215406       -7.6219971891330182E-010
    !  0.96890754534215406       0.24742305587604752       -2.9847705387722482E-009
    !  3.0805524797727912E-009  -1.0920940632167532E-017   1.0000000000000000
    !
    ! Compare to SPICE:
    ! call PXFORM( 'J2000', 'IAU_EARTH', ET, ROTMAT )
    ! rotmat=
    !  0.24742305587604752      -0.96890754534215406       -7.6219971891330182E-010
    !  0.96890754534215406       0.24742305587604752       -2.9847705387722482E-009
    !  3.0805524797727912E-009  -1.0920940632167532E-017    1.0000000000000000

    et     = 1000.0_wp               !epoch [sec from J2000]
    rotmat = icrf_to_iau_moon(et)    !rotation matrix from J2000 to IAU_MOON

    write(*,*) '---icrf_to_iau_moon---'
    write(*,*) 'et    =',et
    write(*,*) 'rotmat='
    do i=1,3
        write(*,*) rotmat(i,:)
    end do

    ! ---icrf_to_iau_moon---
    ! et    =   1000.0000000000000
    ! rotmat=
    !  0.78257369718829173       0.55976292119480831       0.27247730276942850
    ! -0.62214729926548507       0.71906872303263469       0.30963350847878057
    ! -2.2608548951909870E-002 -0.41183205753276536       0.91097925876642116
    !
    ! Compare to SPICE:
    ! call PXFORM( 'J2000', 'IAU_MOON', ET, ROTMAT )
    ! rotmat=
    !  0.78257369718829173       0.55976292119480819       0.27247730276942861
    ! -0.62214729926548507       0.71906872303263458       0.30963350847878074
    ! -2.2608548951909880E-002 -0.41183205753276558       0.91097925876642105

    end subroutine iau_test
!*****************************************************************************************

!*****************************************************************************************
    end module iau_orientation_module
!*****************************************************************************************