C$Procedure  OSCLTX ( Extended osculating elements from state )

      SUBROUTINE OSCLTX ( STATE, ET, MU, ELTS )
      IMPLICIT NONE

C$ Abstract
C
C     Determine the set of osculating conic orbital elements that
C     corresponds to the state (position, velocity) of a body at some
C     epoch. In additional to the classical elements, return the true
C     anomaly, semi-major axis, and period, if applicable.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONIC
C     ELEMENTS
C     EPHEMERIS
C
C$ Declarations

      INCLUDE 'oscltx.inc'

      DOUBLE PRECISION      STATE  ( 6 )
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      MU
      DOUBLE PRECISION      ELTS   ( *  )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     STATE      I   State of body at epoch of elements.
C     ET         I   Epoch of elements.
C     MU         I   Gravitational parameter (GM) of primary body.
C     ELTS       O   Extended set of classical conic elements.
C
C$ Detailed_Input
C
C     STATE      is the state (position and velocity) of the body
C                at some epoch. Components are x, y, z, dx/dt, dy/dt,
C                dz/dt. STATE must be expressed relative to an
C                inertial reference frame. Units are km and km/sec.
C
C
C     ET         is the epoch of the input state, in ephemeris seconds
C                past J2000.
C
C                                                       3    2
C     MU         is the gravitational parameter (GM, km /sec ) of
C                the primary body.
C
C$ Detailed_Output
C
C     ELTS        are equivalent conic elements describing the orbit
C                 of the body around its primary. The elements are,
C                 in order:
C
C                    RP      Perifocal distance.
C                    ECC     Eccentricity.
C                    INC     Inclination.
C                    LNODE   Longitude of the ascending node.
C                    ARGP    Argument of periapsis.
C                    M0      Mean anomaly at epoch.
C                    T0      Epoch.
C                    MU      Gravitational parameter.
C                    NU      True anomaly at epoch.
C                    A       Semi-major axis. A is set to zero if
C                            it is not computable.
C                    TAU     Orbital period. Applicable only for
C                            elliptical orbits. Set to zero otherwise.
C
C                 The epoch of the elements is the epoch of the input
C                 state. Units are km, rad, rad/sec. The same elements
C                 are used to describe all three types (elliptic,
C                 hyperbolic, and parabolic) of conic orbit.
C
C                 User applications should declare ELTS using the
C                 parameter
C
C                    OSCXSZ
C
C                 See the Parameters section below.
C
C
C$ Parameters
C
C     OSCXSZ      is the size of the output elements array ELTS. OSCXSZ
C                 is declared in the Fortran include file
C
C                    oscltx.inc
C
C                 The output array ELTS is intended to contain unused
C                 space to hold additional elements that may be added
C                 in a later version of this routine. In order to
C                 maintain forward compatibility, user applications
C                 should declare ELTS as follows:
C
C                    DOUBLE PRECISION   ELTS( OSCXSZ )
C
C
C$ Exceptions
C
C     1) If MU is not positive, the error SPICE(NONPOSITIVEMASS)
C        is signaled.
C
C     2) If the specific angular momentum vector derived from STATE
C        is the zero vector, the error SPICE(DEGENERATECASE)
C        is signaled.
C
C     3) If the position or velocity vectors derived from STATE
C        is the zero vector, the error SPICE(DEGENERATECASE)
C        is signaled.
C
C     4) If the inclination is determined to be zero or 180 degrees,
C        the longitude of the ascending node is set to zero.
C
C     5) If the eccentricity is determined to be zero, the argument of
C        periapse is set to zero.
C
C     6) If the eccentricity of the orbit is very close to but not
C        equal to zero, the argument of periapse may not be accurately
C        determined.
C
C     7) For inclinations near but not equal to 0 or 180 degrees,
C        the longitude of the ascending node may not be determined
C        accurately.  The argument of periapse and mean anomaly may
C        also be inaccurate.
C
C     8) For eccentricities very close to but not equal to 1, the
C        results of this routine are unreliable.
C
C     9) If the specific angular momentum vector is non-zero but
C        "close" to zero, the results of this routine are unreliable.
C
C    10) If STATE is expressed relative to a non-inertial reference
C        frame, the resulting elements are invalid.  No error checking
C        is done to detect this problem.
C
C    11) The semi-major axis and period may not be computable for
C        orbits having eccentricity too close to 1. If the semi-major
C        axis is not computable, both it and the period are set to zero.
C        If the period is not computable, it is set to zero.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns in the first 8 elements of the array ELTS
C     the outputs computed by OSCELT, and in addition returns in
C     elements 9-11 the quantities:
C
C        ELTS(9)   true anomaly at ET, in radians.
C
C        ELTS(10)  orbital semi-major axis at ET, in km. Valid
C                  if and only if this value is non-zero.
C
C                  The semi-major axis won't be computable if the
C                  eccentricity of the orbit is too close to 1.
C                  In this case A is set to zero.
C
C        ELTS(11)  orbital period. If the period is not computable,
C                  TAU is set to zero.
C
C     The SPICELIB routine CONICS is an approximate inverse of this
C     routine: CONICS maps a set of osculating elements and a time to a
C     state vector.
C
C$ Examples
C
C     Let VINIT contain the initial state of a spacecraft relative to
C     the center of a planet at epoch ET, and let GM be the gravitation
C     parameter of the planet. The call
C
C        CALL OSCLTX ( VINIT, ET, GM, ELTS )
C
C     produces a set of osculating elements describing the nominal
C     orbit that the spacecraft would follow in the absence of all
C     other bodies in the solar system.
C
C     Now let STATE contain the state of the same spacecraft at some
C     other epoch, LATER. The difference between this state and the
C     state predicted by the nominal orbit at the same epoch can be
C     computed as follows.
C
C        CALL CONICS ( ELTS, LATER, NOMINAL )
C        CALL VSUBG  ( NOMINAL, STATE, 6, DIFF )
C
C        WRITE (*,*) 'Perturbation in x, dx/dt = ', DIFF(1), DIFF(4)
C        WRITE (*,*) '                y, dy/dt = ', DIFF(2), DIFF(5)
C        WRITE (*,*) '                z, dz/dt = ', DIFF(3), DIFF(6)
C
C$ Restrictions
C
C     1) The input state vector must be expressed relative to an
C        inertial reference frame.
C
C     2) Osculating elements are generally not useful for
C        high-accuracy work.
C
C     3) Accurate osculating elements may be difficult to derive for
C        near-circular or near-equatorial orbits. Osculating elements
C        for such orbits should be used with caution.
C
C     4) Extracting osculating elements from a state vector is a
C        mathematically simple but numerically challenging task.  The
C        mapping from a state vector to equivalent elements is
C        undefined for certain state vectors, and the mapping is
C        difficult to implement with finite precision arithmetic for
C        states near the subsets of R6 where singularities occur.
C
C        In general, the elements found by this routine can have
C        two kinds of problems:
C
C           - The elements are not accurate but still represent
C             the input state accurately.  The can happen in
C             cases where the inclination is near zero or 180
C             degrees, or for near-circular orbits.
C
C           - The elements are garbage.  This can occur when
C             the eccentricity of the orbit is close to but
C             not equal to 1. In general, any inputs that cause
C             great loss of precision in the computation of the
C             specific angular momentum vector or the eccentricity
C             vector will result in invalid outputs.
C
C        For further details, see the Exceptions section.
C
C        Users of this routine should carefully consider whether
C        it is suitable for their applications.  One recommended
C        "sanity check" on the outputs is to supply them to the
C        SPICELIB routine CONICS and compare the resulting state
C        vector with the one supplied to this routine.
C
C$ Literature_References
C
C     [1] Roger Bate, Fundamentals of Astrodynamics, Dover, 1971.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     K.R. Gehringer  (JPL)
C     I.M. Underwood  (JPL)
C     E.D. Wright     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 02-FEB-2017 (NJB)
C
C        12-MAR-2015 (NJB)
C
C           Re-arranged test for small E to avoid overflow.
C           Changed definition of B to make the maximum value
C           of TAU equal to LIMIT. Removed test comparing
C           E/LIMIT to RMAG.
C
C        11-NOV-2014 (NJB)
C
C           Original version. Based on OSCELT version 1.3.1,
C           28-FEB-2008
C
C-&

C$ Index_Entries
C
C     extended conic elements from state
C     extended osculating elements from state
C     convert state to extended osculating elements
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX
      DOUBLE PRECISION      EXACT
      DOUBLE PRECISION      TWOPI
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      DOUBLE PRECISION      SMALL
      PARAMETER           ( SMALL  = 1.D-10 )

      DOUBLE PRECISION      MARGIN
      PARAMETER           ( MARGIN = 2.D2 )

C
C     Local variables
C
      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C1
      DOUBLE PRECISION      C2
      DOUBLE PRECISION      DEC
      DOUBLE PRECISION      E
      DOUBLE PRECISION      ECC
      DOUBLE PRECISION      ECCVEC ( 3 )
      DOUBLE PRECISION      LIMIT
      DOUBLE PRECISION      MUCUBR
      DOUBLE PRECISION      NU
      DOUBLE PRECISION      POLE   ( 3 )
      DOUBLE PRECISION      RANGE
      DOUBLE PRECISION      RHAT   ( 3 )
      DOUBLE PRECISION      RMAG
      DOUBLE PRECISION      RPERI  ( 3 )
      DOUBLE PRECISION      TAU
      DOUBLE PRECISION      VEL    ( 3 )
      DOUBLE PRECISION      VMAG
      DOUBLE PRECISION      XMAT   ( 3, 3 )

      LOGICAL               CMPTAU
      LOGICAL               PASS1

      SAVE                  LIMIT
      SAVE                  PASS1

      DATA                  PASS1 / .TRUE. /
      DATA                  LIMIT / 0.D0   /

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'OSCLTX' )

      IF ( PASS1 ) THEN

         LIMIT = DPMAX() / MARGIN
         PASS1 = .FALSE.

      END IF

C
C     Initialize the members of ELTS that won't be set by OSCELT. This
C     is necessary because this routine may return early if A or TAU
C     cannot be computed.
C
      CALL CLEARD ( OSCXSZ-8, ELTS(9) )
      NU  = 0.D0
      TAU = 0.D0
      A   = 0.D0

C
C     Compute osculating elements using OSCELT. Take advantage
C     of OSCELT's error handling.
C
      CALL OSCELT ( STATE, ET, MU, ELTS )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'OSCLTX' )
         RETURN
      END IF

C
C     Due to checks made by OSCELT, we know that MU and RMAG
C     are strictly positive.
C
C
C     Compute the true anomaly at ET. For the non-degenerate case, we
C     use equation 2.4-5 from [1] to compute the eccentricity vector:
C
C        _    1          2   mu    _     _  _  _
C        e = ---- * [ ( v - ---- ) r  - <r, v> v ]                   (1)
C             mu             r
C
C
C     where
C
C        _
C        e      is the eccentricity vector
C
C        _  _
C        r, v   are, respectively, the object's position and
C               velocity vectors expressed in the inertial
C               reference frame of the input state.
C                                                    _     _
C        r, v   are, respectively, the magnitudes of r and v
C
C        mu     is the GM value of the center of motion
C
C
C
      CALL UNORM ( STATE, RHAT, RMAG )
      CALL VEQU  ( STATE(4),    VEL  )

      VMAG = VNORM( VEL )

      ECC  = EXACT ( ELTS(2), 0.D0, SMALL )

      IF ( ECC .NE. 0.D0 ) THEN
C                                 _   _
C        C1 is the coefficient of r/||r|| in (1) above:
C
         C1 =    (1.D0/MU) * ( ( RMAG * VMAG**2 ) - MU )

C                                 _
C        C2 is the coefficient of v in (1) above:
C
         C2 =  - (1.D0/MU) * VDOT( STATE, VEL )

C
C        ECCVEC is the eccentricity vector:
C
         CALL VLCOM ( C1, RHAT, C2, VEL, ECCVEC )

C
C        POLE is the orbital pole unit vector.
C
         CALL UCRSS ( STATE, VEL, POLE )

C
C        Compute the transformation from the frame of the input state
C        to the perifocal frame.
C
         CALL TWOVEC ( ECCVEC, 1, POLE, 3, XMAT )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'OSCLTX' )
            RETURN
         END IF

C
C        Transform the input position to the perifocal frame and
C        compute its "right ascension." This is the true anomaly NU,
C        confined to the range [0, 2*pi) radians.
C
         CALL MXV    ( XMAT,  STATE, RPERI     )
         CALL RECRAD ( RPERI, RANGE, NU,   DEC )

      ELSE
C
C        The orbit is circular or nearly so. The mean anomaly can
C        be used as the true anomaly.
C
         NU = ELTS( 6 )

      END IF

      ELTS(9) = NU

C
C     The semi-major axis A satisfies the relationship
C
C                mu
C        E =  - ----                                                 (2)
C                2A
C
C     where E represents the specific energy of the orbit, as long
C     as A is computable.
C
C     If the orbit is not parabolic or too close to parabolic,
C     we can recover A from (2) above:
C
C                mu
C        A =  - ----
C                2E
C
C     To make sure that A is computable, we require
C
C
C
C        |mu/E| < LIMIT
C
C     so
C
C        |mu/LIMIT| < |E|
C
C     We compute E from the specific kinetic and potential
C     energy of the orbit:
C
C               2
C              v     mu
C        E =  --- - ----                                             (3)
C              2     r
C
C     The second term on the right hand side is computable if
C
C        mu/LIMIT < r
C
C
      IF ( ELTS(2) .EQ. 1.D0 ) THEN
C
C        This is the parabolic case.
C
         CALL CHKOUT ( 'OSCLTX' )
         RETURN

      END IF

      IF ( RMAG .LE. ( MU/LIMIT ) ) THEN
C
C        We need RMAG > MU/LIMIT to make E computable.
C
C        We can't safely compute E.
C
         CALL CHKOUT ( 'OSCLTX' )
         RETURN

      END IF

C
C     We assume V and MU are small enough not to cause overflow.
C
      E = ( 0.5D0 * VMAG**2 ) - ( MU / RMAG )

      IF (  ABS(E)  .LT.  ( ABS(MU)/LIMIT )  ) THEN
C
C        We can't safely compute A. The case of E equal to 0
C        gets the code to this point.
C
         CALL CHKOUT ( 'OSCLTX' )
         RETURN

      END IF

C
C     At this point we can compute A (which is stored in ELTS(10)).
C
      A          = - MU / ( 2 * E )
      ELTS( 10 ) = A

C
C     If the orbit is elliptical, compute the period.
C
      ECC = ELTS(2)

      IF ( ECC .LT. 1.D0 ) THEN
C
C        The period is given by the formula
C
C                             3       1/2
C           tau = 2 * pi * ( a  / mu )
C
C        We need to make sure this computation doesn't
C        overflow.
C
C        If mu >= 1 then we can express the constraint
C        on a as
C
C                   1/3                         2/3
C           ( a / mu    )  <  ( LIMIT / (2*pi) )
C
C
C        Otherwise, we require that
C
C                                 2/3     1/3
C           a < ( LIMIT / (2*pi) )    * mu
C
C
C
C        Note that the case of non-positive MU has already
C        been ruled out.
C
         B      = ( LIMIT / TWOPI() )**(2.D0/3.D0)

         MUCUBR = MU ** (1.D0/3.D0 )

         IF ( MU .GE. 1.D0 ) THEN

            CMPTAU =  (  A / MUCUBR  )  .LT.    B
         ELSE
            CMPTAU =     A              .LT.  ( B * MUCUBR )
         END IF

         IF ( CMPTAU ) THEN

            TAU = TWOPI() * ( (A/MUCUBR)**(3.D0/2.D0) )

         END IF

      END IF

C
C     Assign the remaining members of ELTS.
C
      ELTS( 11 ) = TAU

      CALL CHKOUT ( 'OSCLTX' )
      RETURN
      END


**********************************************************************
**********************************************************************
      integer function niveau(cellnum)
*
* calculates cell level for cell number  cellnum:
*
*      0+1 =     1 <=  cellnum  <=    0+   4=  4  --------> niveau 1;
*      4+1 =     5 <=  cellnum  <=    4+  16= 20  --------> niveau 2;
*     20+1 =    21 <=  cellnum  <=   20+  64= 84  --------> niveau 3;
*     84+1 =    85 <=  cellnum  <=   84+ 256=340  --------> niveau 4;
*    340+1 =   341 <=  cellnum  <=  340+1024=1364 --------> niveau 5;
*   1364+1 =  1365 <=  cellnum  <= 1364+4096=5460 --------> niveau 6;
*   5460+1 =  5461 <=  cellnum  <= .......        --------> niveau 7;
*
* input:
*       cellnum  - (actual) number of cell, whose niveau has
*               to be determined (example: cellnum = 3766; niveau => 6)
*
* output:
*       niveau   - function value   (1  <=  niveau  <= levelmax )
*
* called in:
*           main
*
* use of subroutines:
*           none
*
* use of functions:
*           none
*					October 31, 1991; J. Wambsganss
*
      implicit none
      integer i,dum,cellnum
*
      dum = cellnum
      do i = 1,200
           dum =  dum - 4**i
           if(dum.le.0)then
                niveau = i
                return
           endif
      enddo
*
      write(44,*)' cellnum,i,dum: ',cellnum,i,dum
      write(44,*)' (possible reason: levelmax = 30, but it should be '
      write(44,*)' levelmax = 15, if integer*8 cannot be specified!)'
      write(44,*)' ------------>   STOP 271 in NIVEAU !!!'
*
      stop 271
      end


      DOUBLE PRECISION FUNCTION dlanor(x)
C**********************************************************************
C
C      DOUBLE PRECISION FUNCTION DLANOR( X )
C           Double precision Logarith of the Asymptotic Normal
C
C
C                              Function
C
C
C      Computes the logarithm of the cumulative normal distribution
C      from abs( x ) to infinity for abs( x ) >= 5.
C
C
C                              Arguments
C
C
C      X --> Value at which cumulative normal to be evaluated
C                     DOUBLE PRECISION X
C
C
C                              Method
C
C
C      23 term expansion of formula 26.2.12 of Abramowitz and Stegun.
C      The relative error at X = 5 is about 0.5E-5.
C
C
C                              Note
C
C
C      ABS(X) must be >= 5 else there is an error stop.
C
C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION dlsqpi
      PARAMETER (dlsqpi=0.91893853320467274177D0)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION approx,correc,xx,xx2
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION coef(12)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION devlpl,dln1px
      EXTERNAL devlpl,dln1px
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,log
C     ..
C     .. Data statements ..
      DATA coef/-1.0D0,3.0D0,-15.0D0,105.0D0,-945.0D0,10395.0D0,
     +     -135135.0D0,2027025.0D0,-34459425.0D0,654729075.0D0,
     +     -13749310575D0,316234143225.0D0/
C     ..
C     .. Executable Statements ..

      xx = abs(x)
      IF (xx.LT.5.0D0) STOP ' Argument too small in DLANOR'

      approx = -dlsqpi - 0.5D0*xx*xx - log(xx)

      xx2 = xx*xx
      correc = devlpl(coef,12,1.0D0/xx2)/xx2
      correc = dln1px(correc)

      dlanor = approx + correc

      RETURN

      END


!NCLFORTSTART
SUBROUTINE wrfcttcalc(prs, tk, qci, qcw, qvp, ght, ter, ctt, pf, haveqci,&
             fill_nocloud, missing, opt_thresh, nz, ns, ew)
    USE wrf_constants, ONLY : EPS, USSALR, RD, G, ABSCOEFI, ABSCOEF, CELKEL

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: ctt

    INTEGER, INTENT(IN) :: nz, ns, ew, haveqci, fill_nocloud
    REAL(KIND=8), DIMENSION(ew,ns,nz), INTENT(IN) :: ght, prs, tk, qci, qcw, qvp
    REAL(KIND=8), DIMENSION(ew,ns), INTENT(IN) :: ter
    REAL(KIND=8), DIMENSION(ew,ns), INTENT(OUT) :: ctt
    REAL(KIND=8), INTENT(IN) :: missing
    REAL(KIND=8), INTENT(IN) :: opt_thresh
    REAL(KIND=8), DIMENSION(ew,ns,nz), INTENT(INOUT) :: pf

!NCLEND

    !     REAL(KIND=8) ::     znfac(nz)

    ! LOCAL VARIABLES
    INTEGER i,j,k,ripk
    REAL(KIND=8) :: opdepthu, opdepthd, dp, arg1, fac, prsctt, ratmix
    REAL(KIND=8) :: arg2, agl_hgt, vt

    REAL(KIND=8) :: p1, p2

    !$OMP PARALLEL

    ! Calculate the surface pressure
    !$OMP DO COLLAPSE(2) PRIVATE(i, j, ratmix, arg1, arg2, vt, agl_hgt) &
    !$OMP SCHEDULE(runtime)
    DO j=1,ns
        DO i=1,ew
           ratmix = .001D0*qvp(i,j,1)
           arg1 = EPS + ratmix
           arg2 = EPS*(1. + ratmix)
           vt = tk(i,j,1)*arg1/arg2 !Virtual temperature
           agl_hgt = ght(i,j,nz) - ter(i,j)
           arg1 = -G/(RD*USSALR)
           pf(i,j,nz) = prs(i,j,1)*(vt/(vt + USSALR*(agl_hgt)))**(arg1)
        END DO
    END DO
    !$OMP END DO

    !$OMP DO COLLAPSE(3) PRIVATE(i, j, k, ripk) SCHEDULE(runtime)
    DO k=1,nz-1
        DO j=1,ns
            DO i=1,ew
                ripk = nz-k+1
                pf(i,j,k) = .5D0*(prs(i,j,ripk) + prs(i,j,ripk-1))
            END DO
        END DO
    END DO
    !$OMP END DO

    !$OMP DO COLLAPSE(2) PRIVATE(i, j, k, ripk, opdepthd, opdepthu, &
    !$OMP prsctt, dp, p1, p2, fac, arg1) SCHEDULE(runtime)
    DO j=1,ns
        DO i=1,ew
            opdepthd = 0.D0
            k = 0
            prsctt = -1

            ! Integrate downward from model top, calculating path at full
            ! model vertical levels.

            DO k=2,nz
                opdepthu = opdepthd
                ripk = nz - k + 1

                IF (k .NE. 1) THEN
                    dp = 100.D0*(pf(i,j,k) - pf(i,j,k-1))  ! should be in Pa
                ELSE
                    dp = 200.D0*(pf(i,j,1) - prs(i,j,nz))  ! should be in Pa
                END IF

                IF (haveqci .EQ. 0) then
                    IF (tk(i,j,ripk) .LT. CELKEL) then
                        ! Note: abscoefi is m**2/g, qcw is g/kg, so no convrsion needed
                        opdepthd = opdepthu + ABSCOEFI*qcw(i,j,ripk) * dp/G
                    ELSE
                        opdepthd = opdepthu + ABSCOEF*qcw(i,j,ripk) * dp/G
                    END IF
                ELSE
                    opdepthd = opdepthd + (ABSCOEF*qcw(i,j,ripk) + ABSCOEFI*qci(i,j,ripk))*dp/G
                END IF

                IF (opdepthd .LT. opt_thresh .AND. k .LT. nz) THEN
                    CYCLE

                ELSE IF (opdepthd .LT. opt_thresh .AND. k .EQ. nz) THEN
                    IF (fill_nocloud .EQ. 0) THEN
                        prsctt = prs(i,j,1)
                    ENDIF
                    EXIT
                ELSE
                    fac = (1. - opdepthu)/(opdepthd - opdepthu)
                    prsctt = pf(i,j,k-1) + fac*(pf(i,j,k) - pf(i,j,k-1))
                    prsctt = MIN(prs(i,j,1), MAX(prs(i,j,nz), prsctt))
                    EXIT
                END IF
            END DO

            ! prsctt should only be 0 if fill values are used
            IF (prsctt .GT. -1) THEN
                DO k=2,nz
                    ripk = nz - k + 1
                    p1 = prs(i,j,ripk+1)
                    p2 = prs(i,j,ripk)
                    IF (prsctt .GE. p1 .AND. prsctt .LE. p2) THEN
                        fac = (prsctt - p1)/(p2 - p1)
                        arg1 = fac*(tk(i,j,ripk) - tk(i,j,ripk+1)) - CELKEL
                        ctt(i,j) = tk(i,j,ripk+1) + arg1
                        EXIT
                    END IF
                END DO
            ELSE
                ctt(i,j) = missing
            END IF
        END DO
    END DO
    !$OMP END DO

    !$OMP END PARALLEL
    RETURN

END SUBROUTINE wrfcttcalc


      subroutine QUADINTERP(
     &           phi
     &           ,iphilo0
     &           ,iphihi0
     &           ,nphicomp
     &           ,phistar
     &           ,iphistarlo0
     &           ,iphistarhi0
     &           ,nphistarcomp
     &           ,iboxlo0
     &           ,iboxhi0
     &           ,ihilo
     &           ,h
     &           ,idir
     &           ,scomp
     &           ,ecomp
     &           ,nref
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nphicomp
      integer iphilo0
      integer iphihi0
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           0:nphicomp-1)
      integer nphistarcomp
      integer iphistarlo0
      integer iphistarhi0
      REAL*8 phistar(
     &           iphistarlo0:iphistarhi0,
     &           0:nphistarcomp-1)
      integer iboxlo0
      integer iboxhi0
      integer ihilo
      REAL*8 h
      integer idir
      integer scomp
      integer ecomp
      integer nref
      integer i0
      integer ii0
      integer n
      REAL*8 x, pa, pb, ps, a, b, frac, denom, xsquared
      REAL*8  mult, invh
      frac = (2.0d0)/(h*h)
      denom =  nref*nref + 4*nref + 3
      mult = frac/denom
      invh = (1.0d0) / h
      x = (2.0d0) * h
      xsquared = (4.0d0) * h*h
      ii0= ihilo*CHF_ID(0, idir)
      do n=scomp,ecomp
      do i0 = iboxlo0,iboxhi0
            pa = phi(i0 -2*ii0,n)
            pb = phi(i0 -ii0,n)
            ps = phistar(i0 +ii0,n)
            a  = mult*((2.0d0)*ps + (nref+1)*pa - (nref+3)*pb)
            b  = (pb-pa)*invh - a*h
            phi(i0,n) = xsquared*a + b*x + pa
      enddo
      enddo
      return
      end
      subroutine PHISTAR(
     &           fPhiStar
     &           ,ifPhiStarlo0
     &           ,ifPhiStarhi0
     &           ,nfPhiStarcomp
     &           ,iregionlo0
     &           ,iregionhi0
     &           ,phic
     &           ,iphiclo0
     &           ,iphichi0
     &           ,nphiccomp
     &           ,coarslope
     &           ,icoarslopelo0
     &           ,icoarslopehi0
     &           ,ncoarslopecomp
     &           ,coarcurva
     &           ,icoarcurvalo0
     &           ,icoarcurvahi0
     &           ,ncoarcurvacomp
     &           ,coarmixed
     &           ,icoarmixedlo0
     &           ,icoarmixedhi0
     &           ,ncoarmixedcomp
     &           ,dxf
     &           ,ivar
     &           ,dir
     &           ,sign
     &           ,nRef
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nfPhiStarcomp
      integer ifPhiStarlo0
      integer ifPhiStarhi0
      REAL*8 fPhiStar(
     &           ifPhiStarlo0:ifPhiStarhi0,
     &           0:nfPhiStarcomp-1)
      integer iregionlo0
      integer iregionhi0
      integer nphiccomp
      integer iphiclo0
      integer iphichi0
      REAL*8 phic(
     &           iphiclo0:iphichi0,
     &           0:nphiccomp-1)
      integer ncoarslopecomp
      integer icoarslopelo0
      integer icoarslopehi0
      REAL*8 coarslope(
     &           icoarslopelo0:icoarslopehi0,
     &           0:ncoarslopecomp-1)
      integer ncoarcurvacomp
      integer icoarcurvalo0
      integer icoarcurvahi0
      REAL*8 coarcurva(
     &           icoarcurvalo0:icoarcurvahi0,
     &           0:ncoarcurvacomp-1)
      integer ncoarmixedcomp
      integer icoarmixedlo0
      integer icoarmixedhi0
      REAL*8 coarmixed(
     &           icoarmixedlo0:icoarmixedhi0,
     &           0:ncoarmixedcomp-1)
      REAL*8 dxf
      integer ivar
      integer dir
      integer sign
      integer nRef
      REAL*8 xf1, xc1, xf2, xc2, x1, x2, dxc
      REAL*8 aa, update1, update2, update3
      integer i0
      integer ii0
      integer ir0
      integer ic(0:1 -1)
      integer ivf(0:1 -1)
      integer YOU(1:2, 0:2), you1, you2
      data YOU / 1, 2, 0, 2, 0, 1 /
      dxc = nRef * dxf
      you1 = YOU(1,dir)
      you2 = YOU(2,dir)
      ii0= sign*CHF_ID(0, dir)
      do ir0 = iregionlo0,iregionhi0
         ic(0)=ir0/nRef
         ivf(0)=ir0
         i0=ir0+ii0
         xf1 = (ivf(you1)+(0.500d0))*dxf
         xc1 = (  ic(you1)+(0.500d0))*dxc
         xf2 = (ivf(you2)+(0.500d0))*dxf
         xc2 = (  ic(you2)+(0.500d0))*dxc
         x1 = xf1-xc1
         x2 = xf2-xc2
         aa= phic(ic(0),ivar)
         update1=x1*coarslope(ic(0),you1) +
     &        (0.500d0)*x1*x1*coarcurva(ic(0),you1)
         update2=x2*coarslope(ic(0),you2) +
     &        (0.500d0)*x2*x2*coarcurva(ic(0),you2)
         update3=x1*x2*coarmixed(ic(0),0)
         fPhiStar(i0,ivar) = aa+update1+update2+update3
      enddo
      return
      end


      SUBROUTINE SYMSLV(A,C,N,NA,NC)
C
C   PURPOSE:
C      Solve the real matrix equation A'X + XA = C, where C=C' and A
C      is n x n and in upper real Schur form.
C
C   REFERENCES:
C      Bartels, R.H.; and Stewart, G.W.: Algorithm 432 - Solution of
C        the Matrix Equation AX + XB = C.  Commun. ACM, vol. 15, no. 9,
C        Sept. 1972, pp. 820-826.
C
C   Subroutines employed by SYMSLV: SYSSLV
C   Subroutines employing SYMSLV: ATXPXA
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8
     1A(NA,1),C(NC,1),T,P
      INTEGER
     1N,NA,NC,K,KK,DK,KM1,L,LL,DL,LDL,I,IA,J,NSYS
      COMMON/SLVBLK/T(5,5),P(5),NSYS
      L = 1
   10   DL = 1
        IF(L .EQ. N) GO TO 20
        IF(A(L+1,L) .NE. 0.) DL = 2
   20   LL = L+DL-1
        K = L
   30     KM1 = K-1
          DK = 1
          IF(K .EQ. N) GO TO 35
          IF(A(K+1,K) .NE. 0.) DK = 2
   35     KK = K+DK-1
          IF(K .EQ. L) GO TO 45
          DO 40 I=K,KK
            DO 40 J=L,LL
              DO 40 IA=L,KM1
                C(I,J) = C(I,J) - A(IA,I)*C(IA,J)
   40     CONTINUE
   45     IF(DL .EQ. 2) GO TO 60
          IF(DK .EQ. 2 ) GO TO 50
          T(1,1) = A(K,K) + A(L,L)
          IF(T(1,1) .EQ. 0.) STOP
          C(K,L) = C(K,L)/T(1,1)
          GO TO 90
  50      T(1,1) = A(K,K) + A(L,L)
          T(1,2) = A(KK,K)
          T(2,1) = A(K,KK)
          T(2,2) = A(KK,KK) + A(L,L)
          P(1) = C(K,L)
          P(2) = C(KK,L)
          NSYS = 2
          CALL SYSSLV
          C(K,L) = P(1)
        C(KK,L) = P(2)
          GO TO 90
  60      IF(DK .EQ. 2) GO TO 70
          T(1,1) = A(K,K) + A(L,L)
          T(1,2) = A(LL,L)
          T(2,1) = A(L,LL)
          T(2,2) = A(K,K) + A(LL,LL)
          P(1) = C(K,L)
          P(2) = C(K,LL)
          NSYS = 2
          CALL SYSSLV
          C(K,L) = P(1)
          C(K,LL) = P(2)
          GO TO 90
  70      IF(K .NE. L) GO TO 80
          T(1,1) = A(L,L)
          T(1,2) = A(LL,L)
          T(1,3) = 0.
          T(2,1) = A(L,LL)
          T(2,2) = A(L,L) + A(LL,LL)
          T(2,3) = T(1,2)
          T(3,1) = 0.
          T(3,2) = T(2,1)
          T(3,3) = A(LL,LL)
          P(1) = C(L,L)/2.
          P(2) = C(LL,L)
          P(3) = C(LL,LL)/2.
          NSYS = 3
          CALL SYSSLV
          C(L,L) = P(1)
          C(LL,L) = P(2)
          C(L,LL) = P(2)
          C(LL,LL) = P(3)
          GO TO 90
  80      T(1,1) = A(K,K) + A(L,L)
          T(1,2) = A(KK,K)
          T(1,3) = A(LL,L)
          T(1,4) = 0.
          T(2,1) = A(K,KK)
          T(2,2) = A(KK,KK) + A(L,L)
          T(2,3) = 0.
          T(2,4) = T(1,3)
          T(3,1) = A(L,LL)
          T(3,2) = 0.
          T(3,3) = A(K,K) + A(LL,LL)
          T(3,4) = T(1,2)
          T(4,1) = 0.
          T(4,2) = T(3,1)
          T(4,3) = T(2,1)
          T(4,4) = A(KK,KK) + A(LL,LL)
          P(1) = C(K,L)
          P(2) = C(KK,L)
          P(3) = C(K,LL)
          P(4) = C(KK,LL)
          NSYS = 4
          CALL SYSSLV
          C(K,L) = P(1)
          C(KK,L) = P(2)
          C(K,LL) = P(3)
          C(KK,LL) = P(4)
  90    K = K + DK
        IF(K .LE. N) GO TO 30
        LDL = L + DL
        IF(LDL .GT. N) RETURN
        DO 120 J=LDL,N
          DO 100 I=L,LL
            C(I,J) = C(J,I)
  100     CONTINUE
          DO 120 I=J,N
            DO 110 K=L,LL
              C(I,J) = C(I,J) - C(I,K)*A(K,J) - A(K,I)*C(K,J)
  110     CONTINUE
          C(J,I) = C(I,J)
  120 CONTINUE
      L = LDL
      GO TO 10
      END


SUBROUTINE p103(input_file,output_file)
!-------------------------------------------------------------------------
! Program 10.3: Eigenvalue analysis of an elastic solid in plane strain
!               using 4-node rectangular quadrilaterals. Lanczos Method.
!               Consistent mass. Mesh numbered in y-direction.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,iflag=-1,iters,jflag,k,lalfa,leig,lp=6,lx,lz,nband=0,     &
   ndim=2,ndof,neig=0,nels,neq,nip=4,nlen,nmodes,nn,nod,nodof=2,nprops=3, &
   np_types,nr,nst=3,nxe,nye
 REAL(iwp)::acc,det,el,er,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!----------------------------- dynamic arrays-----------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),jeig(:,:),nf(:,:),&
   nu(:),num(:)
 REAL(iwp),ALLOCATABLE::alfa(:),bee(:,:),beta(:),coord(:,:),dee(:,:),     &
   del(:),der(:,:),deriv(:,:),diag(:),ecm(:,:),eig(:),fun(:),g_coord(:,:),&
   jac(:,:),kb(:,:),km(:,:),mb(:,:),mm(:,:),points(:,:),prop(:,:),ua(:),  &
   udiag(:),va(:),v_store(:,:),weights(:),w1(:),x(:),x_coords(:),y(:,:),  &
   y_coords(:),z(:,:)
!---------------------------input and initialisation----------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,nod,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ndof=nod*nodof
 ALLOCATE(nf(nodof,nn),points(nip,ndim),dee(nst,nst),g_coord(ndim,nn),    &
   coord(nod,ndim),fun(nod),jac(ndim,ndim),weights(nip),g_num(nod,nels),  &
   der(ndim,nod),deriv(ndim,nod),bee(nst,ndof),num(nod),km(ndof,ndof),    &
   g(ndof),g_g(ndof,nels),mm(ndof,ndof),ecm(ndof,ndof),                   &
   prop(nprops,np_types),x_coords(nxe+1),y_coords(nye+1),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 READ(10,*)nmodes,el,er,lalfa,leig,lx,lz,acc
 ALLOCATE(eig(leig),x(lx),del(lx),nu(lx),jeig(2,leig),alfa(lalfa),        &
   beta(lalfa),z(lz,leig))
!-------- loop the elements to find nband and set up global arrays -------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   IF(nband<bandwidth(g))nband=bandwidth(g)
 END DO elements_1
 WRITE(11,'(A,I5,A,/,A,I5,/,A,I5)')" There are",neq," equations",         &
   " The half-bandwidth (including diagonal) is",nband+1
 ALLOCATE(kb(neq,nband+1),mb(neq,nband+1),ua(0:neq),va(0:neq),            &
   diag(0:neq),udiag(0:neq),w1(0:neq),y(0:neq,leig),v_store(0:neq,lalfa))
 kb=zero
 mb=zero
 ua=zero
 va=zero
 eig=zero
 jeig=0
 x=zero
 del=zero
 nu=0
 alfa=zero
 beta=zero
 diag=zero
 udiag=zero
 w1=zero
 y=zero
 z=zero
 CALL sample(element,points,weights)
!----------------- element stiffness integration and assembly-------------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   mm=zero
   integrating_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     call beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
     call ecmat(ecm,fun,ndof,nodof)
     mm=mm+ecm*det*weights(i)*prop(3,etype(iel))
   END DO integrating_pts_1
   CALL formkb(kb,km,g)
   CALL formkb(mb,mm,g)
 END DO elements_2
 CALL cholin(mb)
!------------------------------find eigenvalues---------------------------
 DO iters=1,lalfa
   CALL lancz1(neq,el,er,acc,leig,lx,lalfa,lp,iflag,ua,va,eig,jeig,neig,x,&
     del,nu,alfa,beta,v_store)
   IF(iflag==0)EXIT
   IF(iflag>1)THEN
     WRITE(11,'(A,I5)')                                                   &
       " Lancz1 is signalling failure, with iflag = ",   iflag
     STOP
   END IF
!--- iflag = 1 therefore form u + a * v  ( candidate for ebe ) -----------
   udiag=va
   CALL chobk2(mb,udiag)
   CALL banmul(kb,udiag,diag)
   CALL chobk1(mb,diag)
   ua=ua+diag
 END DO
!--- iflag = 0 therefore write out the spectrum  -------------------------
 WRITE(11,'(A,I5,A/)')" It took",iters," iterations"
 WRITE(11,'(3(A,E12.4))')" Eigenvalues in the range",el," and",er," are:"
 WRITE(11,'(6E12.4)')eig(1:neig)
!------------------- calculate the eigenvectors --------------------------
 IF(neig>10)neig=10
  CALL lancz2(neq,lalfa,lp,eig,jeig,neig,alfa,beta,lz,jflag,y,w1,z,v_store)
!-------------------if jflag is zero  calculate the eigenvectors ---------
 IF(jflag==0)THEN
   DO i=1,nmodes
     udiag(:)=y(:,i)
     CALL chobk2(mb,udiag)
     WRITE(11,'(" Eigenvector number",I4," is:")')i
     WRITE(11,'(6E12.4)')udiag(1:)/MAXVAL(ABS(udiag(1:)))
   END DO
 ELSE
! lancz2 fails
   WRITE(11,'(A,I5)')" Lancz2 is signalling failure with jflag = ",jflag
 END IF
END SUBROUTINE p103


      subroutine runY_i(i,j,i1,f,Xtwiddle,Gtt,Gtwiddle,Shat2,Czero1,N0)
      implicit none
C---  Expression for Eq. 5.57
C---  Calculates Di, requires D00i
C---  Small terms of order Xtwiddle(0,j)*Dii
C---  Denominator Xtwiddle(i,j)

      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i,j,i1,n,m,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),
     . Gtwiddle(np,np),f(np),Gtt(np,np,np,np)
      double complex Shat2(np,z1max,-2:0),Czero1(z1max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat2(m,i1,ep)-2d0*delta(m,i1)*Dv(dd00+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4*Dv(dzzi(i1)+N0,ep-1)
      Dv(di(i1)+N0,ep)=
     .  (Gtwiddle(i,j)*(4d0*Dv(dzzi(i1)+N0,ep)+pole-Czero1(i1,ep))
     . +bit+Xtwiddle(0,j)*Dv(dii(z2(i,i1))+N0,ep))/Xtwiddle(i,j)

      enddo
      return
      end


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of COUNT()
module m
  logical, parameter :: arr(3,4) = reshape([(modulo(j, 2) == 1, j = 1, size(arr))], shape(arr))
  logical, parameter :: test_1 = count([1, 2, 3, 2, 1] < [(j, j=1, 5)]) == 2
  logical, parameter :: test_2 = count(arr) == 6
  logical, parameter :: test_3 = all(count(arr, dim=1) == [2, 1, 2, 1])
  logical, parameter :: test_4 = all(count(arr, dim=2) == [2, 2, 2])
  logical, parameter :: test_5 = count(logical(arr, kind=1)) == 6
  logical, parameter :: test_6 = count(logical(arr, kind=2)) == 6
end module


c--- Combinations of bubble integrals, 0704.3914v3 Eq. (3.21)
c--- The hatted versions of these functions are further defined
c--- by Eqs. (3.25), (3.26) and (3.27)
      double complex function BGRL1(s,t)
      implicit none
      double complex lnrat
      double precision s,t
      BGRL1=lnrat(-s,-t)/dcmplx(s-t)
      return
      end

      double complex function BGRL2(s,t)
      implicit none
      double complex lnrat
      double precision s,t
      BGRL2=lnrat(-s,-t)/dcmplx(s-t)**2
      return
      end

      double complex function BGRL2hat(s,t)
      implicit none
      double complex lnrat
      double precision s,t
      BGRL2hat=lnrat(-s,-t)/dcmplx(s-t)**2
     . -dcmplx(0.5d0*(s+t)/((s-t)*s*t))
      return
      end

      double complex function BGRL3(s,t)
      implicit none
      double complex lnrat
      double precision s,t
      BGRL3=lnrat(-s,-t)/dcmplx(s-t)**3
      return
      end

      double complex function BGRL3hat(s,t)
      implicit none
      double complex lnrat
      double precision s,t
      BGRL3hat=lnrat(-s,-t)/dcmplx(s-t)**3
     . -dcmplx(0.5d0*(s+t)/((s-t)**2*s*t))
      return
      end


!/*--------------------------------------------------------------------*\
!Application
!   VectorRelation
!
!Purpose
!   Transform vectors relative to CFD model coordinates
!
! This file is provided courtesy of the United States Army Corps of
!   Engineers, Engineer Research and Development Center, Environmental
!   Laboratory. See license file for information on usage.
!
!\*--------------------------------------------------------------------*/

                                                                                ! Equivalence in BehaviorRule code:
      Subroutine VectorRelation(
     I                          VectorType,                              ! Local scalar             => PositionVector=0 ; VelocityVector=1
     I                          MVComponentsCFD,                         ! Local array              MVComponentsCFD(1:3)
     I                          VldRVOrientXYZ,                          ! Local array              VldRVOrientXYZ(1:2)
     O                          VldMVOrientXYZ,                          ! Local array              VldMVOrientXYZ(1:2)
     I                          RVaoCFDXYZ,                              ! Local array              RVaoCFDXYZ(1:2)
     I                          RVvoCFDXYZ,                              ! Local array              RVvoCFDXYZ(1:3)
     O                          MVaoRVXY,                                ! Local scalar             => (M)aster (V)ector (a)ngle (o)ff (R)eference (V)ector's xy-axis
     O                          MVaoCFDXYZ,                              ! Local array              MVaoCFDXYZ(1:2)
     O                          MVvoRVXYZ                                ! Local array              MVvoRVXYZ(1:3)       => (M)aster (V)ector (v)elocity (o)ff (R)eference (V)ector's xy-axis
     .                          )
      IMPLICIT NONE

      INTEGER VldMVOrientXYZ(2),                                         ! Arrays
     .        VldRVOrientXYZ(2),
     .        VectorType,XYZ                                             ! Scalars

      real*8  MVComponentsCFD(3),                                        ! Arrays
     .        RVaoCFDXYZ(2),
     .        MVaoCFDXYZ(2),
     .        RVvoCFDXYZ(3),
     .        MVvoRVCFDXYZ(3),
     .        MVvoRVXYZ(3),
     .        AbsMVaoCFDXY,                                              ! Scalars
     .        MVvroCFDXY,AbsMVaoCFDZ,MVaoRVXY,MVvroRVXY,MVaoRVXYRad

! Determine angle of the Master Vector relative to the
! CFD xy-axis:

      IF ((MVComponentsCFD(1) .EQ. 0.0) .AND.
     .    (MVComponentsCFD(2) .EQ. 0.0)) THEN
        VldMVOrientXYZ(1) = 0                                            ! No valid xy-plane orientation of master vector
        MVaoCFDXYZ(1)     = 0.0
      ELSE
        VldMVOrientXYZ(1) = 1                                            ! Valid xy-plane orientation of master vector can be determined
        AbsMVaoCFDXY = ABS(ATAN2(ABS(MVComponentsCFD(2)),
     .                           ABS(MVComponentsCFD(1))))

        IF      ((MVComponentsCFD(1) >= 0.0) .AND.
     .           (MVComponentsCFD(2) >= 0.0)) THEN
          MVaoCFDXYZ(1) =         AbsMVaoCFDXY * (180.0 / 3.14159)       ! (M)aster (V)ector (a)ngle (o)ff CFD xy-axis orientation
        ELSE IF ((MVComponentsCFD(1) <= 0.0) .AND.
     .           (MVComponentsCFD(2) >= 0.0)) THEN
          MVaoCFDXYZ(1) = 180.0 - AbsMVaoCFDXY * (180.0 / 3.14159)       ! (M)aster (V)ector (a)ngle (o)ff CFD xy-axis orientation
        ELSE IF ((MVComponentsCFD(1) <= 0.0) .AND.
     .           (MVComponentsCFD(2) <= 0.0)) THEN
          MVaoCFDXYZ(1) = 180.0 + AbsMVaoCFDXY * (180.0 / 3.14159)       ! (M)aster (V)ector (a)ngle (o)ff CFD xy-axis orientation
        ELSE IF ((MVComponentsCFD(1) >= 0.0) .AND.
     .           (MVComponentsCFD(2) <= 0.0)) THEN
          MVaoCFDXYZ(1) = 360.0 - AbsMVaoCFDXY * (180.0 / 3.14159)       ! (M)aster (V)ector (a)ngle (o)ff CFD xy-axis orientation
        END IF
      END IF

! Determine angle of the Master Vector vertical component relative to the
! CFD xy-plane:

      MVvroCFDXY = SQRT( MVComponentsCFD(1) * MVComponentsCFD(1) +
     .                   MVComponentsCFD(2) * MVComponentsCFD(2) )
      IF ((   MVvroCFDXY      .EQ. 0.0) .AND.
     .    (MVComponentsCFD(3) .EQ. 0.0)) THEN
        VldMVOrientXYZ(2) = 0                                            ! No valid vertical orientation of master vector
        MVaoCFDXYZ(2)     = 0.0
      ELSE
        VldMVOrientXYZ(2) = 1                                            ! Valid vertical orientation of master vector can be determined
        AbsMVaoCFDZ = ABS(ATAN2(ABS(MVComponentsCFD(3)),
     .                          ABS(MVvroCFDXY)))
        IF (MVComponentsCFD(3) >= 0.0) THEN
          MVaoCFDXYZ(2) =  AbsMVaoCFDZ * (180.0 / 3.14159)               ! (M)aster (V)ector (a)ngle (o)ff CFD xy-plane
        ELSE
          MVaoCFDXYZ(2) = -AbsMVaoCFDZ * (180.0 / 3.14159)               ! (M)aster (V)ector (a)ngle (o)ff CFD xy-plane
        END IF
      END IF

! Determine angle of the Master Vector relative to the
! Reference Vector's xy-axis:

      IF ((VldRVOrientXYZ(1) .EQ. 1) .AND.
     .    (VldMVOrientXYZ(1) .EQ. 1)) THEN
        MVaoRVXY = MVaoCFDXYZ(1) - RVaoCFDXYZ(1)                         ! (M)aster (V)ector (a)ngle (o)ff (R)eference (V)ector's xy-axis

        IF      (MVaoRVXY < 0.0) THEN
          MVaoRVXY = MVaoRVXY + 360.0
        ELSE IF (MVaoRVXY > 360.0) THEN
          MVaoRVXY = MVaoRVXY - 360.0
        END IF
        IF (MVaoRVXY > 180.0) MVaoRVXY = MVaoRVXY - 360.0                ! Make angles go from 0.0 to 180.0 and 0.0 to -180.0
      ELSE
        MVaoRVXY = 0.0                                                   ! (M)aster (V)ector (a)ngle (o)ff (R)eference (V)ector's xy-axis
      END IF

! Determine velocity of the Master Vector relative to the
! Reference Vector's xyz-axis velocity:

      IF (VectorType .EQ. 0) THEN                                        ! Skip velocity calcs if vector is a 'position vector' (and not a 'velocity vector')
        MVvoRVXYZ(1:3) = 0.0
        GOTO 2332
      END IF
      DO XYZ=1,3
        MVvoRVCFDXYZ(XYZ) = MVComponentsCFD(XYZ) - RVvoCFDXYZ(XYZ)       ! RVvoCFDXYZ(XYZ) units are m/s, so calcs here only valid if MVComponentsCFD(XYZ) units are also m/s
      END DO
      MVvroRVXY = SQRT( MVvoRVCFDXYZ(1) * MVvoRVCFDXYZ(1) +              ! (M)aster (V)ector (v)elocity (r)esultant (o)ff (R)eference (V)ector's xy-axis
     .                  MVvoRVCFDXYZ(2) * MVvoRVCFDXYZ(2) )
      IF      ((MVaoRVXY >=  0.0) .AND.
     .         (MVaoRVXY <= 90.0)) THEN
        MVaoRVXYRad  =          MVaoRVXY  * (3.14159 / 180.0)
        MVvoRVXYZ(1) =  MVvroRVXY * COS(MVaoRVXYRad)                     ! (M)aster (V)ector (v)elocity (o)ff (R)eference (V)ector's xy-axis
        MVvoRVXYZ(2) =  MVvroRVXY * SIN(MVaoRVXYRad)                     ! (M)aster (V)ector (v)elocity (o)ff (R)eference (V)ector's xy-axis
      ELSE IF ((MVaoRVXY >=  90.0) .AND.
     .         (MVaoRVXY <= 180.0)) THEN
        MVaoRVXYRad  = (180.0 - MVaoRVXY) * (3.14159 / 180.0)
        MVvoRVXYZ(1) = -MVvroRVXY * COS(MVaoRVXYRad)
        MVvoRVXYZ(2) =  MVvroRVXY * SIN(MVaoRVXYRad)
      ELSE IF ((MVaoRVXY <=   0.0) .AND.
     .         (MVaoRVXY >= -90.0)) THEN
        MVaoRVXYRad  =         -MVaoRVXY  * (3.14159 / 180.0)
        MVvoRVXYZ(1) =  MVvroRVXY * COS(MVaoRVXYRad)
        MVvoRVXYZ(2) = -MVvroRVXY * SIN(MVaoRVXYRad)
      ELSE IF ((MVaoRVXY <=  -90.0) .AND.
     .         (MVaoRVXY >= -180.0)) THEN
        MVaoRVXYRad  = (180.0 + MVaoRVXY) * (3.14159 / 180.0)
        MVvoRVXYZ(1) = -MVvroRVXY * COS(MVaoRVXYRad)
        MVvoRVXYZ(2) = -MVvroRVXY * SIN(MVaoRVXYRad)
      ELSE
        WRITE(*,*) 'vect.Rel. error: Invalid MVaoRVXY value', MVaoRVXY
        STOP
      END IF
      MVvoRVXYZ(3) = MVvoRVCFDXYZ(3)
 2332 CONTINUE

      RETURN
      END


      PROGRAM DEPTH
C
C     PRINTOUT HYCOM Z-DEPTHS FOR FIVE DIFFERENT DP00F CHOICES
C     THESE DP00F VALUES WERE CHOSEN BECAUSE THEIR 6-TH POWERS
C     ARE (APPROXIMATELY) ROUND NUMBERS:
C     1.07**6 = 1.5,  1.125**6 = 2,  1.2**6 = 3,  1.26**6 = 4.
C
C --- 'dp00f'  = z-level spacing stretching factor (1.0=const.spacing)
C --- 'dp00'   = z-level spacing minimum thickness (m)
C --- 'dp00x'  = z-level spacing maximum thickness (m)
C
      REAL DP00(5),DP00F(5),DPK(5),DPS(5),DP00X
      DATA DP00F /  1.000, 1.070, 1.125, 1.200, 1.260 /
      DATA DPS   /  0.000, 0.000, 0.000, 0.000, 0.000 /
C
      WRITE(6,'(a)',ADVANCE='NO') 'DP00F=1.000; DP00 = '
      READ( 5,*) DP00(1)
      WRITE(6,'(a)',ADVANCE='NO') 'DP00F=1.070; DP00 = '
      READ( 5,*) DP00(2)
      WRITE(6,'(a)',ADVANCE='NO') 'DP00F=1.125; DP00 = '
      READ( 5,*) DP00(3)
      WRITE(6,'(a)',ADVANCE='NO') 'DP00F=1.200; DP00 = '
      READ( 5,*) DP00(4)
      WRITE(6,'(a)',ADVANCE='NO') 'DP00F=1.260; DP00 = '
      READ( 5,*) DP00(5)
C
      WRITE(6,'(a)',ADVANCE='NO') '            DP00X = '
      READ( 5,*) DP00X
C
      WRITE(6,*)
      WRITE(6,'(6A)')
     + '# K  ',
     + ' DP00F=1.000  ',
     + ' DP00F=1.070  ',
     + ' DP00F=1.125  ',
     + ' DP00F=1.200  ',
     + ' DP00F=1.260  '
      DO K= 1,25
        DO L= 1,5
          DPK(L) = MIN(DP00X,DP00(L)*DP00F(L)**(K-1))
          DPS(L) = DPS(L) + DPK(L)
        ENDDO
        WRITE(6,'(I3,5(2F7.1))') K,(DPK(L),DPS(L),L=1,5)
      ENDDO
      END


SUBROUTINE clawpack5_rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr, &
     aux1,aux2,aux3,asdq,bmasdq,bpasdq)
  !!   =====================================================

  IMPLICIT DOUBLE PRECISION (a-h,o-z)

  !! # Riemann solver in the transverse direction for 2D Burgers' equation

  !! # Split asdq into eigenvectors of Roe matrix B.
  !! # For the scalar equation, this simply amounts to computing the
  !! # transverse wave speed from the opposite Riemann problem.

  DIMENSION    ql(meqn, 1-mbc:maxm+mbc)
  DIMENSION    qr(meqn, 1-mbc:maxm+mbc)
  DIMENSION   asdq(meqn, 1-mbc:maxm+mbc)
  DIMENSION bmasdq(meqn, 1-mbc:maxm+mbc)
  DIMENSION bpasdq(meqn, 1-mbc:maxm+mbc)

  !! # x- and y- Riemann problems are identical, so it doesn't matter if
  !! # ixy=1 or 2.

  DO i = 2-mbc, mx+mbc
     sb = 0.5d0*(qr(1,i-1) + ql(1,i))
     bmasdq(1,i) = dmin1(sb, 0.d0) * asdq(1,i)
     bpasdq(1,i) = dmax1(sb, 0.d0) * asdq(1,i)
  ENDDO

  RETURN
END SUBROUTINE clawpack5_rpt2


module process_mod
contains
   subroutine process(a, b, n)
      real :: a(:), b(:)
      integer :: n, i

      print *, "subroutine process..."
!$ACC PARALLEL LOOP
      do i = 1, n
         b(i) = exp(sin(a(i)))
      end do
!$ACC END PARALLEL LOOP

   end subroutine
end module process_mod

program simple

   use process_mod

   integer, parameter :: n = 1*10**9
   integer :: i
   real, allocatable:: a(:), b(:)
   allocate (a(n), b(n))

   print *, "initializing array..."
!$ACC PARALLEL LOOP
   do i = 1, n
      a(i) = asin(log(real(i)))
   end do
!ACC END PARALLEL LOOP

   call process(a, b, n)

end program simple