 SUBROUTINE DGELS_F95( A, B, TRANS, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => DP
    USE LA_AUXMOD, ONLY: ERINFO, LSAME, LA_WS_GELS
    USE F77_LAPACK, ONLY: GELS_F77 => LA_GELS
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    REAL(WP), INTENT(INOUT) :: A(:,:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!       LA_GELS computes the minimum-norm least squares solution to one
! or more real or complex linear systems of the form A*x = b, A^T*x = b
! or A^H*x = b using a QR or LQ factorization of A. Matrix A is
! rectangular assumed to be of full rank. The vectors b and correspon-
! ding solution vectors x are the columns of matrices denoted B and X,
! respectively.
!
! ==========
!
!       SUBROUTINE LA_GELS( A, B, TRANS=trans, INFO=info )
!          <type>(<wp>), INTENT( INOUT ) :: A( :, : ), <rhs>
! 	   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS
! 	   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!          <type> ::= REAL | COMPLEX
! 	   <wp>   ::= KIND(1.0) | KIND(1.0D0)
!          <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! A        (input/output) REAL or COMPLEX rectangular array, shape (:,:).
!          On entry, the matrix A.
! 	   On exit, if size(A,1) >= size(A,2), A is overwritten by
! 	   details of its QR factorization. If size(A,1) < size(A,2), A
! 	   is overwritten by details of its LQ factorization.
! B        (input/output) REAL or COMPLEX array, shape (:,:) with
!          size(B,1) = max(size(A,1), size(A,2)) or shape (:) with
! 	   size(B) = max(size(A,1); size(A,2)).
! 	   On entry, the matrix B.
! 	   On exit, the solution matrix X. There are four cases:
! 	   1. If TRANS = 'N' and size(A,1) >= size(A,2), then rows 1
! 	      to size(A,2) of B contain, columnwise, the least squares
! 	      solution vector(s); the residual sum of squares for the
! 	      solution vector in a column of B is given by the sum of
! 	      squares of elements in rows size(A,2)+1 to size(A,1) of
! 	      that column.
! 	   2. If TRANS = 'N' and size(A,1) < size(A,2), then rows 1
! 	      to size(A,2) of B contain, columnwise, the minimum norm
! 	      solution vector(s).
! 	   3. If TRANS = 'T' or TRANS = 'C', and size(A,1)>=size(A,2),
! 	      then rows 1 to size(A,1) of B contain, columnwise, the
! 	      minimum norm solution vector(s).
! 	   4. If TRANS = 'T' or TRANS = 'C', and size(A,1) < size(A,2),
! 	      then rows 1 to size(A,1) of B contain, columnwise, the
! 	      least squares solution vector(s); the residual sum of
! 	      squares for the solution vector in a column of B is given
! 	      by the sum of squares of elements in rows size(A,1)+1 to
! 	      size(A,2) of that column.
! TRANS    Optional (input) CHARACTER(LEN=1).
!          Specifies the form of the system of equations:
! 	   = 'N': Ax = b (No transpose)
!          = 'T': A^T*x = b (Transpose)
! 	   = 'C': A^H*x = b (Conjugate transpose)
! 	   Default value: 'N'.
! INFO     Optional (output) INTEGER
!          = 0: successful exit.
! 	   < 0: if INFO = -i, the i-th argument had an illegal value.
! 	   If INFO is not present and an error occurs, then the program
! 	   is terminated with an error message.
!---------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GELS'
    CHARACTER(LEN=1), PARAMETER :: VER = 'D'
!   .. LOCAL SCALARS ..
    CHARACTER(LEN=1) :: LTRANS
    INTEGER :: LINFO, ISTAT, ISTAT1, LWORK, N, M, NRHS
!   .. LOCAL POINTERS ..
    REAL(WP), POINTER :: WORK(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT, MAX, MIN
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2); NRHS = SIZE(B,2)
    IF( PRESENT(TRANS) )THEN; LTRANS = TRANS; ELSE; LTRANS = 'N'; ENDIF
!   .. TEST THE ARGUMENTS
    IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= MAX(1,M,N) .OR. NRHS < 0 ) THEN; LINFO = -2
    ELSE IF( .NOT.( LSAME(LTRANS,'N') .OR. LSAME(LTRANS,'T') ) )THEN; LINFO = -3
    ELSE
!   .. CALCULATE THE OPTIMAL WORKSPACE ..
       LWORK = LA_WS_GELS( VER, M, N, NRHS, LTRANS )
       ALLOCATE( WORK(LWORK), STAT = ISTAT )
       IF( ISTAT /= 0 ) THEN
          DEALLOCATE( WORK, STAT=ISTAT1 ); LWORK = MIN(M,N) + MAX(1,M,N,NRHS)
          ALLOCATE( WORK(LWORK), STAT = ISTAT )
          IF( ISTAT /= 0 ) CALL ERINFO( -200, SRNAME, LINFO )
       END IF
       IF ( ISTAT == 0 ) THEN
!      .. CALL LAPACK77 ROUTINE
          CALL GELS_F77( LTRANS, M, N, NRHS, A, MAX(1,M), B, MAX(1,M,N), &
                         WORK, LWORK, LINFO )
       ELSE; LINFO = -100; END IF
       DEALLOCATE(WORK, STAT = ISTAT1 )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE DGELS_F95


module mod_post
  use mod_types
  implicit none
  private
  public vorticity,rotation_rate,strain_rate,q_criterion
  contains
  subroutine vorticity(n,dli,dzci,ux,uy,uz,vox,voy,voz)
    !
    ! computes the vorticity field
    !
    implicit none
    integer , intent(in ), dimension(3)        :: n
    real(rp), intent(in ), dimension(3)        :: dli
    real(rp), intent(in ), dimension(0:)       :: dzci
    real(rp), intent(in ), dimension(0:,0:,0:) :: ux ,uy ,uz
    real(rp), intent(out), dimension( :, :, :) :: vox,voy,voz
    real(rp) :: dxi,dyi
    integer :: i,j,k
    dxi = dli(1)
    dyi = dli(2)
    !$OMP PARALLEL DEFAULT(none) &
    !$OMP SHARED(n,dxi,dyi,dzci,ux,uy,uz,vox,voy,voz) &
    !$OMP PRIVATE(i,j,k)
    !$OMP DO
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          !
          ! x component of the vorticity at cell center
          !
          vox(i,j,k) = 0.25_rp*( &
                                (uz(i,j+1,k  )-uz(i,j  ,k  ))*dyi - (uy(i,j  ,k+1)-uy(i,j  ,k  ))*dzci(k  ) + &
                                (uz(i,j+1,k-1)-uz(i,j  ,k-1))*dyi - (uy(i,j  ,k  )-uy(i,j  ,k-1))*dzci(k-1) + &
                                (uz(i,j  ,k  )-uz(i,j-1,k  ))*dyi - (uy(i,j-1,k+1)-uy(i,j-1,k  ))*dzci(k  ) + &
                                (uz(i,j  ,k-1)-uz(i,j-1,k-1))*dyi - (uy(i,j-1,k  )-uy(i,j-1,k-1))*dzci(k-1) &
                               )
          !
          ! y component of the vorticity at cell center
          !
          voy(i,j,k) = 0.25_rp*( &
                                (ux(i  ,j,k+1)-ux(i  ,j,k  ))*dzci(k  ) - (uz(i+1,j,k  )-uz(i  ,j,k  ))*dxi + &
                                (ux(i  ,j,k  )-ux(i  ,j,k-1))*dzci(k-1) - (uz(i+1,j,k-1)-uz(i  ,j,k-1))*dxi + &
                                (ux(i-1,j,k+1)-ux(i-1,j,k  ))*dzci(k  ) - (uz(i  ,j,k  )-uz(i-1,j,k  ))*dxi + &
                                (ux(i-1,j,k  )-ux(i-1,j,k-1))*dzci(k-1) - (uz(i  ,j,k-1)-uz(i-1,j,k-1))*dxi &
                               )
          !
          ! z component of the vorticity at cell center
          !
          voz(i,j,k) = 0.25_rp*( &
                                (uy(i+1,j  ,k)-uy(i  ,j  ,k))*dxi - (ux(i  ,j+1,k)-ux(i  ,j  ,k))*dyi + &
                                (uy(i+1,j-1,k)-uy(i  ,j-1,k))*dxi - (ux(i  ,j  ,k)-ux(i  ,j-1,k))*dyi + &
                                (uy(i  ,j  ,k)-uy(i-1,j  ,k))*dxi - (ux(i-1,j+1,k)-ux(i-1,j  ,k))*dyi + &
                                (uy(i  ,j-1,k)-uy(i-1,j-1,k))*dxi - (ux(i-1,j  ,k)-ux(i-1,j-1,k))*dyi &
                               )
        end do
      end do
    end do
    !$OMP END PARALLEL
  end subroutine vorticity
  !
  subroutine strain_rate(n,dli,dzci,dzfi,ux,uy,uz,str)
    implicit none
    integer , intent(in ), dimension(3)        :: n
    real(rp), intent(in ), dimension(3)        :: dli
    real(rp), intent(in ), dimension(0:)       :: dzci,dzfi
    real(rp), intent(in ), dimension(0:,0:,0:) :: ux,uy,uz
    real(rp), intent(out), dimension(1:,1:,1:) :: str
    real(rp) :: s11,s22,s33,s12,s13,s23
    real(rp) :: dxi,dyi
    integer :: i,j,k
    dxi = dli(1)
    dyi = dli(2)
    !
    ! compute sijsij, where sij = (1/2)(du_i/dx_j + du_j/dx_i)
    !
    !$OMP PARALLEL DEFAULT(none) &
    !$OMP SHARED(n,dxi,dyi,dzci,dzfi,ux,uy,uz,str) &
    !$OMP PRIVATE(i,j,k,s11,s12,s13,s22,s23,s33)
    !$OMP DO
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          s11 = ((ux(i,j,k)-ux(i-1,j,k))*dxi    )**2
          s22 = ((uy(i,j,k)-uy(i,j-1,k))*dyi    )**2
          s33 = ((uz(i,j,k)-uz(i,j,k-1))*dzfi(k))**2
          s12 = .25_rp*( &
                        ((ux(i  ,j+1,k)-ux(i  ,j  ,k))*dyi + (uy(i+1,j  ,k)-uy(i  ,j  ,k))*dxi)**2 + &
                        ((ux(i  ,j  ,k)-ux(i  ,j-1,k))*dyi + (uy(i+1,j-1,k)-uy(i  ,j-1,k))*dxi)**2 + &
                        ((ux(i-1,j+1,k)-ux(i-1,j  ,k))*dyi + (uy(i  ,j  ,k)-uy(i-1,j  ,k))*dxi)**2 + &
                        ((ux(i-1,j  ,k)-ux(i-1,j-1,k))*dyi + (uy(i  ,j-1,k)-uy(i-1,j-1,k))*dxi)**2 &
                       )*.25_rp
          s13 = .25_rp*( &
                         ((ux(i  ,j,k+1)-ux(i  ,j,k  ))*dzci(k  ) + (uz(i+1,j,k  )-uz(i  ,j,k  ))*dxi)**2 + &
                         ((ux(i  ,j,k  )-ux(i  ,j,k-1))*dzci(k-1) + (uz(i+1,j,k-1)-uz(i  ,j,k-1))*dxi)**2 + &
                         ((ux(i-1,j,k+1)-ux(i-1,j,k  ))*dzci(k  ) + (uz(i  ,j,k  )-uz(i-1,j,k  ))*dxi)**2 + &
                         ((ux(i-1,j,k  )-ux(i-1,j,k-1))*dzci(k-1) + (uz(i  ,j,k-1)-uz(i-1,j,k-1))*dxi)**2 &
                       )*.25_rp
          s23 = .25_rp*( &
                        ((uy(i,j  ,k+1)-uy(i,j  ,k  ))*dzci(k  ) + (uz(i,j+1,k  )-uz(i,j  ,k  ))*dyi)**2 + &
                        ((uy(i,j  ,k  )-uy(i,j  ,k-1))*dzci(k-1) + (uz(i,j+1,k-1)-uz(i,j  ,k-1))*dyi)**2 + &
                        ((uy(i,j-1,k+1)-uy(i,j-1,k  ))*dzci(k  ) + (uz(i,j  ,k  )-uz(i,j-1,k  ))*dyi)**2 + &
                        ((uy(i,j-1,k  )-uy(i,j-1,k-1))*dzci(k-1) + (uz(i,j  ,k-1)-uz(i,j-1,k-1))*dyi)**2 &
                       )*.25_rp
          str(i,j,k) = s11+s22+s33 + 2*(s12+s13+s23)
        end do
      end do
    end do
    !$OMP END PARALLEL
  end subroutine strain_rate
  !
  subroutine rotation_rate(n,dli,dzci,ux,uy,uz,ens)
    implicit none
    integer , intent(in ), dimension(3)        :: n
    real(rp), intent(in ), dimension(3)        :: dli
    real(rp), intent(in ), dimension(0:)       :: dzci
    real(rp), intent(in ), dimension(0:,0:,0:) :: ux,uy,uz
    real(rp), intent(out), dimension(1:,1:,1:) :: ens
    real(rp) :: e12,e13,e23
    real(rp) :: dxi,dyi
    integer :: i,j,k
    !
    ! compute wijwij, where wij = (1/2)(du_i/dx_j - du_j/dx_i)
    !
    dxi = dli(1)
    dyi = dli(2)
    !$OMP PARALLEL DEFAULT(none) &
    !$OMP SHARED(n,dxi,dyi,dzci,ux,uy,uz,ens) &
    !$OMP PRIVATE(i,j,k,e12,e13,e23)
    !$OMP DO
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          e12 = .25_rp*( &
                        ((ux(i  ,j+1,k)-ux(i  ,j  ,k))*dyi - (uy(i+1,j  ,k)-uy(i  ,j  ,k))*dxi)**2 + &
                        ((ux(i  ,j  ,k)-ux(i  ,j-1,k))*dyi - (uy(i+1,j-1,k)-uy(i  ,j-1,k))*dxi)**2 + &
                        ((ux(i-1,j+1,k)-ux(i-1,j  ,k))*dyi - (uy(i  ,j  ,k)-uy(i-1,j  ,k))*dxi)**2 + &
                        ((ux(i-1,j  ,k)-ux(i-1,j-1,k))*dyi - (uy(i  ,j-1,k)-uy(i-1,j-1,k))*dxi)**2 &
                       )*.25_rp
          e13 = .25_rp*( &
                        ((ux(i  ,j,k+1)-ux(i  ,j,k  ))*dzci(k  ) - (uz(i+1,j,k  )-uz(i  ,j,k  ))*dxi)**2 + &
                        ((ux(i  ,j,k  )-ux(i  ,j,k-1))*dzci(k-1) - (uz(i+1,j,k-1)-uz(i  ,j,k-1))*dxi)**2 + &
                        ((ux(i-1,j,k+1)-ux(i-1,j,k  ))*dzci(k  ) - (uz(i  ,j,k  )-uz(i-1,j,k  ))*dxi)**2 + &
                        ((ux(i-1,j,k  )-ux(i-1,j,k-1))*dzci(k-1) - (uz(i  ,j,k-1)-uz(i-1,j,k-1))*dxi)**2 &
                       )*.25_rp
          e23 = .25_rp*( &
                        ((uy(i,j  ,k+1)-uy(i,j  ,k  ))*dzci(k  ) - (uz(i,j+1,k  )-uz(i,j  ,k  ))*dyi)**2 + &
                        ((uy(i,j  ,k  )-uy(i,j  ,k-1))*dzci(k-1) - (uz(i,j+1,k-1)-uz(i,j  ,k-1))*dyi)**2 + &
                        ((uy(i,j-1,k+1)-uy(i,j-1,k  ))*dzci(k  ) - (uz(i,j  ,k  )-uz(i,j-1,k  ))*dyi)**2 + &
                        ((uy(i,j-1,k  )-uy(i,j-1,k-1))*dzci(k-1) - (uz(i,j  ,k-1)-uz(i,j-1,k-1))*dyi)**2 &
                       )*.25_rp
          ens(i,j,k) =  2._rp*(e12+e13+e23)
        end do
      end do
    end do
    !$OMP END PARALLEL
  end subroutine rotation_rate
  !
  subroutine q_criterion(n,ens,str,qcr)
    implicit none
    integer , intent(in ), dimension(3)        :: n
    real(rp), intent(in ), dimension(1:,1:,1:) :: ens,str
    real(rp), intent(out), dimension(0:,0:,0:) :: qcr
    integer  :: i,j,k
    !$OMP PARALLEL DEFAULT(none) &
    !$OMP SHARED(n,ens,str,qcr) &
    !$OMP PRIVATE(i,j,k)
    !$OMP DO
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          qcr(i,j,k) = .5_rp*(ens(i,j,k)-str(i,j,k))
        end do
      end do
    end do
    !$OMP END PARALLEL
  end subroutine q_criterion
end module mod_post


SUBROUTINE kepler_z2k (r,v,GM , kepler)

! ----------------------------------------------------------------------
! SUBROUTINE: kepler_z2k.f90
! ----------------------------------------------------------------------
! Purpose:
!  Conversion of Position and Velocity vectors cartesian coordinates to
!  Keplerian elements  [a,e,i,Omega,omega,f,M,E,u]
! ----------------------------------------------------------------------
! Input arguments:
! - r:  		position (m)
! - v:  		velocity (m/sec)
! - GM: 		Earth gravity constant,  m^3/sec^2
!
! Output arguments:
!  - kepler:	Kepler elements
!    a:       	semi-major axis  (m)
!    e:      	eccentricity
!    i:      	inclination (degrees)
!    Omega:  	right ascension of the ascending node (degrees)
!    omega:  	argument of perigee (degrees)
!    f:      	true anomaly (degrees)
!    E:      	eccentric anomaly (degrees)
!    M:      	Mean anomaly (degrees)
!    u:      	argument of latitude (degrees)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia            21 April 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: r(3), v(3), GM
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: kepler(9)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: X,Y,Z, Vx,Vy,Vz
      REAL (KIND = prec_q) :: r_norm, v_norm
      REAL (KIND = prec_q) :: rr_dot, vv_dot, rv_dot, rv_norm
      REAL (KIND = prec_q) :: h(3), hh_dot, h_norm
      REAL (KIND = prec_q) :: W(3), Wx, Wy, Wz, p
      REAL (KIND = prec_q) :: i_y, i_x, i_rad
      REAL (KIND = prec_q) :: Omega_asc_rad, a, n, e, M_rad
      REAL (KIND = prec_q) :: E_y, E_x, E_rad
      REAL (KIND = prec_q) :: u_y, u_x, u_rad
      REAL (KIND = prec_q) :: f_y, f_x, f_rad
      REAL (KIND = prec_q) :: i_deg, Omega_asc_deg, E_deg, M_deg, u_deg, f_deg, omega_per_deg
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Position vector r = [ X Y Z ]'
X = r(1)
Y = r(2)
Z = r(3)

! Velocity vector v = [ Vx Vy Vz ]'
Vx = v(1)
Vy = v(2)
Vz = v(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! r vector magnitude (norm)
      CALL productdot(r, r, rr_dot)
      r_norm = sqrt(rr_dot)
! v vector magnitude (norm)
      CALL productdot(v, v, vv_dot)
      v_norm = sqrt(vv_dot)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! h: angular momentum (areal velocity vector)
!h = [ Y*Vz-Z*Vy
!      Z*Vx-X*Vz
!      X*Vy-Y*Vx ];
      h(1) = Y * Vz - Z * Vy
      h(2) = Z * Vx - X * Vz
      h(3) = X * Vy - Y * Vx
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! W (unit vector of h)
!W = h/sqrt(h'*h);
!Wx = W([1]);
!Wy = W([2]);
!Wz = W([3]);

! h length (norm)
      !h_norm = sqrt(h(1)**2 + h(2)**2 + h(3)**2)
      CALL productdot(h, h, hh_dot)
      h_norm = sqrt(hh_dot)

      W(1) = h(1) * (1.0D0 / h_norm)
      W(2) = h(2) * (1.0D0 / h_norm)
      W(3) = h(3) * (1.0D0 / h_norm)
      Wx = W(1)
      Wy = W(2)
      Wz = W(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! parameter p: semi-latus rectum
!p = (h'*h)/GM;
      p = hh_dot / GM
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! i: inclination (in radians)
!i = arctan( sqrt(Wx^2+Wy^2) , Wz );
!i_deg = i * (180/pi);
      i_y = sqrt(Wx**2 + Wy**2)
      i_x = Wz
      CALL arctan ( i_y, i_x , i_rad )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Omega: the right ascension of the ascending node (in radians)
!Omega = arctan( Wx , -Wy );
!Omega_deg = Omega * (180/pi);
      CALL arctan ( Wx, -1.0D0 * Wy , Omega_asc_rad )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! a: semi-major axis
!a = 1/( (2/sqrt(r'*r))-(v'*v)/ GM );
      a = 1.0D0 / ( 2.0D0 / r_norm - v_norm**2 / GM )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! n: the mean motion
!n = sqrt( GM /a^3);
      n = sqrt(GM / a**3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! e: the eccentricity
!e = sqrt(1- (p/a) );
      e = sqrt(1.0D0 - (p/a) )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! E: the eccentric anomaly (in radians)
!E = arctan( (r'*v)/(a^2*n) , 1-sqrt(r'*r)/a );
!E_deg = E * (180/pi);
      CALL productdot(r, v, rv_dot)
      rv_norm = sqrt(rv_dot)
      E_y = rv_dot / (a**2 * n)
      E_x = 1.0D0 - r_norm / a
      CALL arctan ( E_y, E_x , E_rad )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! M: Mean anomaly (in radians)
!M = E - e*sin(E);
!% converse in degrees
!M_deg = M * (180/pi);
      M_rad = E_rad - e * sin(E_rad)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! u: Argument of latitude (in radians)
!u = arctan( Z , -X*Wy+Y*Wx );
!% converse in degrees
!u_deg = u * (180/pi);
      u_y = Z
      u_x = -1.0D0 * X * Wy + Y * Wx
      CALL arctan ( u_y, u_x , u_rad )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! f : True anomaly (in radians)
!f = arctan( sqrt(1-e^2)*sin(E) , cos(E)-e );
!% converse in degrees
!f_deg = f * (180/pi);
      f_y = sqrt(1.0D0 - e**2) * sin(E_rad)
      f_x = cos(E_rad) - e
      CALL arctan ( f_y, f_x , f_rad )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Angular elements: radians to degrees
      i_deg = i_rad * (180D0 / PI_global)
      Omega_asc_deg = Omega_asc_rad * (180D0 / PI_global)
      E_deg = E_rad * (180D0 / PI_global)
      M_deg = M_rad * (180D0 / PI_global)
      u_deg = u_rad * (180D0 / PI_global)
      f_deg = f_rad * (180D0 / PI_global)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! omega : Argument of perigee (degrees)
!omega_deg = u_deg - f_deg;
!if omega_deg < 0
!    omega_deg = omega_deg + 360;
!end

      omega_per_deg = u_deg - f_deg
      if (omega_per_deg < 0.0D0) then
          omega_per_deg = omega_per_deg + 360D0
      end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Keplerian elements (angular elements in degrees)
!  - kepler:	Kepler elements
!    a:       	semi-major axis  (m)
!    e:      	eccentricity
!    i:      	inclination
!    Omega:  	right ascension of the ascending node
!    omega:  	argument of perigee
!    f:      	true anomaly
!    E:      	eccentric anomaly
!    M:      	Mean anomaly
!    u:      	argument of latitude

! kepler = [a,e,i,Omega,omega,f,M,E,u]
      kepler(1) = a
      kepler(2) = e
      kepler(3) = i_deg
      kepler(4) = Omega_asc_deg
      kepler(5) = omega_per_deg
      kepler(6) = f_deg
      kepler(7) = E_deg
      kepler(8) = M_deg
      kepler(9) = u_deg
! ----------------------------------------------------------------------

end


      SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP,
     $                   LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients of a minimal polynomial basis
C                                                 DK
C         K(s) = K(0) + K(1) * s + ... + K(DK) * s
C
C     for the right nullspace of the MP-by-NP polynomial matrix of
C     degree DP, given by
C                                                 DP
C         P(s) = P(0) + P(1) * s + ... + P(DP) * s  ,
C
C     which corresponds to solving the polynomial matrix equation
C     P(s) * K(s) = 0.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     MP      (input) INTEGER
C             The number of rows of the polynomial matrix P(s).
C             MP >= 0.
C
C     NP      (input) INTEGER
C             The number of columns of the polynomial matrix P(s).
C             NP >= 0.
C
C     DP      (input) INTEGER
C             The degree of the polynomial matrix P(s).  DP >= 1.
C
C     P       (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1)
C             The leading MP-by-NP-by-(DP+1) part of this array must
C             contain the coefficients of the polynomial matrix P(s).
C             Specifically, P(i,j,k) must contain the (i,j)-th element
C             of P(k-1), which is the cofficient of s**(k-1) of P(s),
C             where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1.
C
C     LDP1    INTEGER
C             The leading dimension of array P.  LDP1 >= MAX(1,MP).
C
C     LDP2    INTEGER
C             The second dimension of array P.   LDP2 >= MAX(1,NP).
C
C     DK      (output) INTEGER
C             The degree of the minimal polynomial basis K(s) for the
C             right nullspace of P(s) unless DK = -1, in which case
C             there is no right nullspace.
C
C     GAM     (output) INTEGER array, dimension (DP*MP+1)
C             The leading (DK+1) elements of this array contain
C             information about the ordering of the right nullspace
C             vectors stored in array NULLSP.
C
C     NULLSP  (output) DOUBLE PRECISION array, dimension
C             (LDNULL,(DP*MP+1)*NP)
C             The leading NP-by-SUM(i*GAM(i)) part of this array
C             contains the right nullspace vectors of P(s) in condensed
C             form (as defined in METHOD), where i = 1,2,...,DK+1.
C
C     LDNULL  INTEGER
C             The leading dimension of array NULLSP.
C             LDNULL >= MAX(1,NP).
C
C     KER     (output) DOUBLE PRECISION array, dimension
C             (LDKER1,LDKER2,DP*MP+1)
C             The leading NP-by-nk-by-(DK+1) part of this array contains
C             the coefficients of the minimal polynomial basis K(s),
C             where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically,
C             KER(i,j,m) contains the (i,j)-th element of K(m-1), which
C             is the coefficient of s**(m-1) of K(s), where i = 1,2,...,
C             NP, j = 1,2,...,nk and m = 1,2,...,DK+1.
C
C     LDKER1  INTEGER
C             The leading dimension of array KER.  LDKER1 >= MAX(1,NP).
C
C     LDKER2  INTEGER
C             The second dimension of array KER.   LDKER2 >= MAX(1,NP).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance below which matrix elements are considered
C             to be zero. If the user sets TOL to be less than
C             10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is
C                                  F       F
C             taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the
C                                           F       F
C             machine precision (see LAPACK Library Routine DLAMCH) and
C             A and E are matrices (as defined in METHOD).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (m+2*MAX(n,m+1)+n),
C             where m = DP*MP and n = (DP-1)*MP + NP.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= m*n*n + 2*m*n + 2*n*n.
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             > 0:  if incorrect rank decisions were taken during the
C                   computations. This failure is not likely to occur.
C                   The possible values are:
C                     k, 1 <= k <= DK+1, the k-th diagonal submatrix had
C                           not a full row rank;
C                     DK+2, if incorrect dimensions of a full column
C                           rank submatrix;
C                     DK+3, if incorrect dimensions of a full row rank
C                           submatrix.
C
C     METHOD
C
C     The computation of the right nullspace of the MP-by-NP polynomial
C     matrix P(s) of degree DP given by
C                                                  DP-1            DP
C        P(s) = P(0) + P(1) * s + ... + P(DP-1) * s     + P(DP) * s
C
C     is performed via the pencil s*E - A, associated with P(s), where
C
C            | I              |           | 0         -P(DP) |
C            |   .            |           | I .          .   |
C        A = |     .          |  and  E = |   . .        .   |.      (1)
C            |       .        |           |     . 0      .   |
C            |         I      |           |       I 0 -P(2)  |
C            |           P(0) |           |         I -P(1)  |
C
C     The pencil s*E - A is transformed by unitary matrices Q and Z such
C     that
C
C                     | sE(eps)-A(eps) |        X       |      X     |
C                     |----------------|----------------|------------|
C                     |        0       | sE(inf)-A(inf) |      X     |
C        Q'(s*E-A)Z = |=================================|============|.
C                     |                                 |            |
C                     |                0                | sE(r)-A(r) |
C
C     Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the
C     minimal polynomial basis for the right nullspace of Q'(s*E-A)Z
C     (and consequently the basis for the right nullspace of s*E - A) is
C     completely determined by s*E(eps)-A(eps).
C
C     Let Veps(s) be a minimal polynomial basis for the right nullspace
C     of s*E(eps)-A(eps). Then
C
C                   | Veps(s) |
C        V(s) = Z * |---------|
C                   |    0    |
C
C     is a minimal polynomial basis for the right nullspace of s*E - A.
C     From the structure of s*E - A it can be shown that if V(s) is
C     partitioned as
C
C               | Vo(s) | (DP-1)*MP
C        V(s) = |------ |
C               | Ve(s) | NP
C
C     then the columns of Ve(s) form a minimal polynomial basis for the
C     right nullspace of P(s).
C
C     The vectors of Ve(s) are computed and stored in array NULLSP in
C     the following condensed form:
C
C        ||      ||      |      ||      |      |      ||      |     |
C        || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |,
C        ||      ||      |      ||      |      |      ||      |     |
C
C     where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block
C     of columns of K(j), the j-th coefficient of the polynomial matrix
C     representation for the right nullspace
C                                                  DK
C        K(s) = K(0) + K(1) * s + . . . + K(DK) * s  .
C
C     The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices
C     given by
C
C        K(0)  = | U1,0 | U2,0 | U3,0 | . . .          | U(DK+1,0) |
C
C        K(1)  = |  0   | U2,1 | U3,1 | . . .          | U(DK+1,1) |
C
C        K(2)  = |  0   |  0   | U3,2 | . . .          | U(DK+1,2) |
C
C          .     .     .     .     .     .     .     .     .     .
C
C        K(DK) = |  0   |  0   |  0   | . . .    |  0  | U(DK+1,DK)|.
C
C     Note that the degree of K(s) satisfies the inequality DK <=
C     DP * MIN(MP,NP) and that the dimension of K(s) satisfies the
C     inequality (NP-MP) <= nk <= NP.
C
C     REFERENCES
C
C     [1] Beelen, Th.G.J.
C         New Algorithms for Computing the Kronecker structure of a
C         Pencil with Applications to Systems and Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology, 1987.
C
C     [2] Van Den Hurk, G.J.H.H.
C         New Algorithms for Solving Polynomial Matrix Problems.
C         Master's Thesis, Eindhoven University of Technology, 1987.
C
C     NUMERICAL ASPECTS
C
C     The algorithm used by the routine involves the construction of a
C     special block echelon form with pivots considered to be non-zero
C     when they are larger than TOL. These pivots are then inverted in
C     order to construct the columns of the kernel of the polynomial
C     matrix. If TOL is chosen to be too small then these inversions may
C     be sensitive whereas increasing TOL will make the inversions more
C     robust but will affect the block echelon form (and hence the
C     column degrees of the polynomial kernel). Furthermore, if the
C     elements of the computed polynomial kernel are large relative to
C     the polynomial matrix, then the user should consider trying
C     several values of TOL.
C
C     FURTHER COMMENTS
C
C     It also possible to compute a minimal polynomial basis for the
C     right nullspace of a pencil, since a pencil is a polynomial matrix
C     of degree 1. Thus for the pencil (s*E - A), the required input is
C     P(1)  = E and P(0) = -A.
C
C     The routine can also be used to compute a minimal polynomial
C     basis for the left nullspace of a polynomial matrix by simply
C     transposing P(s).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC03BD by A.J. Geurts and MC03BZ by
C     Th.G.J. Beelen, A.J. Geurts, and G.J.H.H. van den Hurk.
C
C     REVISIONS
C
C     Jan. 1998.
C
C     KEYWORDS
C
C     Echelon form, elementary polynomial operations, input output
C     description, polynomial matrix, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TEN
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DK, DP, INFO, LDKER1, LDKER2, LDNULL, LDP1,
     $                  LDP2, LDWORK, MP, NP
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           GAM(*), IWORK(*)
      DOUBLE PRECISION  DWORK(*), KER(LDKER1,LDKER2,*),
     $                  NULLSP(LDNULL,*), P(LDP1,LDP2,*)
C     .. Local Scalars ..
      INTEGER           GAMJ, H, I, IDIFF, IFIR, J, JWORKA, JWORKE,
     $                  JWORKQ, JWORKV, JWORKZ, K, M, MUK, N, NBLCKS,
     $                  NBLCKI, NCA, NCV, NRA, NUK, RANKE, SGAMK, TAIL,
     $                  VC1, VR2
      DOUBLE PRECISION  TOLER
C     .. Local Arrays ..
      INTEGER           MNEI(3)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANGE, DLAPY2
      EXTERNAL          DLAMCH, DLANGE, DLAPY2
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DLACPY, DLASET, MB04UD, MB04VD, MC03NX,
     $                  MC03NY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, SQRT
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      M = DP*MP
      H = M - MP
      N = H + NP
      INFO = 0
      IF( MP.LT.0 ) THEN
         INFO = -1
      ELSE IF( NP.LT.0 ) THEN
         INFO = -2
      ELSE IF( DP.LE.0 ) THEN
         INFO = -3
      ELSE IF( LDP1.LT.MAX( 1, MP ) ) THEN
         INFO = -5
      ELSE IF( LDP2.LT.MAX( 1, NP ) ) THEN
         INFO = -6
      ELSE IF( LDNULL.LT.MAX( 1, NP ) ) THEN
         INFO = -10
      ELSE IF( LDKER1.LT.MAX( 1, NP ) ) THEN
         INFO = -12
      ELSE IF( LDKER2.LT.MAX( 1, NP ) ) THEN
         INFO = -13
      ELSE IF( LDWORK.LT.( N*( M*N + 2*( M + N ) ) ) ) THEN
         INFO = -17
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC03ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MP.EQ.0 .OR. NP.EQ.0 ) THEN
         DK = -1
         RETURN
      END IF
C
      JWORKA = 1
      JWORKE = JWORKA + M*N
      JWORKZ = JWORKE + M*N
      JWORKV = JWORKZ + N*N
      JWORKQ = JWORKA
C
C     Construct the matrices A and E in the pencil s*E-A in (1).
C     Workspace:  2*M*N.
C
      CALL MC03NX( MP, NP, DP, P, LDP1, LDP2, DWORK(JWORKA), M,
     $             DWORK(JWORKE), M )
C
C     Computation of the tolerance.
C
      TOLER = MAX( DLANGE( 'F', M,  NP, DWORK(JWORKE+H*M), M, DWORK ),
     $             DLANGE( 'F', MP, NP, P, LDP1, DWORK ) )
      TOLER = TEN*DLAMCH( 'Epsilon' )
     $           *DLAPY2( TOLER, SQRT( DBLE( H ) ) )
      IF ( TOLER.LE.TOL ) TOLER = TOL
C
C     Reduction of E to column echelon form E0 = Q' x E x Z and
C     transformation of A, A0 = Q' x A x Z.
C     Workspace:  2*M*N + N*N + max(M,N).
C
      CALL MB04UD( 'No Q', 'Identity Z', M, N, DWORK(JWORKA), M,
     $             DWORK(JWORKE), M, DWORK(JWORKQ), M, DWORK(JWORKZ), N,
     $             RANKE, IWORK, TOLER, DWORK(JWORKV), INFO )
C
C     The contents of ISTAIR is transferred from MB04UD to MB04VD by
C     IWORK(i), i=1,...,M.
C     In the sequel the arrays IMUK and INUK are part of IWORK, namely:
C     IWORK(i), i = M+1,...,M+max(N,M+1), contains IMUK,
C     IWORK(i), i = M+max(N,M+1)+1,...,M+2*max(N,M+1), contains INUK.
C     IWORK(i), i = M+2*max(N,M+1)+1,...,M+2*max(N,M+1)+N, contains
C               IMUK0 (not needed), and is also used as workspace.
C
      MUK  = M + 1
      NUK  = MUK + MAX( N, M+1 )
      TAIL = NUK + MAX( N, M+1 )
C
      CALL MB04VD( 'Separation', 'No Q', 'Update Z', M, N, RANKE,
     $             DWORK(JWORKA), M, DWORK(JWORKE), M, DWORK(JWORKQ), M,
     $             DWORK(JWORKZ), N, IWORK, NBLCKS, NBLCKI, IWORK(MUK),
     $             IWORK(NUK), IWORK(TAIL), MNEI, TOLER, IWORK(TAIL),
     $             INFO )
      IF ( INFO.GT.0 ) THEN
C
C        Incorrect rank decisions.
C
         INFO = INFO + NBLCKS
         RETURN
      END IF
C
C     If NBLCKS < 1, or the column dimension of s*E(eps) - A(eps) is
C     zero, then there is no right nullspace.
C
      IF ( NBLCKS.LT.1 .OR. MNEI(2).EQ.0 ) THEN
         DK = -1
         RETURN
      END IF
C
C     Start of the computation of the minimal basis.
C
      DK = NBLCKS - 1
      NRA = MNEI(1)
      NCA = MNEI(2)
C
C     Determine a minimal basis VEPS(s) for the right nullspace of the
C     pencil s*E(eps)-A(eps) associated with the polynomial matrix P(s).
C     Workspace:  2*M*N + N*N + N*N*(M+1).
C
      CALL MC03NY( NBLCKS, NRA, NCA, DWORK(JWORKA), M, DWORK(JWORKE), M,
     $             IWORK(MUK), IWORK(NUK), DWORK(JWORKV), N, INFO )
C
      IF ( INFO.GT.0 )
     $   RETURN
C
      NCV = IWORK(MUK) - IWORK(NUK)
      GAM(1) = NCV
      IWORK(1) = 0
      IWORK(TAIL) = IWORK(MUK)
C
      DO 20 I = 2, NBLCKS
         IDIFF = IWORK(MUK+I-1) - IWORK(NUK+I-1)
         GAM(I) = IDIFF
         IWORK(I) = NCV
         NCV = NCV + I*IDIFF
         IWORK(TAIL+I-1) = IWORK(TAIL+I-2) + IWORK(MUK+I-1)
   20 CONTINUE
C
C     Determine a basis for the right nullspace of the polynomial
C     matrix P(s). This basis is stored in array NULLSP in condensed
C     form.
C
      CALL DLASET( 'Full', NP, NCV, ZERO, ZERO, NULLSP, LDNULL )
C
C                                                |VEPS(s)|
C     The last NP rows of the product matrix Z x |-------| contain the
C                                                |   0   |
C     polynomial basis for the right nullspace of the polynomial matrix
C     P(s) in condensed form. The multiplication is restricted to the
C     nonzero submatrices Vij,k of VEPS, the result is stored in the
C     array NULLSP.
C
      VC1 = 1
C
      DO 60 I = 1, NBLCKS
         VR2 = IWORK(TAIL+I-1)
C
         DO 40 J = 1, I
C
C           Multiplication of Z(H+1:N,1:VR2) with V.i,j-1 stored in
C           VEPS(1:VR2,VC1:VC1+GAM(I)-1).
C
            CALL DGEMM( 'No transpose', 'No transpose', NP, GAM(I), VR2,
     $                  ONE, DWORK(JWORKZ+H), N,
     $                  DWORK(JWORKV+(VC1-1)*N), N, ZERO, NULLSP(1,VC1),
     $                  LDNULL )
            VC1 = VC1 + GAM(I)
            VR2 = VR2 - IWORK(MUK+I-J)
   40    CONTINUE
C
   60 CONTINUE
C
C     Transfer of the columns of NULLSP to KER in order to obtain the
C     polynomial matrix representation of K(s), the right nullspace
C     of P(s).
C
      SGAMK = 1
C
      DO 100 K = 1, NBLCKS
         CALL DLASET( 'Full', NP, SGAMK-1, ZERO, ZERO, KER(1,1,K),
     $                LDKER1 )
         IFIR = SGAMK
C
C        Copy the appropriate columns of NULLSP into KER(k).
C        SGAMK = 1 + SUM(i=1,..,k-1) GAM(i), is the first nontrivial
C        column of KER(k), the first SGAMK - 1 columns of KER(k) are
C        zero. IFIR denotes the position of the first column in KER(k)
C        in the set of columns copied for a value of J.
C        VC1 is the first column of NULLSP to be copied.
C
         DO 80 J = K, NBLCKS
            GAMJ = GAM(J)
            VC1 = IWORK(J) + (K-1)*GAMJ + 1
            CALL DLACPY( 'Full', NP, GAMJ, NULLSP(1,VC1), LDNULL,
     $                   KER(1,IFIR,K), LDKER1 )
            IFIR = IFIR + GAMJ
   80    CONTINUE
C
         SGAMK = SGAMK + GAM(K)
  100 CONTINUE
C
      RETURN
C *** Last line of MC03ND ***
      END


	FUNCTION PS_STAP  ( datain, nparm, clev, ivcord )
C************************************************************************
C* PS_STAP								*
C*									*
C* This function computes the stability as the negative of the		*
C* potential temperature vertical gradient with respect to pressure.	*
C*									*
C* REAL PS_STAP  ( DATAIN, NPARM, CLEV, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN		REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	PS_STAP		REAL		Stability ( - d THETA / dp)	*
C**									*
C* Log:									*
C* J. Nielsen/SUNYA	 8/90						*
C* T. Lee/GSC		 8/97	Changed default depth to RMISSD		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		stndl (10), stndb (10), stndt (10)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
	PS_STAP = RMISSD
C
C*	Get the depth.
C
	dfdpth = RMISSD
	idfcrd = 1
	CALL PC_DPTH  ( datain, nparm, clev, ivcord, dfdpth, idfcrd, 1,
     +			depth, idcord, stndl, stndb, stndt, ier )
C
C*	Check for missing data.
C
	IF  ( ( ier .ne. 0 ) .or. ERMISS ( stndt (2) ) .or.
     +	      ERMISS ( stndb (2) ) )  RETURN
	deltap = stndt (1) - stndb (1)
	IF  ( deltap .eq. 0.0 )  RETURN
C*
	thtop = PR_THTA ( stndt (2), stndt (1) )
	thbot = PR_THTA ( stndb (2), stndb (1) )

	PS_STAP = - (( thtop - thbot ) / ( deltap * 100.0 ))
C*
	RETURN
	END


* This file contains the following subroutines, related to the
* spherical geometry of the Earth's atmosphere
*     sphers
*     airmas
*=============================================================================*

      SUBROUTINE sphers(nz, z, zen, dsdh, nid)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Calculate slant path over vertical depth ds/dh in spherical geometry.    =*
*=  Calculation is based on:  A.Dahlback, and K.Stamnes, A new spheric model =*
*=  for computing the radiation field available for photolysis and heating   =*
*=  at twilight, Planet.Space Sci., v39, n5, pp. 671-683, 1991 (Appendix B)  =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NZ      - INTEGER, number of specified altitude levels in the working (I)=*
*=            grid                                                           =*
*=  Z       - REAL, specified altitude working grid (km)                  (I)=*
*=  ZEN     - REAL, solar zenith angle (degrees)                          (I)=*
*=  DSDH    - REAL, slant path of direct beam through each layer crossed  (O)=*
*=            when travelling from the top of the atmosphere to layer i;     =*
*=            DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1                            =*
*=  NID     - INTEGER, number of layers crossed by the direct beam when   (O)=*
*=            travelling from the top of the atmosphere to layer i;          =*
*=            NID(i), i = 0..NZ-1                                            =*
*-----------------------------------------------------------------------------*
*=  EDIT HISTORY:                                                            =*
*=  double precision fix for shallow layers - Julia Lee-Taylor Dec 2000      =*
*-----------------------------------------------------------------------------*
*= This program is free software;  you can redistribute it and/or modify     =*
*= it under the terms of the GNU General Public License as published by the  =*
*= Free Software Foundation;  either version 2 of the license, or (at your   =*
*= option) any later version.                                                =*
*= The TUV package is distributed in the hope that it will be useful, but    =*
*= WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTIBI-  =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public     =*
*= License for more details.                                                 =*
*= To obtain a copy of the GNU General Public License, write to:             =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.   =*
*-----------------------------------------------------------------------------*
*= To contact the authors, please mail to:                                   =*
*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA  or =*
*= send email to:  sasha@ucar.edu                                            =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

* input
      INTEGER nz
      REAL zen, z(kz)

* output
      INTEGER nid(0:kz)
      REAL dsdh(0:kz,kz)

* more program constants
      REAL re, ze(kz)
      REAL  dr
      PARAMETER ( dr = pi/180.)

* local

      DOUBLE PRECISION zenrad, rpsinz, rj, rjp1, dsj, dhj, ga, gb, sm
      INTEGER i, j, k
      INTEGER id

      INTEGER nlayer
      REAL zd(0:kz-1)

*-----------------------------------------------------------------------------

      zenrad = zen*dr

* number of layers:
      nlayer = nz - 1

* include the elevation above sea level to the radius of the earth:
      re = radius + z(1)
* correspondingly z changed to the elevation above earth surface:
      DO k = 1, nz
         ze(k) = z(k) - z(1)
      END DO

* inverse coordinate of z
      zd(0) = ze(nz)
      DO k = 1, nlayer
        zd(k) = ze(nz - k)
      END DO

* initialize dsdh(i,j), nid(i)
      DO i = 0, kz
       nid(i) = 0
       DO j = 1, kz
        dsdh(i,j) = 0.
       END DO
      END DO

* calculate ds/dh of every layer
      DO 100 i = 0, nlayer

        rpsinz = (re + zd(i)) * SIN(zenrad)

        IF ( (zen .GT. 90.0) .AND. (rpsinz .LT. re) ) THEN
           nid(i) = -1
        ELSE

*
* Find index of layer in which the screening height lies
*
           id = i
           IF( zen .GT. 90.0 ) THEN
              DO 10 j = 1, nlayer
                 IF( (rpsinz .LT. ( zd(j-1) + re ) ) .AND.
     $               (rpsinz .GE. ( zd(j) + re )) ) id = j
 10           CONTINUE
           END IF

           DO 20 j = 1, id

             sm = 1.0
             IF(j .EQ. id .AND. id .EQ. i .AND. zen .GT. 90.0)
     $          sm = -1.0

             rj = re + zd(j-1)
             rjp1 = re + zd(j)

             dhj = zd(j-1) - zd(j)

             ga = rj*rj - rpsinz*rpsinz
             gb = rjp1*rjp1 - rpsinz*rpsinz
             IF (ga .LT. 0.0) ga = 0.0
             IF (gb .LT. 0.0) gb = 0.0

             IF(id.GT.i .AND. j.EQ.id) THEN
                dsj = SQRT( ga )
             ELSE
                dsj = SQRT( ga ) - sm*SQRT( gb )
             END IF
             dsdh(i,j) = dsj / dhj
 20        CONTINUE

           nid(i) = id

        END IF

 100  CONTINUE

*-----------------------------------------------------------------------------

      RETURN
      END

*=============================================================================*

      SUBROUTINE airmas(nz, dsdh, nid, cz,
     $      vcol, scol)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Calculate vertical and slant air columns, in spherical geometry, as a    =*
*=  function of altitude.                                                    =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NZ      - INTEGER, number of specified altitude levels in the working (I)=*
*=            grid                                                           =*
*=  DSDH    - REAL, slant path of direct beam through each layer crossed  (O)=*
*=            when travelling from the top of the atmosphere to layer i;     =*
*=            DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1                            =*
*=  NID     - INTEGER, number of layers crossed by the direct beam when   (O)=*
*=            travelling from the top of the atmosphere to layer i;          =*
*=            NID(i), i = 0..NZ-1                                            =*
*=  VCOL    - REAL, output, vertical air column, molec cm-2, above level iz  =*
*=  SCOL    - REAL, output, slant air column in direction of sun, above iz   =*
*=            also in molec cm-2                                             =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

* Input:

      INTEGER nz
      INTEGER nid(0:kz)
      REAL dsdh(0:kz,kz)
      REAL cz(kz)

* output:

      REAL vcol(kz), scol(kz)

* internal:

      INTEGER id, j
      REAL sum, vsum

* calculate vertical and slant column from each level:
* work downward

      vsum = 0.
      DO id = 0, nz - 1
         vsum = vsum + cz(nz-id)
         vcol(nz-id) = vsum
         sum = 0.
         IF(nid(id) .LT. 0) THEN
            sum = largest
         ELSE

* single pass layers:

            DO j = 1, MIN(nid(id), id)
               sum = sum + cz(nz-j)*dsdh(id,j)
            ENDDO

* double pass layers:

            DO j = MIN(nid(id),id)+1, nid(id)
               sum = sum + 2.*cz(nz-j)*dsdh(id,j)
            ENDDO

         ENDIF
         scol(nz - id) = sum

      ENDDO

      RETURN
      END


  subroutine cross_section_Rayleigh(   &
    nsmax,       wavelength_ns,  relN2,    &
    relO2,       relAr,          eps_N2,   &
    eps_O2,      eps_Ar,         csray_N2, &
    csray_O2,    csray_Ar)

!-----------------------------------------------------------
! Subroutine:
!    csray
!
! Purpose:
!    Calculate Rayleigh cross section for
!    N2, O2, Ar, and air
!------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

! nr of wavelengths
  integer,intent(in):: &
     nsmax
! wavelengths around incident light (ns_elas) [nm]
  real(kind=dp):: &
    wavelength_ns(0:nsmax)

  real(kind=dp),intent(in):: &
     relN2, & !N2 volume mixing ratio
     relO2, & !O2 volume mixing ratio
     relAr    !Ar volume mixing ratio

  real(kind=dp),dimension(0:nsmax):: &
    rn_N2,      & !refraction index of N2
    rn_O2,      & !refraction index of O2
    rn_Ar         !refraction index of Ar

  real(kind=dp):: &
    Wcm,        & !wavelengthlength [cm]
    WNmu,       & !1/wavelengthlength [um-1]
    frac_rn_N2, &
    frac_rn_O2, &
    frac_rn_Ar, &
    rn_N2m1,    &
    rn_O2m1,    &
    rn_Arm1,    &
    fk_N2,      & !King factor
    fk_O2,      &
    fk_Ar,      &
    dens

! parametrization of refraction index of N2 and O2 ( Bates 1984 )
  real(kind=dp):: &
     a_N2(3),   &
     b_N2(3),   &
     a_O2(4),   &
     b_O2(4)
  data &
     a_N2 / 6855.200d0,  5989.242d0,  6998.749d0             /, &
     b_N2 / 3243157.0d0, 3363266.3d0, 3233582.0d0            /, &
     a_O2 / 21351.1d0,   20564.8d0,   22120.4d0,  23796.7d0  /, &
     b_O2 / 218567.0d0,  248089.9d0,  203187.6d0, 168988.4d0 /

  real(kind=dp),parameter::    &
     pi       = 3.141592653589793115997963468544d0, &
     temp_std = 273.15d0,    & !standard temperature [K]
     Dair     = 2.54743D+19    !molar nrdensity air [part. cm-3]

  integer::ni

  real(kind=dp),dimension(0:nsmax):: &
     csray_air    !Rayleigh cross sections for air

  real(kind=dp),dimension(0:nsmax),intent(out):: &
     eps_N2,   &  !epsilon for N2
     eps_O2,   &  !epsilon for O2
     eps_AR,   &  !epsilon for Ar = 0
     csray_O2, &  !Rayleigh cross sections for O2 molecules
     csray_N2, &  !Rayleigh cross sections for N2 molecules
     csray_Ar     !Rayleigh cross sections for Ar atoms

  integer::ns

  do ns=0,nsmax

     WNmu = (1.d+07/wavelength_ns(ns)) * 1.d-4

!    King correction factor
     fk_N2 = 1.034d0 + 3.17d-4 * WNmu**2
     fk_O2 = 1.096d0 + 1.385d-03*WNmu**2 + 1.448d-4*WNmu**4
     fk_Ar = 1.d0

!    anisotropic polarizability factor eps
     eps_N2(ns) = 9.d0/2.d0 * (fk_N2-1.d0)
     eps_O2(ns) = 9.d0/2.d0 * (fk_O2-1.d0)
     eps_Ar(ns) = 0.d0

!    refraction index of N2  (n(N2)-1) [Bates1984]
     ni = 1
     if(wavelength_ns(ns).lT.468.d0) ni = 2
     if(wavelength_ns(ns).lT.254.d0) ni = 3
     rn_N2m1  = (a_N2(ni) + b_N2(ni)/(144.d0-WNmu**2))*1.d-08
     rn_N2(ns) = 1.d0 + rn_N2m1

!    refraction index of O2  (n(O2)-1) [Bates1984]
     ni = 1
     if(wavelength_ns(ns).lT.546.d0)  ni = 2
     if(wavelength_ns(ns).lT.288.d0)  ni = 3
     if(wavelength_ns(ns).lT.221.d0)  ni = 4
     rn_O2m1  = (a_O2(ni) + b_O2(ni)/(40.90d0-WNmu**2))*1.d-08
     rn_O2(ns) = 1.d0 + rn_O2m1

!    refraction index of Ar (n(Ar)-1)  [Peck and Fisher1964]
     rn_Arm1  = (678.6711d0 + 301829.43d0/(144.d0-WNmu**2))*1.d-07
     rn_Ar(ns) = 1.d0 + rn_Arm1

!    (n**2-1)/(n**2+2)
     frac_rn_N2 = (rn_N2(ns)**2-1.d0)**2/(rn_N2(ns)**2+2.d0)**2
     frac_rn_O2 = (rn_O2(ns)**2-1.d0)**2/(rn_O2(ns)**2+2.d0)**2
     frac_rn_Ar = (rn_Ar(ns)**2-1.d0)**2/(rn_Ar(ns)**2+2.d0)**2

!    Dair is given for 15 degree Celius
!    scale to standard temp T = 273.15 K because of refractive index

     dens = (288.16d0/temp_std) * Dair

     Wcm = wavelength_ns(ns) * 1.d-7 !change units nm -> cm

     csray_N2(ns) = 24.d0*pi**3/(Wcm**4*dens**2)*frac_rn_N2*fk_N2
     csray_O2(ns) = 24.d0*pi**3/(Wcm**4*dens**2)*frac_rn_O2*fk_O2
     csray_Ar(ns) = 24.d0*pi**3/(Wcm**4*dens**2)*frac_rn_Ar*fk_Ar

     csray_air(ns) = relN2 * csray_N2(ns) + &
                     relO2 * csray_O2(ns) + &
                     relAr * csray_Ar(ns)

  enddo

  return

end subroutine cross_section_Rayleigh


program foo
   integer, dimension (2, 3) :: a
   integer, dimension (2, 2, 3) :: b
   character (len=80) line1, line2, line3

   a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/))
   b = spread (a, 1, 2)
   if (any (b .ne. reshape ((/1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6/), &
                            (/2, 2, 3/)))) &
      call abort
   write(line1, 9000) b
   write(line2, 9000) spread (a, 1, 2)
   if (line1 /= line2) call abort
   write(line3, 9000) spread (a, 1, 2) + 0
   if (line1 /= line3) call abort
9000 format(12I3)
end program


subroutine djpi2(dj, lmax, exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine computes
!     j
!   d     (pi/2)
!     m N
!
!   for all posible values of m (>=0) and N for 0<l<lmax.
!   The output array corresponds to dj(N,m,j). (I'm not positive
!   about the N and m ordering).
!
!   Note that this algorithm is easy to modify to work on a
!   single l (just need a loop to compute f1) since there are
!   no l recursions involved.
!
!   Calling Parameters
!
!       IN
!           lmax    Maximum spherical harmonic degree to be computed.
!
!       OUT
!           dj  Rotation matrix with dimensions (lmax+1, lmax+1, lmax+1).
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   History
!
!       1. Based on routine from Guy Masters (July 16, 1993)
!       2. Modified by Mark Simons (July 19, 1993)
!       3. Turned into readable f95 code by Mark Wieczorek (August, 2003).
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    integer, intent(in) :: lmax
    real(dp), intent(out) :: dj(:,:,:)
    integer, intent(out), optional :: exitstatus
    integer :: i, l, n, lp1, j, m, isn, np
    real(dp) :: f((lmax+1)*8), f1, f2, g1, g2, en2, fl2p1

    if (present(exitstatus)) exitstatus = 0

    if (size(dj(:,1,1)) < lmax+1 .or. size(dj(1,:,1)) < lmax + 1 .or. &
            size(dj(1,1,:)) < lmax +1) then
        print*, "Error --- djpi2"
        print*, "DJ must be dimensioned (LMAX+1, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(dj(:,1,1)), &
                size(dj(1,:,1)), size(dj(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    dj = 0.0_dp

    dj(1,1,1) = 1.0_dp
    dj(1,1,2) = 0.0_dp
    dj(1,2,2) = -1.0_dp / sqrt(2.0_dp)
    dj(2,1,2) = -dj(1,2,2)
    dj(2,2,2) = 0.5_dp
    f1        = 0.5_dp

    do l = 2, lmax

        lp1 = l + 1
        fl2p1 = l + lp1

        do i = 1, l
            f(i) = dsqrt(i * (fl2p1-i))
        end do

            f1 = f1 * (l+l-1.0_dp) / (l+l)

        ! Do N = 0 terms
        dj(lp1,1,lp1) = -dsqrt(f1)
        dj(l,1,lp1)   = 0.0_dp

        do i = 2, l
            j = lp1 - i
            dj(j,1,lp1) = -f(i-1) * dj(j+2,1,lp1) / f(i)
        end do

        ! Do positive N terms (bottom triangle)
        f2 = f1
        g1 = l
        g2 = lp1

        do n = 1, l
            np = n + 1
            en2 = n + n
            g1 = g1 + 1.0_dp
            g2 = g2 - 1.0_dp
            f2 = f2 * g2 / g1
            dj(lp1,np,lp1) = -dsqrt(f2)
            dj(l,np,lp1) = dj(lp1,np,lp1) * en2 / f(1)

            do i = 2, l - n
                j = lp1 - i
                dj(j,np,lp1) = ( en2 * dj(j+1,np,lp1) &
                               - f(i-1) * dj(j+2,np,lp1) ) / f(i)
            end do

        end do

        ! Fill upper triangle and fix signs
        do j = 1, l
            do m = j, l
                dj(j,m+1,lp1) = dj(m+1,j,lp1)
            end do
        end do

        isn = 1 + mod(l,2)

        do np = 1, lp1
            do i = isn, lp1, 2
                dj(i,np,lp1) = -dj(i,np,lp1)
            end do
        end do

    end do

end subroutine djpi2


MODULE adapt_quad_infinite

USE constants_NSWC
IMPLICIT NONE

CONTAINS

SUBROUTINE qagi (f, bound, inf, epsabs, epsrel, result, abserr,  &
                 neval, ier, limit, last)
!-----------------------------------------------------------------------

!                   INTEGRATION OVER INFINITE INTERVALS

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

!  PURPOSE
!     THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
!     INTEGRAL    I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
!              OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
!              OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
!     HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
!     ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).

!  PARAMETERS
!   ON ENTRY
!      F      - REAL
!               FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
!               FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
!               DECLARED E X T E R N A L IN THE DRIVER PROGRAM.

!      BOUND  - REAL
!               FINITE BOUND OF INTEGRATION RANGE
!               (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)

!      INF    - INTEGER
!               INDICATING THE KIND OF INTEGRATION RANGE INVOLVED
!               INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
!               INF = -1            TO  (-INFINITY,BOUND),
!               INF = 2             TO (-INFINITY,+INFINITY).

!      EPSABS - REAL
!               ABSOLUTE ACCURACY REQUESTED

!      EPSREL - REAL
!               RELATIVE ACCURACY REQUESTED

!   ON RETURN
!      RESULT - REAL
!               APPROXIMATION TO THE INTEGRAL

!      ABSERR - REAL
!               ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
!               WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)

!      NEVAL  - INTEGER
!               NUMBER OF INTEGRAND EVALUATIONS

!      IER    - INTEGER
!               IER = 0 NORMAL AND RELIABLE TERMINATION OF THE ROUTINE.
!                       IT IS ASSUMED THAT THE REQUESTED
!                       ACCURACY HAS BEEN ACHIEVED.
!             - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE.  THE ESTIMATES
!                       FOR RESULT AND ERROR ARE LESS RELIABLE. IT IS ASSUMED
!                       THAT THE REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.

!               IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED HAS BEEN
!                       ACHIEVED.  ONE CAN ALLOW MORE SUBDIVISIONS BY
!                       INCREASING THE VALUE OF LIMIT (AND TAKING THE
!                       ACCORDING DIMENSION ADJUSTMENTS INTO ACCOUNT).
!                       HOWEVER, IF THIS YIELDS NO IMPROVEMENT IT IS ADVISED
!                       TO ANALYZE THE INTEGRAND IN ORDER TO DETERMINE THE
!                       INTEGRATION DIFFICULTIES.
!                       IF THE POSITION OF A LOCAL DIFFICULTY CAN BE DETERMINED
!                       (E.G. SINGULARITY, DISCONTINUITY WITHIN THE INTERVAL)
!                       ONE WILL PROBABLY GAIN FROM SPLITTING UP THE INTERVAL
!                       AT THIS POINT AND CALLING THE INTEGRATOR ON THE
!                       SUBRANGES.
!                       IF POSSIBLE, AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
!                       SHOULD BE USED, WHICH IS DESIGNED FOR HANDLING THE
!                       TYPE OF DIFFICULTY INVOLVED.
!                   = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETECTED, WHICH
!                       PREVENTS THE REQUESTED TOLERANCE FROM BEING ACHIEVED.
!                       THE ERROR MAY BE UNDER-ESTIMATED.
!                   = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS AT SOME POINTS
!                       OF THE INTEGRATION INTERVAL.
!                   = 4 THE ALGORITHM DOES NOT CONVERGE.
!                       ROUNDOFF ERROR IS DETECTED IN THE EXTRAPOLATION TABLE.
!                       IT IS ASSUMED THAT THE REQUESTED TOLERANCE CANNOT BE
!                       ACHIEVED, AND THAT THE RETURNED RESULT IS THE BEST
!                       WHICH CAN BE OBTAINED.
!                   = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR SLOWLY
!                       CONVERGENT. IT MUST BE NOTED THAT DIVERGENCE CAN OCCUR
!                       WITH ANY OTHER VALUE OF IER.
!                   = 6 THE INPUT IS INVALID BECAUSE EPSABS OR EPSREL IS
!                       NEGATIVE, LIMIT .LT. 1, OR LENW .LT. 4 * LIMIT.
!                       RESULT, ABSERR, NEVAL, LAST ARE SET TO ZERO.

!   DIMENSIONING PARAMETERS
!      LIMIT - INTEGER
!              DIMENSIONING PARAMETER FOR IWORK
!              LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS IN THE
!              PARTITION OF THE GIVEN INTEGRATION INTERVAL (A,B), LIMIT.GE.1.
!              IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6.

!      LENW  - INTEGER
!              DIMENSIONING PARAMETER FOR WORK
!              LENW MUST BE AT LEAST LIMIT*4.
!              IF LENW.LT.LIMIT*4, THE ROUTINE WILL END WITH IER = 6.

!      LAST  - INTEGER
!              ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS PRODUCED IN
!              THE SUBDIVISION PROCESS, WHICH DETERMINES THE NUMBER OF
!              SIGNIFICANT ELEMENTS ACTUALLY IN THE WORK ARRAYS.

!  SUBROUTINES OR FUNCTIONS NEEDED
!        - QAGIE
!        - QK15I
!        - QPSRT
!        - QELG
!        - F (USER PROVIDED FUNCTION)
!        - SPMPAR

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

REAL (dp), INTENT(IN)   :: bound, epsabs, epsrel
INTEGER, INTENT(IN)     :: inf, limit
REAL (dp), INTENT(OUT)  :: result, abserr
INTEGER, INTENT(OUT)    :: neval, ier, last

INTERFACE
  FUNCTION f(x) RESULT(fx)
    USE constants_NSWC
    IMPLICIT NONE
    REAL (dp), INTENT(IN)  :: x
    REAL (dp)              :: fx
  END FUNCTION f
END INTERFACE

!         CHECK VALIDITY OF LIMIT.

ier = 6
neval = 0
last = 0
result = 0.0D0
abserr = 0.0D0
IF (limit < 1) RETURN

!         PREPARE CALL FOR QAGIE.

CALL qagie (f, bound, inf, epsabs, epsrel, limit, result, abserr,  &
            neval, ier, last)
RETURN
END SUBROUTINE qagi

SUBROUTINE qagie (f, bound, inf, epsabs, epsrel, limit, result, abserr,  &
                  neval, ier, last)
!-----------------------------------------------------------------------

!                   INTEGRATION OVER INFINITE INTERVALS

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

!  PURPOSE
!     THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN INTEGRAL
!                 I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
!              OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
!              OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
!     HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
!     ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).

!  PARAMETERS
!   ON ENTRY
!      F      - REAL
!               FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
!               FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
!               DECLARED E X T E R N A L IN THE DRIVER PROGRAM.

!      BOUND  - REAL
!               FINITE BOUND OF INTEGRATION RANGE
!               (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)

!      INF    - INTEGER
!               INDICATING THE KIND OF INTEGRATION RANGE INVOLVED
!               INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
!               INF = -1            TO  (-INFINITY,BOUND),
!               INF = 2             TO (-INFINITY,+INFINITY).

!      EPSABS - REAL
!               ABSOLUTE ACCURACY REQUESTED

!      EPSREL - REAL
!               RELATIVE ACCURACY REQUESTED

!      LIMIT  - INTEGER
!               GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS IN THE
!               PARTITION OF (A,B),
!               LIMIT.GE.1

!   ON RETURN
!      RESULT - REAL
!               APPROXIMATION TO THE INTEGRAL

!      ABSERR - REAL
!               ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
!               WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)

!      NEVAL  - INTEGER
!               NUMBER OF INTEGRAND EVALUATIONS

!      IER    - INTEGER
!               IER = 0 NORMAL AND RELIABLE TERMINATION OF THE ROUTINE.
!                       IT IS ASSUMED THAT THE REQUESTED ACCURACY HAS BEEN
!                       ACHIEVED.
!             - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE.  THE ESTIMATES
!                       FOR RESULT AND ERROR ARE LESS RELIABLE.  IT IS ASSUMED
!                       THAT THE REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.

!               IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED HAS BEEN
!                       ACHIEVED.  ONE CAN ALLOW MORE SUBDIVISIONS BY
!                       INCREASING THE VALUE OF LIMIT (AND TAKING THE
!                       ACCORDING DIMENSION ADJUSTMENTS INTO ACCOUNT).
!                       HOWEVER, IF THIS YIELDS NO IMPROVEMENT IT IS ADVISED
!                       TO ANALYZE THE INTEGRAND IN ORDER TO DETERMINE THE
!                       INTEGRATION DIFFICULTIES.
!                       IF THE POSITION OF A LOCAL DIFFICULTY CAN BE
!                       DETERMINED (E.G. SINGULARITY, DISCONTINUITY WITHIN THE
!                       INTERVAL) ONE WILL PROBABLY GAIN FROM SPLITTING UP THE
!                       INTERVAL AT THIS POINT AND CALLING THE INTEGRATOR ON
!                       THE SUBRANGES.  IF POSSIBLE, AN APPROPRIATE SPECIAL-
!                       PURPOSE INTEGRATOR SHOULD BE USED, WHICH IS DESIGNED
!                       FOR HANDLING THE TYPE OF DIFFICULTY INVOLVED.
!                   = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETECTED, WHICH
!                       PREVENTS THE REQUESTED TOLERANCE FROM BEING ACHIEVED.
!                       THE ERROR MAY BE UNDER-ESTIMATED.
!                   = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS AT SOME
!                       POINTS OF THE INTEGRATION INTERVAL.
!                   = 4 THE ALGORITHM DOES NOT CONVERGE.
!                       ROUNDOFF ERROR IS DETECTED IN THE EXTRAPOLATION TABLE.
!                       IT IS ASSUMED THAT THE REQUESTED TOLERANCE CANNOT BE
!                       ACHIEVED, AND THAT THE RETURNED RESULT IS THE BEST
!                       WHICH CAN BE OBTAINED.
!                   = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR SLOWLY
!                       CONVERGENT.  IT MUST BE NOTED THAT DIVERGENCE CAN
!                       OCCUR WITH ANY OTHER VALUE OF IER.
!                   = 6 THE INPUT IS INVALID BECAUSE EPSABS OR EPSREL IS
!                       NEGATIVE.
!                       RESULT, ABSERR, NEVAL, LAST, RLIST(1), ELIST(1) AND
!                       IORD(1) ARE SET TO ZERO.
!                       ALIST(1) AND BLIST(1) ARE SET TO 0 AND 1 RESPECTIVELY.

!      ALIST  - REAL
!               VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
!                LAST  ELEMENTS OF WHICH ARE THE LEFT
!               END POINTS OF THE SUBINTERVALS IN THE PARTITION
!               OF THE TRANSFORMED INTEGRATION RANGE (0,1).

!      BLIST  - REAL
!               VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
!                LAST  ELEMENTS OF WHICH ARE THE RIGHT
!               END POINTS OF THE SUBINTERVALS IN THE PARTITION
!               OF THE TRANSFORMED INTEGRATION RANGE (0,1).

!      RLIST  - REAL
!               VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
!                LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
!               APPROXIMATIONS ON THE SUBINTERVALS

!      ELIST  - REAL
!               VECTOR OF DIMENSION AT LEAST LIMIT,  THE FIRST
!                LAST  ELEMENTS OF WHICH ARE THE MODULI
!               OF THE ABSOLUTE ERROR ESTIMATES ON THE
!               SUBINTERVALS

!      IORD   - INTEGER
!               VECTOR OF DIMENSION LIMIT, THE FIRST K ELEMENTS OF WHICH ARE
!               POINTERS TO THE ERROR ESTIMATES OVER THE SUBINTERVALS,
!               SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) FORM A
!               DECREASING SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2),
!               AND K = LIMIT+1-LAST OTHERWISE

!      LAST   - INTEGER
!               NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE SUBDIVISION
!               PROCESS

!  SUBROUTINES OR FUNCTIONS NEEDED
!        - QK15I
!        - QPSRT
!        - QELG
!        - F (USER-PROVIDED FUNCTION)
!        - SPMPAR

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

REAL (dp), INTENT(IN)   :: bound, epsabs, epsrel
REAL (dp), INTENT(OUT)  :: result, abserr
INTEGER, INTENT(IN)     :: inf, limit
INTEGER, INTENT(OUT)    :: neval, ier, last

REAL (dp) :: abseps, area, area1, area12, area2, a1, a2, boun, b1, b2,     &
             correc, defabs, defab1, defab2, dres, epmach, erlarg, erlast, &
             errbnd, errmax, error1, error2, erro12, errsum, ertest,       &
             oflow, rerr, resabs, reseps, res3la(3), rlist2(52), small, t, &
             uflow
INTEGER :: id, ierro, iroff1, iroff2, iroff3, jupbnd, k, ksgn, ktmin,  &
           maxerr, nres, nrmax, numrl2
LOGICAL :: extrap, noext

REAL (dp), DIMENSION(limit)  :: alist, blist, elist, rlist
INTEGER, DIMENSION(limit)    :: iord

INTERFACE
  FUNCTION f(x) RESULT(fx)
    USE constants_NSWC
    IMPLICIT NONE
    REAL (dp), INTENT(IN) :: x
    REAL (dp)             :: fx
  END FUNCTION f
END INTERFACE

!      THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
!      LIMEXP IN SUBROUTINE QELG.

!      LIST OF MAJOR VARIABLES
!      -----------------------

!     ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS CONSIDERED UP
!                 TO NOW
!     BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS CONSIDERED UP
!                 TO NOW
!     RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER (ALIST(I),BLIST(I))
!     RLIST2    - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), CONTAINING THE PART
!                 OF THE EPSILON TABLE WHICH IS STILL NEEDED FOR FURTHER
!                 COMPUTATIONS
!     ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
!     MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR ESTIMATE
!     ERRMAX    - ELIST(MAXERR)
!     ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
!                 (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
!     AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
!     ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
!     ERRBND    - REQUESTED ACCURACY MAX(EPSABS, EPSREL*ABS(RESULT))
!     *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
!     *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
!     LAST      - INDEX FOR SUBDIVISION
!     NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
!     NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2.  IF AN APPROPRIATE
!                 APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS BEEN OBTAINED,
!                 IT IS PUT IN RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
!                 BY ONE.
!     SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP TO NOW,
!                 MULTIPLIED BY 1.5
!     ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER THAN THE
!                 SMALLEST INTERVAL CONSIDERED UP TO NOW
!     EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS ATTEMPTING TO
!                 PERFORM EXTRAPOLATION. I.E. BEFORE SUBDIVIDING THE SMALLEST
!                 INTERVAL WE TRY TO DECREASE THE VALUE OF ERLARG.
!     NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS NO LONGER
!                 ALLOWED (TRUE-VALUE)

!      MACHINE DEPENDENT CONSTANTS
!      ---------------------------

!     EPMACH IS THE LARGEST RELATIVE SPACING.
!     UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
!     OFLOW IS THE LARGEST POSITIVE MAGNITUDE.

epmach = dpmpar(1)
uflow = dpmpar(2)
oflow = dpmpar(3)

!           CHECK EPSABS AND EPSREL
!           -----------------------

neval = 0
last = 0
result = 0.0D0
abserr = 0.0D0
alist(1) = 0.0D0
blist(1) = 1.0D0
rlist(1) = 0.0D0
elist(1) = 0.0D0
iord(1) = 0
ier = 6
IF (epsabs < 0.0D0 .OR. epsrel < 0.0D0) GO TO 999
ier = 0
rerr = MAX(epsrel, 50.0D0*epmach, 0.5D-14)

!     FIRST APPROXIMATION TO THE INTEGRAL
!     -----------------------------------

!     DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1).
!     IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE
!     I1 = INTEGRAL OF F OVER (-INFINITY,0),
!     I2 = INTEGRAL OF F OVER (0,+INFINITY).

boun = bound
IF (inf == 2) boun = 0.0D0
CALL qk15i (f, boun, inf, 0.0D0, 1.0D0, result, abserr, defabs, resabs, &
            epmach, uflow)

!           TEST ON ACCURACY

last = 1
rlist(1) = result
elist(1) = abserr
iord(1) = 1
dres = ABS(result)
errbnd = MAX(epsabs,rerr*dres)
IF (abserr <= 100.0D0*epmach*defabs .AND. abserr > errbnd)  &
ier = 2
IF (limit == 1) ier = 1
IF (ier /= 0 .OR. (abserr <= errbnd .AND. abserr /= resabs)  &
.OR. abserr == 0.0D0) GO TO 130

!           INITIALIZATION
!           --------------

rlist2(1) = result
errmax = abserr
maxerr = 1
area = result
errsum = abserr
abserr = oflow
correc = 0.0D0
nrmax = 1
nres = 0
ktmin = 0
numrl2 = 2
extrap = .false.
noext = .false.
ierro = 0
iroff1 = 0
iroff2 = 0
iroff3 = 0
ksgn = -1
IF (dres >= (1.0D0 - 50.0D0*epmach)*defabs) ksgn = 1
t = 1.0D0 + 100.0D0*epmach

!           MAIN DO-LOOP
!           ------------

DO last = 2,limit

!           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE.

  a1 = alist(maxerr)
  b1 = 0.5D0*(alist(maxerr) + blist(maxerr))
  a2 = b1
  b2 = blist(maxerr)
  erlast = errmax
  CALL qk15i (f, boun, inf, a1, b1, area1, error1,  &
              resabs, defab1, epmach, uflow)
  CALL qk15i (f, boun, inf, a2, b2, area2, error2,  &
              resabs, defab2, epmach, uflow)

!           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL AND ERROR
!           AND TEST FOR ACCURACY.

  area12 = area1 + area2
  erro12 = error1 + error2
  errsum = errsum + erro12 - errmax
  area = area + area12 - rlist(maxerr)
  IF (defab1 == error1 .OR. defab2 == error2) GO TO 15
  IF (ABS(rlist(maxerr) - area12) > 0.1D-04*ABS(area12)  &
      .OR. erro12 < 0.99D0*errmax) GO TO 10
  IF (extrap) iroff2 = iroff2 + 1
  IF (.NOT.extrap) iroff1 = iroff1 + 1
  10 IF (last > 10 .AND. erro12 > errmax) iroff3 = iroff3 + 1
  15 rlist(maxerr) = area1
  rlist(last) = area2
  errbnd = MAX(epsabs,rerr*ABS(area))

!           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.

  IF (iroff1 + iroff2 >= 10 .OR. iroff3 >= 20) ier = 2
  IF (iroff2 >= 5) ierro = 3

!           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
!           SUBINTERVALS EQUALS LIMIT.

  IF (last == limit) ier = 1

!           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
!           AT SOME POINTS OF THE INTEGRATION RANGE.

  IF (MAX(ABS(a1),ABS(b2)) <= t*(ABS(a2) + 0.1D+04*uflow)) ier = 4

!           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.

  IF (error2 > error1) GO TO 20
  alist(last) = a2
  blist(maxerr) = b1
  blist(last) = b2
  elist(maxerr) = error1
  elist(last) = error2
  GO TO 30
  20 alist(maxerr) = a2
  alist(last) = a1
  blist(last) = b1
  rlist(maxerr) = area2
  rlist(last) = area1
  elist(maxerr) = error2
  elist(last) = error1

!           CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING
!           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL WITH
!           NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).

  30 CALL qpsrt (limit,last,maxerr,errmax,elist,iord,nrmax)
  IF (errsum <= errbnd) GO TO 115
  IF (ier /= 0) GO TO 100
  IF (last == 2) GO TO 80
  IF (noext) CYCLE
  erlarg = erlarg - erlast
  IF (ABS(b1 - a1) > small) erlarg = erlarg + erro12
  IF (extrap) GO TO 40

!           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
!           SMALLEST INTERVAL.

  IF (ABS(blist(maxerr) - alist(maxerr)) > small) CYCLE
  extrap = .true.
  nrmax = 2
  40 IF (ierro == 3 .OR. erlarg <= ertest) GO TO 60

!           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
!           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS
!           OVER THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.

  id = nrmax
  jupbnd = last
  IF (last > (2 + limit/2)) jupbnd = limit + 3 - last
  DO k = id,jupbnd
    maxerr = iord(nrmax)
    errmax = elist(maxerr)
    IF (ABS(blist(maxerr) - alist(maxerr)) > small) CYCLE
    nrmax = nrmax + 1
  END DO

!           PERFORM EXTRAPOLATION.

  60 numrl2 = numrl2 + 1
  rlist2(numrl2) = area
  CALL qelg (numrl2, rlist2, reseps, abseps, res3la, nres,epmach, oflow)
  ktmin = ktmin + 1
  IF (ktmin > 5 .AND. abserr < 0.1D-02*errsum) ier = 5
  IF (abseps >= abserr) GO TO 70
  ktmin = 0
  abserr = abseps
  result = reseps
  correc = erlarg
  ertest = MAX(epsabs,rerr*ABS(reseps))
  IF (abserr <= ertest) GO TO 100

!            PREPARE BISECTION OF THE SMALLEST INTERVAL.

  70 IF (numrl2 == 1) noext = .true.
  IF (ier == 5) GO TO 100
  maxerr = iord(1)
  errmax = elist(maxerr)
  nrmax = 1
  extrap = .false.
  small = small*0.5D0
  erlarg = errsum
  CYCLE
  80 small = 0.375D0
  erlarg = errsum
  ertest = errbnd
  rlist2(2) = area
END DO

!           SET FINAL RESULT AND ERROR ESTIMATE.
!           ------------------------------------

100 IF (abserr == oflow) GO TO 115
IF (ier + ierro == 0) GO TO 110
IF (ierro == 3) abserr = abserr + correc
IF (ier == 0) ier = 3
IF (result /= 0.0D0 .AND. area /= 0.0D0) GO TO 105
IF (abserr > errsum) GO TO 115
IF (area == 0.0D0) GO TO 130
GO TO 110
105 IF (abserr/ABS(result) > errsum/ABS(area)) GO TO 115

!           TEST ON DIVERGENCE

110 IF (ksgn == -1 .AND. MAX(ABS(result),ABS(area)) <=  &
defabs*0.1D-01) GO TO 130
IF (0.1D-01 > (result/area) .OR. (result/area) > 0.1D+03  &
.OR. errsum > ABS(area)) ier = 6
GO TO 130

!           COMPUTE GLOBAL INTEGRAL SUM.

115 result = 0.0D0
DO k = 1,last
  result = result + rlist(k)
END DO
abserr = errsum
130 neval = 30*last - 15
IF (inf == 2) neval = 2*neval
IF (ier > 2) ier = ier - 1
999 RETURN
END SUBROUTINE qagie

SUBROUTINE qk15i (f, boun, inf, a, b, result, abserr, resabs,  &
                  resasc, epmach, uflow)
!-----------------------------------------------------------------------

! 1.  PURPOSE
!        THE ORIGINAL (INFINITE) INTEGRATION RANGE IS MAPPED
!        ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1).
!        IT IS THE PURPOSE TO COMPUTE
!        I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B),
!        J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B).

! 2.  PARAMETERS
!      ON ENTRY
!        F      - REAL
!                 FUNCTION SUBPROGRAM DEFINING THE INTEGRAND FUNCTION F(X).
!                 THE ACTUAL NAME FOR F NEEDS TO BE DECLARED E X T E R N A L
!                 IN THE CALLING PROGRAM.

!        BOUN   - REAL
!                 FINITE BOUND OF ORIGINAL INTEGRATION
!                 RANGE (SET TO ZERO IF INF = +2)

!        INF    - INTEGER
!                 IF INF = -1, THE ORIGINAL INTERVAL IS
!                             (-INFINITY,BOUND),
!                 IF INF = +1, THE ORIGINAL INTERVAL IS
!                             (BOUND,+INFINITY),
!                 IF INF = +2, THE ORIGINAL INTERVAL IS
!                             (-INFINITY,+INFINITY) AND
!                 THE INTEGRAL IS COMPUTED AS THE SUM OF TWO INTEGRALS,
!                 ONE OVER (-INFINITY,0) AND ONE OVER (0,+INFINITY).

!        A      - REAL
!                 LOWER LIMIT FOR INTEGRATION OVER SUBRANGE OF (0,1)

!        B      - REAL
!                 UPPER LIMIT FOR INTEGRATION OVER SUBRANGE OF (0,1)

!        EPMACH - REAL
!                 THE RELATIVE PRECISION OF THE FLOATING ARITHMETIC BEING USED.

!        UFLOW  - REAL
!                 THE SMALLEST POSITIVE MAGNITUDE.

!      ON RETURN
!        RESULT - REAL
!                 APPROXIMATION TO THE INTEGRAL I
!                 RESULT IS COMPUTED BY APPLYING THE 15-POINT KRONROD RULE
!                 (RESK) OBTAINED BY OPTIMAL ADDITION OF ABSCISSAE TO THE
!                 7-POINT GAUSS RULE(RESG).

!        ABSERR - REAL
!                 ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
!                 WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)

!        RESABS - REAL
!                 APPROXIMATION TO THE INTEGRAL J

!        RESASC - REAL
!                 APPROXIMATION TO THE INTEGRAL OF
!                 ABS((TRANSFORMED INTEGRAND)-I/(B-A)) OVER (A,B)

! 3.  SUBROUTINES OR FUNCTIONS NEEDED
!           - F (USER-PROVIDED FUNCTION)

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

REAL (dp), INTENT(IN)   :: boun, a, b, epmach, uflow
INTEGER, INTENT(IN)     :: inf
REAL (dp), INTENT(OUT)  :: result, abserr, resabs, resasc

REAL (dp) :: fv1(7), fv2(7)

INTERFACE
  FUNCTION f(x) RESULT(fx)
    USE constants_NSWC
    IMPLICIT NONE
    REAL (dp), INTENT(IN) :: x
    REAL (dp)             :: fx
  END FUNCTION f
END INTERFACE

!     THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL
!     (-1,1).  BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND
!     THEIR CORRESPONDING WEIGHTS ARE GIVEN.

!     XGK    - ABSCISSAE OF THE 15-POINT KRONROD RULE
!              XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT GAUSS RULE
!              XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
!              ADDED TO THE 7-POINT GAUSS RULE

!     WGK    - WEIGHTS OF THE 15-POINT KRONROD RULE

!     WG     - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING TO THE
!              ABSCISSAE XGK(2), XGK(4), ... WG(1), WG(3), ...
!              ARE SET TO ZERO.

REAL (dp) :: absc, absc1, absc2,  centr, dinf, fc, fsum, fval1, fval2,  &
             hlgth, resg, resk, reskh, tabsc1, tabsc2, tol
INTEGER   :: j
REAL (dp), DIMENSION(8) :: xgk = (/  &
                           0.9914553711208126D+00, 0.9491079123427585D+00,  &
                           0.8648644233597691D+00, 0.7415311855993944D+00,  &
                           0.5860872354676911D+00, 0.4058451513773972D+00,  &
                           0.2077849550078985D+00, 0.0000000000000000D+00 /), &
                           wgk = (/  &
                           0.2293532201052922D-01, 0.6309209262997855D-01,  &
                           0.1047900103222502D+00, 0.1406532597155259D+00,  &
                           0.1690047266392679D+00, 0.1903505780647854D+00,  &
                           0.2044329400752989D+00, 0.2094821410847278D+00 /), &
                           wg = (/   &
                           0.0000000000000000D+00, 0.1294849661688697D+00,  &
                           0.0000000000000000D+00, 0.2797053914892767D+00,  &
                           0.0000000000000000D+00, 0.3818300505051189D+00,  &
                           0.0000000000000000D+00, 0.4179591836734694D+00 /)

!     LIST OF MAJOR VARIABLES
!     -----------------------

!     CENTR  - MID POINT OF THE INTERVAL
!     HLGTH  - HALF-LENGTH OF THE INTERVAL
!     ABSC*  - ABSCISSA
!     TABSC* - TRANSFORMED ABSCISSA
!     FVAL*  - FUNCTION VALUE
!     RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
!     RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
!     RESKH  - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED
!              INTEGRAND OVER (A,B), I.E. TO I/(B-A)

dinf = MIN(1,inf)

centr = 0.5D0*(a + b)
hlgth = 0.5D0*(b - a)
tabsc1 = boun + dinf*(1.0D0 - centr)/centr
fval1 = f(tabsc1)
IF (inf == 2) fval1 = fval1 + f(-tabsc1)
fc = (fval1/centr)/centr

!           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE INTEGRAL,
!           AND ESTIMATE THE ERROR.

resg = wg(8)*fc
resk = wgk(8)*fc
resabs = ABS(resk)
DO j = 1,7
  absc = hlgth*xgk(j)
  absc1 = centr - absc
  absc2 = centr + absc
  tabsc1 = boun + dinf*(1.0D0 - absc1)/absc1
  tabsc2 = boun + dinf*(1.0D0 - absc2)/absc2
  fval1 = f(tabsc1)
  fval2 = f(tabsc2)
  IF (inf == 2) fval1 = fval1 + f(-tabsc1)
  IF (inf == 2) fval2 = fval2 + f(-tabsc2)
  fval1 = (fval1/absc1)/absc1
  fval2 = (fval2/absc2)/absc2
  fv1(j) = fval1
  fv2(j) = fval2
  fsum = fval1 + fval2
  resg = resg + wg(j)*fsum
  resk = resk + wgk(j)*fsum
  resabs = resabs + wgk(j)*(ABS(fval1) + ABS(fval2))
END DO
reskh = resk / 2
resasc = wgk(8)*ABS(fc - reskh)
DO j = 1,7
  resasc = resasc + wgk(j)*(ABS(fv1(j)-reskh) + ABS(fv2(j)-reskh))
END DO
result = resk*hlgth
resasc = resasc*hlgth
resabs = resabs*hlgth
abserr = ABS((resk - resg)*hlgth)
IF (resasc /= 0.0D0 .AND. abserr /= 0.0D0) abserr = resasc*  &
                           MIN(1.0D0, (0.2D+03*abserr/resasc)**1.5D0)
tol = 50.0D0*epmach
IF (resabs > uflow/tol) abserr = MAX(abserr, tol*resabs)

RETURN
END SUBROUTINE qk15i

SUBROUTINE qpsrt(limit, last, maxerr, ermax, elist, iord, nrmax)
!     ..................................................................

! 1.  QPSRT
!     ORDERING ROUTINE
!        STANDARD FORTRAN SUBROUTINE
!        REAL VERSION

! 2.  PURPOSE
!        THIS ROUTINE MAINTAINS THE DESCENDING ORDERING IN THE LIST OF THE
!        LOCAL ERROR ESTIMATES RESULTING FROM THE INTERVAL SUBDIVISION
!        PROCESS.  AT EACH CALL TWO ERROR ESTIMATES ARE INSERTED USING THE
!        SEQUENTIAL SEARCH METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE
!        AND BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE.

! 3.  CALLING SEQUENCE
!        CALL QPSRT(LIMIT, LAST, MAXERR, ERMAX, ELIST, IORD, NRMAX)

!     PARAMETERS (MEANING AT OUTPUT)
!        LIMIT  - INTEGER
!                 MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST CAN CONTAIN

!        LAST   - INTEGER
!                 NUMBER OF ERROR ESTIMATES CURRENTLY IN THE LIST

!        MAXERR - INTEGER
!                 MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR ESTIMATE
!                 CURRENTLY IN THE LIST

!        ERMAX  - REAL
!                 NRMAX-TH LARGEST ERROR ESTIMATE
!                 ERMAX = ELIST(MAXERR)

!        ELIST  - REAL
!                 VECTOR OF DIMENSION LAST CONTAINING THE ERROR ESTIMATES

!        IORD   - INTEGER
!                 VECTOR OF DIMENSION LAST, THE FIRST K ELEMENTS OF
!                 WHICH CONTAIN POINTERS TO THE ERROR ESTIMATES,
!                 SUCH THAT ELIST(IORD(1)), ... , ELIST(IORD(K))
!                 FORM A DECREASING SEQUENCE, WITH K = LAST IF
!                 LAST <= (LIMIT/2+2), AND K = LIMIT+1-LAST OTHERWISE

!        NRMAX  - INTEGER
!                 MAXERR = IORD(NRMAX)

! 4.  NO SUBROUTINES OR FUNCTIONS NEEDED

!     ..................................................................

INTEGER, INTENT(IN)                  :: limit, last
REAL (dp), DIMENSION(:), INTENT(IN)  :: elist
INTEGER, INTENT(IN OUT)              :: nrmax
INTEGER, DIMENSION(:), INTENT(OUT)   :: iord
INTEGER, INTENT(OUT)                 :: maxerr
REAL (dp), INTENT(OUT)               :: ermax

REAL (dp) :: errmax, errmin
INTEGER   :: i, ibeg, ido, isucc, j, jbnd, jupbn, k

!           CHECK WHETHER THE LIST CONTAINS MORE THAN TWO ERROR ESTIMATES.

!***FIRST EXECUTABLE STATEMENT  QPSRT
IF(last > 2) GO TO 10
iord(1) = 1
iord(2) = 2
GO TO 90

!           THIS PART OF THE ROUTINE IS ONLY EXECUTED IF,
!           DUE TO A DIFFICULT INTEGRAND, SUBDIVISION INCREASED
!           THE ERROR ESTIMATE.   IN THE NORMAL CASE THE INSERT PROCEDURE
!           SHOULD START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE.

10 errmax = elist(maxerr)
IF(nrmax == 1) GO TO 30
ido = nrmax-1
DO i = 1, ido
  isucc = iord(nrmax-1)
! ***JUMP OUT OF DO-LOOP
  IF(errmax <= elist(isucc)) EXIT
  iord(nrmax) = isucc
  nrmax = nrmax-1
END DO

!           COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO
!           BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER
!           DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL ALLOWED.

30 jupbn = last
IF(last > (limit/2+2)) jupbn = limit+3-last
errmin = elist(last)

!           INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN,
!           STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)).

jbnd = jupbn-1
ibeg = nrmax+1
DO i=ibeg, jbnd
  isucc = iord(i)
! ***JUMP OUT OF DO-LOOP
  IF(errmax >= elist(isucc)) GO TO 60
  iord(i-1) = isucc
END DO
iord(jbnd) = maxerr
iord(jupbn) = last
GO TO 90

!           INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP.

60 iord(i-1) = maxerr
k = jbnd
DO j=i, jbnd
  isucc = iord(k)
! ***JUMP OUT OF DO-LOOP
  IF(errmin < elist(isucc)) GO TO 80
  iord(k+1) = isucc
  k = k-1
END DO
iord(i) = last
GO TO 90
80 iord(k+1) = last

!           SET MAXERR AND ERMAX.

90 maxerr = iord(nrmax)
ermax = elist(maxerr)
RETURN
END SUBROUTINE qpsrt

SUBROUTINE qelg (n, epstab, result, abserr, res3la, nres, epmach, oflow)
!-----------------------------------------------------------------------

! 1.  PURPOSE
!        THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF
!        APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM OF P. WYNN.
!        AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN.
!        THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE ELEMENTS NEEDED
!        FOR THE COMPUTATION OF THE NEXT DIAGONAL ARE PRESERVED.

! 2.  PARAMETERS
!        N      - INTEGER
!                 EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE
!                 FIRST COLUMN OF THE EPSILON TABLE.

!        EPSTAB - REAL
!                 VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS OF THE TWO
!                 LOWER DIAGONALS OF THE TRIANGULAR EPSILON TABLE.
!                 THE ELEMENTS ARE NUMBERED STARTING AT THE RIGHT-HAND
!                 CORNER OF THE TRIANGLE.

!        RESULT - REAL
!                 RESULTING APPROXIMATION TO THE INTEGRAL

!        ABSERR - REAL
!                 ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM
!                 RESULT AND THE 3 PREVIOUS RESULTS

!        RES3LA - REAL
!                 VECTOR OF DIMENSION 3 CONTAINING THE LAST 3 RESULTS

!        NRES   - INTEGER
!                 NUMBER OF CALLS TO THE ROUTINE
!                 (SHOULD BE ZERO AT FIRST CALL)

!        EPMACH - REAL
!                 THE RELATIVE PRECISION OF THE FLOATING ARITHMETIC BEING USED.

!        OFLOW  - REAL
!                 THE LARGEST POSITIVE MAGNITUDE.

! 3.  NO SUBROUTINES OR FUNCTIONS USED

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

INTEGER, INTENT(IN OUT)                  :: n, nres
REAL (dp), INTENT(IN)                    :: epmach, oflow
REAL (dp), INTENT(OUT)                   :: abserr, result
REAL (dp), DIMENSION(:), INTENT(IN OUT)  :: epstab, res3la
!---------------------

!     LIST OF MAJOR VARIABLES
!     -----------------------

!     E0     - THE 4 ELEMENTS ON WHICH THE
!     E1       COMPUTATION OF A NEW ELEMENT IN
!     E2       THE EPSILON TABLE IS BASED
!     E3                 E0
!                  E3    E1    NEW
!                        E2
!     NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW DIAGONAL
!     ERROR  - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2)
!     RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE OF ERROR

!     LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON TABLE CAN CONTAIN.
!     IF THIS NUMBER IS REACHED, THE UPPER DIAGONAL OF THE EPSILON TABLE IS
!     DELETED.

REAL (dp) :: delta1, delta2, delta3, epsinf, error, err1, err2, err3, e0, &
             e1, e1abs, e2, e3, res, ss, tol1, tol2, tol3
INTEGER   :: i, ib, ib2, ie, indx, k1, k2, k3, limexp, newelm, num

nres = nres + 1
abserr = oflow
result = epstab(n)
IF (n < 3) GO TO 100
limexp = 50
epstab(n + 2) = epstab(n)
newelm = (n - 1)/2
epstab(n) = oflow
num = n
k1 = n
DO i = 1, newelm
  k2 = k1 - 1
  k3 = k1 - 2
  res = epstab(k1 + 2)
  e0 = epstab(k3)
  e1 = epstab(k2)
  e2 = res
  e1abs = ABS(e1)
  delta2 = e2 - e1
  err2 = ABS(delta2)
  tol2 = MAX(ABS(e2),e1abs)*epmach
  delta3 = e1 - e0
  err3 = ABS(delta3)
  tol3 = MAX(e1abs,ABS(e0))*epmach
  IF (err2 > tol2 .OR. err3 > tol3) GO TO 10

!           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE ACCURACY,
!           CONVERGENCE IS ASSUMED.
!           RESULT = E2
!           ABSERR = ABS(E1-E0) + ABS(E2-E1)

  result = res
  abserr = err2 + err3
! ***JUMP OUT OF DO-LOOP
  GO TO 100
  10 e3 = epstab(k1)
  epstab(k1) = e1
  delta1 = e1 - e3
  err1 = ABS(delta1)
  tol1 = MAX(e1abs,ABS(e3))*epmach

!           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
!           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N

  IF (err1 <= tol1 .OR. err2 <= tol2 .OR. err3 <= tol3) GO TO 20
  ss = 1.0D0/delta1 + 1.0D0/delta2 - 1.0D0/delta3
  epsinf = ABS(ss*e1)

!           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND EVENTUALLY
!           OMIT A PART OF THE TABLE ADJUSTING THE VALUE OF N.

  IF (epsinf > 0.1D-03) GO TO 30
  20 n = i + i - 1
! ***JUMP OUT OF DO-LOOP
  GO TO 50

!           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST THE VALUE OF RESULT.

  30 res = e1 + 1.0D0/ss
  epstab(k1) = res
  k1 = k1 - 2
  error = err2 + ABS(res - e2) + err3
  IF (error > abserr) CYCLE
  abserr = error
  result = res
END DO

!           SHIFT THE TABLE.

50 IF (n == limexp) n = 2*(limexp/2) - 1
ib = 1
IF ((num/2)*2 == num) ib = 2
ie = newelm + 1
DO i = 1, ie
  ib2 = ib + 2
  epstab(ib) = epstab(ib2)
  ib = ib2
END DO
IF (num == n) GO TO 80
indx = num - n + 1
DO i = 1, n
  epstab(i) = epstab(indx)
  indx = indx + 1
END DO
80 IF (nres >= 4) GO TO 90
res3la(nres) = result
abserr = oflow
GO TO 100

!           COMPUTE ERROR ESTIMATE

90 abserr = ABS(result - res3la(3)) + ABS(result - res3la(2)) +  &
            ABS(result - res3la(1))
res3la(1) = res3la(2)
res3la(2) = res3la(3)
res3la(3) = result
100 abserr = MAX(abserr,5.0D0*epmach*ABS(result))
RETURN
END SUBROUTINE qelg

END MODULE adapt_quad_infinite


PROGRAM Triangle
    IMPLICIT NONE
    REAL :: a, b, c, Area
    PRINT *, 'Welcome, please enter the&
            &lengths of the 3 sides.'
    READ *, a, b, c
    PRINT *, 'Triangle''s area:  ', Area(a,b,c)
END PROGRAM Triangle
FUNCTION Area(x,y,z)
    IMPLICIT NONE
    REAL :: Area            ! function type
    REAL, INTENT( IN ) :: x, y, z
    REAL :: theta, height
    theta = ACOS((x**2+y**2-z**2)/(2.0*x*y))
    height = x*SIN(theta); Area = 0.5*y*height
END FUNCTION Area


      SUBROUTINE RNARRY(AA,N)
C       FORTRAN 77 version of "ran_array"
C       from Seminumerical Algorithms by D E Knuth, 3rd edition (1997)
C       including the MODIFICATIONS made in the 9th printing (2002)
C       and a bugfix to make this compatible with rng.c (2012)
C       ********* see the book for explanations and caveats! *********
      IMPLICIT INTEGER (A-Z)
      DIMENSION AA(*)
      PARAMETER (KK=100)
      PARAMETER (LL=37)
      PARAMETER (MM=2**30)
      COMMON /RSTATE/ RANX(KK)
      SAVE /RSTATE/
      DO 1 J=1,KK
 1       AA(J)=RANX(J)
      DO 2 J=KK+1,N
         AA(J)=AA(J-KK)-AA(J-LL)
         IF (AA(J) .LT. 0) AA(J)=AA(J)+MM
 2    CONTINUE
      DO 3 J=1,LL
         RANX(J)=AA(N+J-KK)-AA(N+J-LL)
         IF (RANX(J) .LT. 0) RANX(J)=RANX(J)+MM
 3    CONTINUE
      DO 4 J=LL+1,KK
         RANX(J)=AA(N+J-KK)-RANX(J-LL)
         IF (RANX(J) .LT. 0) RANX(J)=RANX(J)+MM
 4    CONTINUE
      END

      SUBROUTINE RNSTRT(SEED)
      IMPLICIT INTEGER (A-Z)
      PARAMETER (KK=100)
      PARAMETER (LL=37)
      PARAMETER (MM=2**30)
      PARAMETER (TT=70)
      PARAMETER (KKK=KK+KK-1)
      DIMENSION X(KKK)
      COMMON /RSTATE/ RANX(KK)
      SAVE /RSTATE/
      IF (SEED .LT. 0) THEN
         SSEED=MM-1-MOD(-1-SEED,MM)
      ELSE
         SSEED=MOD(SEED,MM)
      END IF
      SS=SSEED-MOD(SSEED,2)+2
      DO 1 J=1,KK
         X(J)=SS
         SS=SS+SS
         IF (SS .GE. MM) SS=SS-MM+2
 1    CONTINUE
      X(2)=X(2)+1
      SS=SSEED
      T=TT-1
 10   DO 12 J=KK,2,-1
         X(J+J-1)=X(J)
 12      X(J+J-2)=0
      DO 14 J=KKK,KK+1,-1
         X(J-(KK-LL))=X(J-(KK-LL))-X(J)
         IF (X(J-(KK-LL)) .LT. 0) X(J-(KK-LL))=X(J-(KK-LL))+MM
         X(J-KK)=X(J-KK)-X(J)
         IF (X(J-KK) .LT. 0) X(J-KK)=X(J-KK)+MM
 14   CONTINUE
      IF (MOD(SS,2) .EQ. 1) THEN
         DO 16 J=KK,1,-1
 16      X(J+1)=X(J)
         X(1)=X(KK+1)
         X(LL+1)=X(LL+1)-X(KK+1)
         IF (X(LL+1) .LT. 0) X(LL+1)=X(LL+1)+MM
       END IF
       IF (SS .NE. 0) THEN
          SS=SS/2
       ELSE
          T=T-1
       END IF
       IF (T .GT. 0) GO TO 10
       DO 20 J=1,LL
 20       RANX(J+KK-LL)=X(J)
       DO 21 J=LL+1,KK
 21       RANX(J-LL)=X(J)
       DO 22 J=1,10
 22       CALL RNARRY(X,KKK)
       END

       PROGRAM MAIN
C      a rudimentary test program:
       IMPLICIT INTEGER (A-Z)
       DIMENSION A(2009)
       EXTERNAL RNSTRT, RNARRY
       CALL RNSTRT(310952)
       DO 1 I=1,2009
          CALL RNARRY(A,1009)
 1     CONTINUE
       PRINT '(I15)',A(1)
C                   the number should be 995235265
       CALL RNSTRT(310952)
       DO 2 I=1,1009
          CALL RNARRY(A,2009)
 2     CONTINUE
       PRINT '(I15)',A(1)
C                                 again, 995235265
       END


c     Subroutine to convert from stnpres to sealevel pressure
c     copied from earlier dwdsub analysis
c     AJ_Kettle, Nov29/2017

      SUBROUTINE slpres_from_stnpres_dwdday(
     +   f_p_hpa,f_e_hpa,f_hght_m,f_airt_c,
     +   f_slpres_hpa)

      IMPLICIT NONE
c************************************************************************
      INTEGER             :: i,j,k,ii,jj,kk

c     Inputs
      REAL                :: f_p_hpa
      REAL                :: f_e_hpa
      REAL                :: f_hght_m
      REAL                :: f_airt_c

c     Output
      REAL                :: f_slpres_hpa

c     INTERNAL CONSTANTS
      REAL                :: f_grav_ms2
      REAL                :: f_gasconstant_jkgk
      REAL                :: f_airt_k
      REAL                :: f_alapse_km
      REAL                :: f_ccoef_khpa

c      REAL                :: f_numer
c      REAL                :: f_denom1
c      REAL                :: f_denom2
c      REAL                :: f_denom3
c************************************************************************
      f_grav_ms2          =9.80665
      f_gasconstant_jkgk  =287.05
      f_airt_k            =273.15+f_airt_c
      f_alapse_km         =0.0065
      f_ccoef_khpa        =0.12

c      f_numer =f_grav_ms2*f_hght_m/f_gasconstant_jkgk
c      f_denom1=f_airt_k
c      f_denom2=f_alapse_km*f_hght_m/2.0
c      f_denom3=f_e_hpa*f_ccoef_khpa

      f_slpres_hpa=f_p_hpa*
     +  EXP(
     +       (f_grav_ms2*f_hght_m/f_gasconstant_jkgk)/
     +       (f_airt_k+f_alapse_km*f_hght_m/2.0+f_e_hpa*f_ccoef_khpa)
     +     )

c      print*,'f_numer =',f_numer
c      print*,'f_denom1=',f_denom1
c      print*,'f_denom2=',f_denom2
c      print*,'f_denom3=',f_denom3
c      print*,'f_p_hpa=',f_p_hpa
c      call sleep(5)

c      print*,'just leaving slpres_from_stnpres_dwdday'
c************************************************************************
      RETURN
      END