      SUBROUTINE iau_PLAN94 ( DATE1, DATE2, NP, PV, J )
*+
*  - - - - - - - - - - -
*   i a u _ P L A N 9 4
*  - - - - - - - - - - -
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Approximate heliocentric position and velocity of a nominated major
*  planet:  Mercury, Venus, EMB, Mars, Jupiter, Saturn, Uranus or
*  Neptune (but not the Earth itself).
*
*  Given:
*     DATE1    d       TDB date part A (Note 1)
*     DATE2    d       TDB date part B (Note 1)
*     NP       i       planet (1=Mercury, 2=Venus, 3=EMB ... 8=Neptune)
*
*  Returned:
*     PV       d(3,2)  planet pos,vel (heliocentric, J2000.0, au, au/d)
*     J        i       status: -1 = illegal NP (outside 1-8)
*                               0 = OK
*                              +1 = warning: date outside 1000-3000 AD
*                              +2 = warning: solution failed to converge
*
*  Notes:
*
*  1) The TDB date DATE1+DATE2 is a Julian Date, apportioned in any
*     convenient way between the two arguments.  For example,
*     JD(TDB)=2450123.7 could be expressed in any of these ways, among
*     others:
*
*            DATE1          DATE2
*
*         2450123.7D0        0D0        (JD method)
*          2451545D0      -1421.3D0     (J2000 method)
*         2400000.5D0     50123.2D0     (MJD method)
*         2450123.5D0       0.2D0       (date & time method)
*
*     The JD method is the most natural and convenient to use in
*     cases where the loss of several decimal digits of resolution
*     is acceptable.  The J2000 method is best matched to the way
*     the argument is handled internally and will deliver the
*     optimum resolution.  The MJD method and the date & time methods
*     are both good compromises between resolution and convenience.
*     The limited accuracy of the present algorithm is such that any
*     of the methods is satisfactory.
*
*  2) If an NP value outside the range 1-8 is supplied, an error
*     status (J = -1) is returned and the PV vector set to zeroes.
*
*  3) For NP=3 the result is for the Earth-Moon Barycenter.  To
*     obtain the heliocentric position and velocity of the Earth,
*     use instead the SOFA routine iau_EPV00.
*
*  4) On successful return, the array PV contains the following:
*
*        PV(1,1)  x       }
*        PV(2,1)  y       } heliocentric position, au
*        PV(3,1)  z       }
*
*        PV(1,2)  xdot    }
*        PV(2,2)  ydot    } heliocentric velocity, au/d
*        PV(3,2)  zdot    }
*
*     The reference frame is equatorial and is with respect to the
*     mean equator and equinox of epoch J2000.0.
*
*  5) The algorithm is due to J.L. Simon, P. Bretagnon, J. Chapront,
*     M. Chapront-Touze, G. Francou and J. Laskar (Bureau des
*     Longitudes, Paris, France).  From comparisons with JPL
*     ephemeris DE102, they quote the following maximum errors
*     over the interval 1800-2050:
*
*                     L (arcsec)    B (arcsec)      R (km)
*
*        Mercury          4             1             300
*        Venus            5             1             800
*        EMB              6             1            1000
*        Mars            17             1            7700
*        Jupiter         71             5           76000
*        Saturn          81            13          267000
*        Uranus          86             7          712000
*        Neptune         11             1          253000
*
*     Over the interval 1000-3000, they report that the accuracy is no
*     worse than 1.5 times that over 1800-2050.  Outside 1000-3000 the
*     accuracy declines.
*
*     Comparisons of the present routine with the JPL DE200 ephemeris
*     give the following RMS errors over the interval 1960-2025:
*
*                      position (km)     velocity (m/s)
*
*        Mercury            334               0.437
*        Venus             1060               0.855
*        EMB               2010               0.815
*        Mars              7690               1.98
*        Jupiter          71700               7.70
*        Saturn          199000              19.4
*        Uranus          564000              16.4
*        Neptune         158000              14.4
*
*     Comparisons against DE200 over the interval 1800-2100 gave the
*     following maximum absolute differences.  (The results using
*     DE406 were essentially the same.)
*
*                   L (arcsec)   B (arcsec)     R (km)   Rdot (m/s)
*
*        Mercury        7            1            500       0.7
*        Venus          7            1           1100       0.9
*        EMB            9            1           1300       1.0
*        Mars          26            1           9000       2.5
*        Jupiter       78            6          82000       8.2
*        Saturn        87           14         263000      24.6
*        Uranus        86            7         661000      27.4
*        Neptune       11            2         248000      21.4
*
*  6) The present SOFA re-implementation of the original Simon et al.
*     Fortran code differs from the original in the following respects:
*
*       *  The date is supplied in two parts.
*
*       *  The result is returned only in equatorial Cartesian form;
*          the ecliptic longitude, latitude and radius vector are not
*          returned.
*
*       *  The result is in the J2000.0 equatorial frame, not ecliptic.
*
*       *  More is done in-line:  there are fewer calls to other
*          routines.
*
*       *  Different error/warning status values are used.
*
*       *  A different Kepler's-equation-solver is used (avoiding
*          use of COMPLEX*16).
*
*       *  Polynomials in T are nested to minimize rounding errors.
*
*       *  Explicit double-precision constants are used to avoid
*          mixed-mode expressions.
*
*       *  There are other, cosmetic, changes to comply with SOFA
*          style conventions.
*
*     None of the above changes affects the result significantly.
*
*  7) The returned status, J, indicates the most serious condition
*     encountered during execution of the routine.  Illegal NP is
*     considered the most serious, overriding failure to converge,
*     which in turn takes precedence over the remote epoch warning.
*
*  Called:
*     iau_ANP      normalize angle into range 0 to 2pi
*
*  Reference:  Simon, J.L, Bretagnon, P., Chapront, J.,
*              Chapront-Touze, M., Francou, G., and Laskar, J.,
*              Astron. Astrophys. 282, 663 (1994).
*
*  This revision:  2017 March 16
*
*  SOFA release 2017-04-20
*
*  Copyright (C) 2017 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION DATE1, DATE2
      INTEGER NP
      DOUBLE PRECISION PV(3,2)
      INTEGER J

*  Maximum number of iterations allowed to solve Kepler's equation
      INTEGER KMAX
      PARAMETER ( KMAX = 10 )

*  2Pi
      DOUBLE PRECISION D2PI
      PARAMETER ( D2PI = 6.283185307179586476925287D0 )

*  Arcseconds to radians
      DOUBLE PRECISION DAS2R
      PARAMETER ( DAS2R = 4.848136811095359935899141D-6 )

*  Reference epoch (J2000.0), JD
      DOUBLE PRECISION DJ00
      PARAMETER ( DJ00 = 2451545D0 )

*  Days per Julian millennium
      DOUBLE PRECISION DJM
      PARAMETER ( DJM = 365250D0 )

*  Sin and cos of J2000.0 mean obliquity (IAU 1976)
      DOUBLE PRECISION SINEPS, COSEPS
      PARAMETER ( SINEPS = 0.3977771559319137D0,
     :            COSEPS = 0.9174820620691818D0 )

*  Gaussian constant
      DOUBLE PRECISION GK
      PARAMETER ( GK = 0.017202098950D0 )

      INTEGER JSTAT, I, K
      DOUBLE PRECISION AMAS(8), A(3,8), DLM(3,8), E(3,8),
     :                 PI(3,8), DINC(3,8), OMEGA(3,8),
     :                 KP(9,8), CA(9,8), SA(9,8),
     :                 KQ(10,8), CL(10,8), SL(10,8),
     :                 T, DA, DL, DE, DP, DI, DOM, DMU, ARGA, ARGL, AM,
     :                 AE, DAE, AE2, AT, R, V, SI2, XQ, XP, TL, XSW,
     :                 XCW, XM2, XF, CI2, XMS, XMC, XPXQ2, X, Y, Z

      DOUBLE PRECISION iau_ANPM

*  Planetary inverse masses
      DATA AMAS / 6023600D0, 408523.5D0, 328900.5D0, 3098710D0,
     :            1047.355D0, 3498.5D0, 22869D0, 19314D0 /

*
*  Tables giving the mean Keplerian elements, limited to T**2 terms:
*
*         A       semi-major axis (au)
*         DLM     mean longitude (degree and arcsecond)
*         E       eccentricity
*         PI      longitude of the perihelion (degree and arcsecond)
*         DINC    inclination (degree and arcsecond)
*         OMEGA   longitude of the ascending node (degree and arcsecond)
*
      DATA A /
     :  0.3870983098D0,             0D0,      0D0,
     :  0.7233298200D0,             0D0,      0D0,
     :  1.0000010178D0,             0D0,      0D0,
     :  1.5236793419D0,           3D-10,      0D0,
     :  5.2026032092D0,       19132D-10,  -39D-10,
     :  9.5549091915D0, -0.0000213896D0,  444D-10,
     : 19.2184460618D0,       -3716D-10,  979D-10,
     : 30.1103868694D0,      -16635D-10,  686D-10 /
*
      DATA DLM /
     : 252.25090552D0, 5381016286.88982D0,  -1.92789D0,
     : 181.97980085D0, 2106641364.33548D0,   0.59381D0,
     : 100.46645683D0, 1295977422.83429D0,  -2.04411D0,
     : 355.43299958D0,  689050774.93988D0,   0.94264D0,
     :  34.35151874D0,  109256603.77991D0, -30.60378D0,
     :  50.07744430D0,   43996098.55732D0,  75.61614D0,
     : 314.05500511D0,   15424811.93933D0,  -1.75083D0,
     : 304.34866548D0,    7865503.20744D0,   0.21103D0 /
*
      DATA E /
     : 0.2056317526D0,  0.0002040653D0,      -28349D-10,
     : 0.0067719164D0, -0.0004776521D0,       98127D-10,
     : 0.0167086342D0, -0.0004203654D0, -0.0000126734D0,
     : 0.0934006477D0,  0.0009048438D0,      -80641D-10,
     : 0.0484979255D0,  0.0016322542D0, -0.0000471366D0,
     : 0.0555481426D0, -0.0034664062D0, -0.0000643639D0,
     : 0.0463812221D0, -0.0002729293D0,  0.0000078913D0,
     : 0.0094557470D0,  0.0000603263D0,            0D0  /
*
      DATA PI /
     :  77.45611904D0,  5719.11590D0,   -4.83016D0,
     : 131.56370300D0,   175.48640D0, -498.48184D0,
     : 102.93734808D0, 11612.35290D0,   53.27577D0,
     : 336.06023395D0, 15980.45908D0,  -62.32800D0,
     :  14.33120687D0,  7758.75163D0,  259.95938D0,
     :  93.05723748D0, 20395.49439D0,  190.25952D0,
     : 173.00529106D0,  3215.56238D0,  -34.09288D0,
     :  48.12027554D0,  1050.71912D0,   27.39717D0 /
*
      DATA DINC /
     : 7.00498625D0, -214.25629D0,   0.28977D0,
     : 3.39466189D0,  -30.84437D0, -11.67836D0,
     :          0D0,  469.97289D0,  -3.35053D0,
     : 1.84972648D0, -293.31722D0,  -8.11830D0,
     : 1.30326698D0,  -71.55890D0,  11.95297D0,
     : 2.48887878D0,   91.85195D0, -17.66225D0,
     : 0.77319689D0,  -60.72723D0,   1.25759D0,
     : 1.76995259D0,    8.12333D0,   0.08135D0 /
*
      DATA OMEGA /
     :  48.33089304D0,  -4515.21727D0,  -31.79892D0,
     :  76.67992019D0, -10008.48154D0,  -51.32614D0,
     : 174.87317577D0,  -8679.27034D0,   15.34191D0,
     :  49.55809321D0, -10620.90088D0, -230.57416D0,
     : 100.46440702D0,   6362.03561D0,  326.52178D0,
     : 113.66550252D0,  -9240.19942D0,  -66.23743D0,
     :  74.00595701D0,   2669.15033D0,  145.93964D0,
     : 131.78405702D0,   -221.94322D0,   -0.78728D0 /
*
*  Tables for trigonometric terms to be added to the mean elements
*  of the semi-major axes.
*
      DATA KP /
     : 69613, 75645, 88306, 59899, 15746, 71087, 142173,  3086,    0,
     : 21863, 32794, 26934, 10931, 26250, 43725,  53867, 28939,    0,
     : 16002, 21863, 32004, 10931, 14529, 16368,  15318, 32794,    0,
     : 6345,   7818, 15636,  7077,  8184, 14163,   1107,  4872,    0,
     : 1760,   1454,  1167,   880,   287,  2640,     19,  2047, 1454,
     :  574,      0,   880,   287,    19,  1760,   1167,   306,  574,
     :  204,      0,   177,  1265,     4,   385,    200,   208,  204,
     :    0,    102,   106,     4,    98,  1367,    487,   204,    0 /
*
      DATA CA /
     :      4,    -13,    11,    -9,    -9,    -3,    -1,     4,    0,
     :   -156,     59,   -42,     6,    19,   -20,   -10,   -12,    0,
     :     64,   -152,    62,    -8,    32,   -41,    19,   -11,    0,
     :    124,    621,  -145,   208,    54,   -57,    30,    15,    0,
     : -23437,  -2634,  6601,  6259, -1507, -1821,  2620, -2115,-1489,
     :  62911,-119919, 79336, 17814,-24241, 12068,  8306, -4893, 8902,
     : 389061,-262125,-44088,  8387,-22976, -2093,  -615, -9720, 6633,
     :-412235,-157046,-31430, 37817, -9740,   -13, -7449,  9644,    0 /
*
      DATA SA /
     :     -29,    -1,     9,     6,    -6,     5,     4,     0,    0,
     :     -48,  -125,   -26,   -37,    18,   -13,   -20,    -2,    0,
     :    -150,   -46,    68,    54,    14,    24,   -28,    22,    0,
     :    -621,   532,  -694,   -20,   192,   -94,    71,   -73,    0,
     :  -14614,-19828, -5869,  1881, -4372, -2255,   782,   930,  913,
     :  139737,     0, 24667, 51123, -5102,  7429, -4095, -1976,-9566,
     : -138081,     0, 37205,-49039,-41901,-33872,-27037,-12474,18797,
     :       0, 28492,133236, 69654, 52322,-49577,-26430, -3593,    0 /
*
*  Tables giving the trigonometric terms to be added to the mean
*  elements of the mean longitudes.
*
      DATA KQ /
     :  3086, 15746, 69613, 59899, 75645, 88306, 12661, 2658,  0,   0,
     : 21863, 32794, 10931,    73,  4387, 26934,  1473, 2157,  0,   0,
     :    10, 16002, 21863, 10931,  1473, 32004,  4387,   73,  0,   0,
     :    10,  6345,  7818,  1107, 15636,  7077,  8184,  532, 10,   0,
     :    19,  1760,  1454,   287,  1167,   880,   574, 2640, 19,1454,
     :    19,   574,   287,   306,  1760,    12,    31,   38, 19, 574,
     :     4,   204,   177,     8,    31,   200,  1265,  102,  4, 204,
     :     4,   102,   106,     8,    98,  1367,   487,  204,  4, 102 /
*
      DATA CL /
     :     21,   -95, -157,   41,   -5,   42,   23,   30,     0,    0,
     :   -160,  -313, -235,   60,  -74,  -76,  -27,   34,     0,    0,
     :   -325,  -322,  -79,  232,  -52,   97,   55,  -41,     0,    0,
     :   2268,  -979,  802,  602, -668,  -33,  345,  201,   -55,    0,
     :   7610, -4997,-7689,-5841,-2617, 1115, -748, -607,  6074,  354,
     : -18549, 30125,20012, -730,  824,   23, 1289, -352,-14767,-2062,
     :-135245,-14594, 4197,-4030,-5630,-2898, 2540, -306,  2939, 1986,
     :  89948,  2103, 8963, 2695, 3682, 1648,  866, -154, -1963, -283 /
*
      DATA SL /
     :   -342,   136,  -23,   62,   66,  -52,  -33,   17,     0,    0,
     :    524,  -149,  -35,  117,  151,  122,  -71,  -62,     0,    0,
     :   -105,  -137,  258,   35, -116,  -88, -112,  -80,     0,    0,
     :    854,  -205, -936, -240,  140, -341,  -97, -232,   536,    0,
     : -56980,  8016, 1012, 1448,-3024,-3710,  318,  503,  3767,  577,
     : 138606,-13478,-4964, 1441,-1319,-1482,  427, 1236, -9167,-1918,
     :  71234,-41116, 5334,-4935,-1848,   66,  434,-1748,  3780, -701,
     : -47645, 11647, 2166, 3194,  679,    0, -244, -419, -2531,   48 /

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

*  Validate the planet number.
      IF ( NP.LT.1 .OR. NP.GT.8 ) THEN
         JSTAT = -1

*     Reset the result in case of failure.
         DO 2 K=1,2
            DO 1 I=1,3
               PV(I,K) = 0D0
 1          CONTINUE
 2       CONTINUE
      ELSE

*     Time: Julian millennia since J2000.0.
         T = ( ( DATE1-DJ00 ) + DATE2 ) / DJM

*     OK status unless remote epoch.
         IF ( ABS(T) .LE. 1D0 ) THEN
            JSTAT = 0
         ELSE
            JSTAT = 1
         END IF

*     Compute the mean elements.
         DA = A(1,NP) +
     :      ( A(2,NP) +
     :        A(3,NP) * T ) * T
         DL = ( 3600D0 * DLM(1,NP) +
     :                 ( DLM(2,NP) +
     :                   DLM(3,NP) * T ) * T ) * DAS2R
         DE = E(1,NP) +
     :      ( E(2,NP) +
     :        E(3,NP) * T ) * T
         DP = iau_ANPM ( ( 3600D0 * PI(1,NP) +
     :                            ( PI(2,NP) +
     :                              PI(3,NP) * T ) * T ) * DAS2R )
         DI = ( 3600D0 * DINC(1,NP) +
     :                 ( DINC(2,NP) +
     :                   DINC(3,NP) * T ) * T ) * DAS2R
         DOM = iau_ANPM ( ( 3600D0 * OMEGA(1,NP)
     :                           + ( OMEGA(2,NP)
     :                             + OMEGA(3,NP) * T ) * T ) * DAS2R )

*     Apply the trigonometric terms.
         DMU = 0.35953620D0 * T
         DO 3 K=1,8
            ARGA = KP(K,NP) * DMU
            ARGL = KQ(K,NP) * DMU
            DA = DA + ( CA(K,NP) * COS(ARGA) +
     :                  SA(K,NP) * SIN(ARGA) ) * 1D-7
            DL = DL + ( CL(K,NP) * COS(ARGL) +
     :                  SL(K,NP) * SIN(ARGL) ) * 1D-7
 3       CONTINUE
         ARGA = KP(9,NP) * DMU
         DA = DA + T * ( CA(9,NP) * COS(ARGA) +
     :                   SA(9,NP) * SIN(ARGA) ) * 1D-7
         DO 4 K=9,10
            ARGL = KQ(K,NP) * DMU
            DL = DL + T * ( CL(K,NP) * COS(ARGL) +
     :                      SL(K,NP) * SIN(ARGL) ) * 1D-7
 4       CONTINUE
         DL = MOD(DL, D2PI)

*     Iterative solution of Kepler's equation to get eccentric anomaly.
         AM = DL - DP
         AE = AM + DE*SIN(AM)
         K = 0
 5       CONTINUE
            DAE = ( AM - AE + DE*SIN(AE) ) / ( 1D0 - DE*COS(AE) )
            AE = AE + DAE
            K = K + 1
            IF ( K.GE.KMAX ) JSTAT = 2
         IF ( K.LT.KMAX .AND. ABS(DAE) .GT. 1D-12 ) GO TO 5

*     True anomaly.
         AE2 = AE / 2D0
         AT = 2D0 * ATAN2(SQRT((1D0+DE)/(1D0-DE)) * SIN(AE2),
     :                                              COS(AE2))

*     Distance (au) and speed (radians per day).
         R = DA * ( 1D0 - DE*COS(AE) )
         V = GK * SQRT( ( 1D0 + 1D0/AMAS(NP) ) / (DA*DA*DA))

         SI2 = SIN(DI/2D0)
         XQ = SI2 * COS(DOM)
         XP = SI2 * SIN(DOM)
         TL = AT + DP
         XSW = SIN(TL)
         XCW = COS(TL)
         XM2 = 2D0 * ( XP*XCW - XQ*XSW )
         XF = DA / SQRT(1D0 - DE*DE)
         CI2 = COS(DI/2D0)
         XMS = ( DE * SIN(DP) + XSW ) * XF
         XMC = ( DE * COS(DP) + XCW ) * XF
         XPXQ2 = 2D0 * XP * XQ

*     Position (J2000.0 ecliptic x,y,z in au).
         X = R * ( XCW - XM2*XP )
         Y = R * ( XSW + XM2*XQ )
         Z = R * ( -XM2 * CI2 )

*     Rotate to equatorial.
         PV(1,1) = X
         PV(2,1) = Y*COSEPS - Z*SINEPS
         PV(3,1) = Y*SINEPS + Z*COSEPS

*     Velocity (J2000.0 ecliptic xdot,ydot,zdot in au/d).
         X = V * ( ( -1D0 + 2D0*XP*XP ) * XMS + XPXQ2 * XMC )
         Y = V * ( ( 1D0 - 2D0*XQ*XQ ) * XMC - XPXQ2 * XMS )
         Z = V * ( 2D0 * CI2 * ( XP*XMS + XQ*XMC ) )

*     Rotate to equatorial.
         PV(1,2) = X
         PV(2,2) = Y*COSEPS - Z*SINEPS
         PV(3,2) = Y*SINEPS + Z*COSEPS

      END IF

*  Return the status.
      J = JSTAT

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2017
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
module global_1d_models
!-------------------------------------------------------------------------------
!  Provides some global 1d isotropic velocity models and a few functions relating
!  to 1d models

      implicit none

!  ** size constants
      integer, parameter, private :: i4 = selected_int_kind(9) ; ! long int
      integer, parameter, private :: r4 = selected_real_kind(6,37) ; ! SP
      integer, parameter, private :: r8 = selected_real_kind(15,307) ; ! DP

!  ** precision selector
      integer, parameter, private :: rs = r8

!  ** maths constants and other useful things
      real(rs), parameter, private :: pi = 3.141592653589793238462643 ;
      real(rs), parameter, private :: to_rad = 1.74532925199433e-002 ;
      real(rs), parameter, private :: to_deg = 57.2957795130823e0 ;
      real(rs), parameter, private :: to_km = 111.194926644559 ;

      real(rs), parameter, private :: big_number = 10.e36 ;

      real(rs), parameter, private :: bigG = 6.67428e-11  ! Newton's gravitational constant

!  ** Available models:
      character(len=32),parameter,private :: available_models(2) = (/ 'AK135', &
                                                                      'PREM ' /)

!  ** Public model constants
      real(rs), parameter, public :: AK135_radius_km = 6371._rs, &
                                     PREM_radius_km = 6371._rs
   contains

!===============================================================================
   function gravity(depth,model)
!===============================================================================
!  Returns the acceleration due to gravity at a given depth in the specified model.
!  Assumes AK135 unless stated.
!  Input depth in km, converted to m for calculation within the function.
!  g = GM/r**2
!  M = 4π∫ rho(r) r**2 dr

     real(rs),intent(in) :: depth
     character(len=*),optional :: model
     character(len=5) :: model_in
     real(rs) :: gravity,r,r0,r1,M,rho,z
     integer :: ir
     real(rs),parameter :: dr=1.

!  Check if we've specified PREM instead, and stop for bad input
     model_in = 'AK135'
     if (present(model)) model_in = trim(model)
     if (trim(model_in) /= 'PREM' .and. trim(model_in) /= 'AK135') then
       write(0,'(a,a,a)') "gravity: model '",trim(model_in),"' not recognised."
       write(0,'(a)') '   Available models are: ', available_models
       stop
     endif
!  Check our depth isn't silly
     if (depth < 0. .or. depth > 6371.) then
       write(0,'(a)') 'gravity: Depth must be in range 0--6371 km'
       stop
     endif

!  Get radius required
     r = 6371. - depth

     M = 0.
     r0 = 0.
!  Calculate mass up to radius required
     do ir=1,int(r),int(dr)
       r1 = real(ir)                ! Radius to top of shell
       z = 6371. - (r0 + r1)/2.     ! Depth to middle of shell
       if (trim(model_in) == 'AK135') call ak135(z,rho=rho)
       if (trim(model_in) == 'PREM' ) then
          call prem(depth, g=gravity)
          return
       endif
       rho = rho * 1.e3             ! Convert to kg/m^3
       M = M + rho*(4./3.)*pi*((r1 * 1.e3)**3 - (r0 * 1.e3)**3) ! Add mass within shell
       r0 = r1                      ! Next layer upwards
     enddo

!  Calculate g
     gravity = bigG *  M / (r * 1.e3)**2

   end function gravity
!-------------------------------------------------------------------------------

!===============================================================================
   function pressure(depth,model)
!===============================================================================
!  Calculate pressure as a function of depth for a specified model.
!  Assumes AK135 unless otherwise stated.
!  Input depth in km.

      real(rs),intent(in) :: depth
      real(rs)            :: pressure
      character(len=*),optional :: model
      character(len=5)          :: model_in
      real(rs)                  :: rho, r, P, r0, r1, dep
      real(rs),parameter        :: dr=10.   ! integration width

      model_in='AK135'
      if (present(model)) model_in = trim(model)
     if (trim(model_in) /= 'PREM' .and. trim(model_in) /= 'AK135') then
       write(0,'(a,a,a)') "pressure: model '",trim(model_in),"' not recognised."
       write(0,'(a)') '   Available models are: ', available_models
       stop
     endif
!  Check our depth isn't silly
     if (depth < 0. .or. depth > 6371.) then
       write(0,'(a)') 'pressure: Depth must be in range 0--6371 km'
       stop
     endif

!  Get radius required
     r = 6371. - depth

!  Calculate pressure by integrating downwards
      P = 0.
      r1 = 6371.
      do while (r1 >= r)
         dep = 6371. - r1
         if (trim(model_in) == 'AK135') call ak135(dep,rho=rho)
         if (trim(model_in) == 'PREM' ) call prem(dep,rho=rho)
         P = P + gravity(dep,model=model)*(rho*1.e3)*(dr*1.e3)
         r1 = r1 - dr
      enddo

      pressure = P / 1.e9   ! GPa

   end function pressure
!-------------------------------------------------------------------------------

!===============================================================================
subroutine ak135(depth,vp,vs,rho)
!===============================================================================
!  AK135 model

   real(rs),intent(in) :: depth
   real(rs),intent(out),optional :: vp,vs,rho
   integer, parameter :: nlayers = 136
   real(rs) :: den1,den2,vp1,vp2,vs1,vs2,dep1,dep2
   integer :: i
   logical :: twodepths

   real(rs), parameter, dimension(nlayers) ::  dep = (/ &
       0.0,   20.0,   20.0,   35.0,   35.0, &
      77.5,  120.0,  165.0,  210.0,  210.0, &
      260.0,  310.0,  360.0,  410.0,  410.0, &
      460.0,  510.0,  560.0,  610.0,  660.0, &
      660.0,  710.0,  760.0,  809.5,  859.0, &
      908.5,  958.0, 1007.5, 1057.0, 1106.5, &
     1156.0, 1205.5, 1255.0, 1304.5, 1354.0, &
     1403.5, 1453.0, 1502.5, 1552.0, 1601.5, &
     1651.0, 1700.5, 1750.0, 1799.5, 1849.0, &
     1898.5, 1948.0, 1997.5, 2047.0, 2096.5, &
     2146.0, 2195.5, 2245.0, 2294.5, 2344.0, &
     2393.5, 2443.0, 2492.5, 2542.0, 2591.5, &
     2640.0, 2690.0, 2740.0, 2740.0, 2789.7, &
     2839.3, 2891.5, 2891.5, 2939.3, 2989.7, &
     3040.0, 3090.3, 3140.7, 3191.0, 3241.3, &
     3291.7, 3342.0, 3392.3, 3442.6, 3493.0, &
     3543.3, 3593.6, 3644.0, 3694.3, 3744.6, &
     3795.0, 3845.3, 3895.6, 3945.9, 3996.3, &
     4046.6, 4096.9, 4147.3, 4197.6, 4247.9, &
     4298.3, 4348.6, 4398.9, 4449.3, 4499.6, &
     4549.9, 4600.3, 4650.6, 4700.9, 4801.6, &
     4851.9, 4902.2, 4952.6, 5002.9, 5053.2, &
     5103.6, 5153.5, 5153.5, 5204.6, 5255.3, &
     5306.0, 5356.8, 5407.5, 5458.2, 5508.9, &
     5559.6, 5610.3, 5661.0, 5711.7, 5813.2, &
     5863.9, 5914.6, 5965.3, 6016.0, 6066.7, &
     6117.4, 6168.1, 6218.9, 6269.6, 6320.3, &
     6371.0 /)

   real(rs), parameter, dimension(nlayers) :: den = (/ &
      2.44900,  2.44900,  2.71420,  2.71420,  3.29760, &
      3.29940,  3.30130,  3.34870,  3.39600,  3.39600, &
      3.46520,  3.53430,  3.60340,  3.67260,  3.79760, &
      3.86120,  3.92480,  3.98850,  4.05210,  4.11580, &
      4.33930,  4.38960,  4.43990,  4.47010,  4.50290, &
      4.53500,  4.56640,  4.59700,  4.62700,  4.65630, &
      4.68490,  4.71300,  4.74040,  4.76730,  4.79360, &
      4.81950,  4.84480,  4.87000,  4.89420,  4.91820, &
      4.94230,  4.96530,  4.98820,  5.01090,  5.03330, &
      5.05530,  5.07720,  5.09900,  5.12060,  5.14220, &
      5.16380,  5.18480,  5.20610,  5.22700,  5.24810, &
      5.26980,  5.29070,  5.31220,  5.33380,  5.35600, &
      5.37760,  5.39990,  5.42240,  5.42240,  5.42380, &
      5.42510,  5.42650,  9.91450,  9.99420, 10.07220, &
     10.14850, 10.22330, 10.29640, 10.36790, 10.43780, &
     10.50620, 10.57310, 10.63850, 10.70230, 10.76470, &
     10.82570, 10.88520, 10.94340, 11.00010, 11.05550, &
     11.10950, 11.16230, 11.21370, 11.26390, 11.31270, &
     11.36040, 11.40690, 11.45210, 11.49620, 11.53910, &
     11.58090, 11.62160, 11.66120, 11.69980, 11.73730, &
     11.77370, 11.80920, 11.84370, 11.87720, 11.94140, &
     11.97220, 12.00010, 12.03110, 12.05930, 12.08670, &
     12.11330, 12.13910, 12.70370, 12.72890, 12.75300, &
     12.77600, 12.79800, 12.81880, 12.83870, 12.85740, &
     12.87510, 12.89170, 12.90720, 12.92170, 12.94740, &
     12.95860, 12.96880, 12.97790, 12.98590, 12.99290, &
     12.99880, 13.00360, 13.00740, 13.01000, 13.01170, &
     13.01220 /)

   real(rs), parameter, dimension(nlayers) ::  vpm = (/ &
     5.8000,  5.8000,  6.5000,  6.5000,  8.0400,  8.0450,  8.0500, &
     8.1750,  8.3000,  8.3000,  8.4825,  8.6650,  8.8475,  9.0300, &
     9.3600,  9.5280,  9.6960,  9.8640, 10.0320, 10.2000, 10.7900, &
    10.9229, 11.0558, 11.1353, 11.2221, 11.3068, 11.3896, 11.4705, &
    11.5495, 11.6269, 11.7026, 11.7766, 11.8491, 11.9200, 11.9895, &
    12.0577, 12.1245, 12.1912, 12.2550, 12.3185, 12.3819, 12.4426, &
    12.5031, 12.5631, 12.6221, 12.6804, 12.7382, 12.7956, 12.8526, &
    12.9096, 12.9668, 13.0222, 13.0783, 13.1336, 13.1894, 13.2465, &
    13.3018, 13.3585, 13.4156, 13.4741, 13.5312, 13.5900, 13.6494, &
    13.6494, 13.6530, 13.6566, 13.6602,  8.0000,  8.0382,  8.1283, &
     8.2213,  8.3122,  8.4001,  8.4861,  8.5692,  8.6496,  8.7283, &
     8.8036,  8.8761,  8.9461,  9.0138,  9.0792,  9.1426,  9.2042, &
     9.2634,  9.3205,  9.3760,  9.4297,  9.4814,  9.5306,  9.5777, &
     9.6232,  9.6673,  9.7100,  9.7513,  9.7914,  9.8304,  9.8682, &
     9.9051,  9.9410,  9.9761, 10.0103, 10.0439, 10.0768, 10.1415, &
    10.1739, 10.2049, 10.2329, 10.2565, 10.2745, 10.2854, 10.2890, &
    11.0427, 11.0585, 11.0718, 11.0850, 11.0983, 11.1166, 11.1316, &
    11.1457, 11.1590, 11.1715, 11.1832, 11.1941, 11.2134, 11.2219, &
    11.2295, 11.2364, 11.2424, 11.2477, 11.2521, 11.2557, 11.2586, &
    11.2606, 11.2618, 11.2622 /)

   real(rs), parameter, dimension(nlayers) :: vsm = (/ &
     3.4600,  3.4600,  3.8500,  3.8500,  4.4800,  4.4900,  4.5000, &
     4.5090,  4.5180,  4.5230,  4.6090,  4.6960,  4.7830,  4.8700, &
     5.0800,  5.1860,  5.2920,  5.3980,  5.5040,  5.6100,  5.9600, &
     6.0897,  6.2095,  6.2426,  6.2798,  6.3160,  6.3512,  6.3854, &
     6.4187,  6.4510,  6.4828,  6.5138,  6.5439,  6.5727,  6.6008, &
     6.6285,  6.6555,  6.6815,  6.7073,  6.7326,  6.7573,  6.7815, &
     6.8052,  6.8286,  6.8515,  6.8742,  6.8972,  6.9194,  6.9418, &
     6.9627,  6.9855,  7.0063,  7.0281,  7.0500,  7.0720,  7.0931, &
     7.1144,  7.1369,  7.1586,  7.1807,  7.2031,  7.2258,  7.2490, &
     7.2490,  7.2597,  7.2704,  7.2811,  0.0000,  0.0000,  0.0000, &
     0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
     0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
     0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
     0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
     0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
     0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
     3.5043,  3.5187,  3.5314,  3.5435,  3.5551,  3.5661,  3.5765, &
     3.5864,  3.5957,  3.6044,  3.6126,  3.6202,  3.6337,  3.6396, &
     3.6450,  3.6498,  3.6540,  3.6577,  3.6608,  3.6633,  3.6653, &
     3.6667,  3.6675,  3.6678 /)

!  Ensure depth is in km and not too large
   if (depth > 6371.0) then
      write(0,'(a,f9.1,a)') '  ak135: depth ',depth,' is too large.'
      stop
   else if (depth < 0.) then
      write(0,'(a)') '  ak135: Depth cannot be negative.'
      stop
   endif

!  Look for the specific point first
   do i=1,136
      if (depth == dep(i)) then
         if (present(rho)) rho = den(i)
         if (present(vp)) vp = vpm(i)
         if (present(vs)) vs = vsm(i)
         twodepths = .false.
         exit
      else
!  Otherwise, find the points above and below this depth
         if (depth > dep(i) .and. depth < dep(i+1)) then
            dep1 = dep(i);    dep2 = dep(i+1)
            if (present(rho)) then
               den1 = den(i); den2 = den(i+1)
            endif
            if (present(vp)) then
               vp1 = vpm(i);  vp2 = vpm(i+1)
            endif
            if (present(vs)) then
               vs1 = vsm(i);  vs2 = vsm(i+1)
            endif
            twodepths = .true.
            exit
         endif
      endif
   enddo

   if (twodepths) then
!  Extrapolate linearly to find density
      if (present(rho)) rho = den1 + (depth-dep1)*(den2-den1)/(dep2-dep1)
      if (present(vp))   vp = vp1  + (depth-dep1)*(vp2-vp1) / (dep2-dep1)
      if (present(vs))   vs = vs1  + (depth-dep1)*(vs2-vs1) / (dep2-dep1)
   endif

   return
   end subroutine ak135
!-------------------------------------------------------------------------------

!===============================================================================
subroutine prem_old(depth,vp,vs,rho)
!===============================================================================
!  AK135 model

   real(rs),intent(in) :: depth
   real(rs),intent(out),optional :: vp,vs,rho
   integer, parameter :: nlayers = 88
   real(rs) :: den1,den2,vp1,vp2,vs1,vs2,dep1,dep2
   integer :: i
   logical :: twodepths

   real(rs), parameter, dimension(nlayers) :: dep = (/ &
         0.0,    15.0,    15.0,    24.4,    24.4,    40.0,    60.0, &
        80.0,   115.0,   150.0,   185.0,   220.0,   220.0,   265.0, &
       310.0,   355.0,   400.0,   400.0,   450.0,   500.0,   550.0, &
       600.0,   635.0,   670.0,   670.0,   721.0,   771.0,   871.0, &
       971.0,  1071.0,  1171.0,  1271.0,  1371.0,  1471.0,  1571.0, &
      1671.0,  1771.0,  1871.0,  1971.0,  2071.0,  2171.0,  2271.0, &
      2371.0,  2471.0,  2571.0,  2671.0,  2741.0,  2771.0,  2871.0, &
      2891.0,  2891.0,  2971.0,  3071.0,  3171.0,  3271.0,  3371.0, &
      3471.0,  3571.0,  3671.0,  3771.0,  3871.0,  3971.0,  4017.0, &
      4171.0,  4271.0,  4371.0,  4471.0,  4571.0,  4671.0,  4771.0, &
      4871.0,  4971.0,  5071.0,  5149.5,  5149.5,  5171.0,  5271.0, &
      5371.0,  5471.0,  5571.0,  5671.0,  5771.0,  5871.0,  5971.0, &
      6071.0,  6171.0,  6271.0,  6371.0 /)

   real(rs), parameter, dimension(nlayers) :: den = (/ &
      2.6000,  2.6000,  2.9000,  2.9000,  3.3808,  3.3791,  3.3769, &
      3.3747,  3.3709,  3.3671,  3.3633,  3.3595,  3.4358,  3.4626, &
      3.4895,  3.5164,  3.5433,  3.7238,  3.7868,  3.8498,  3.9128, &
      3.9758,  3.9840,  3.9921,  4.3807,  4.4124,  4.4432,  4.5037, &
      4.5631,  4.6213,  4.6784,  4.7346,  4.7898,  4.8442,  4.8978, &
      4.9507,  5.0030,  5.0547,  5.1059,  5.1567,  5.2071,  5.2573, &
      5.3072,  5.3571,  5.4068,  5.4566,  5.4915,  5.5064,  5.5564, &
      5.5664,  9.9035, 10.0294, 10.1813, 10.3273, 10.4673, 10.6015, &
      10.7301, 10.8532, 10.9709, 11.0833, 11.1907, 11.2930, 11.3904, &
      11.4831, 11.5712, 11.6548, 11.7340, 11.8090, 11.8799, 11.9468, &
      12.0099, 12.0692, 12.1250, 12.1663, 12.7636, 12.7749, 12.8250, &
      12.8707, 12.9121, 12.9491, 12.9818, 13.0101, 13.0340, 13.0536, &
      13.0689, 13.0798, 13.0863, 13.0885 /)

   real(rs), parameter, dimension(nlayers) :: vpm = (/ &
      5.8000,  5.8000,  6.8000,  6.8000,  8.1106,  8.1012,  8.0891, &
      8.0769,  8.0554,  8.0337,  8.0118,  7.9897,  8.5590,  8.6455, &
      8.7321,  8.8187,  8.9052,  9.1340,  9.3899,  9.6459,  9.9018, &
      10.1578, 10.2120, 10.2662, 10.7513, 10.9101, 11.0656, 11.2449, &
      11.4156, 11.5783, 11.7336, 11.8821, 12.0244, 12.1613, 12.2932, &
      12.4207, 12.5447, 12.6655, 12.7839, 12.9004, 13.0158, 13.1305, &
      13.2453, 13.3607, 13.4774, 13.5960, 13.6804, 13.6875, 13.7117, &
      13.7166,  8.0648,  8.1994,  8.3602,  8.5130,  8.6580,  8.7957, &
      8.9263,  9.0502,  9.1675,  9.2787,  9.3842,  9.4841,  9.5788, &
      9.6686,  9.7539,  9.8350,  9.9121,  9.9855, 10.0557, 10.1229, &
      10.1874, 10.2496, 10.3097, 10.3557, 11.0283, 11.0364, 11.0725, &
      11.1054, 11.1352, 11.1619, 11.1854, 11.2058, 11.2230, 11.2371, &
      11.2481, 11.2559, 11.2606, 11.2622 /)

   real(rs), parameter, dimension(nlayers) :: vsm = (/ &
      3.2000,  3.2000,  3.9000,  3.9000,  4.4909,  4.4849,  4.4771, &
      4.4695,  4.4564,  4.4436,  4.4311,  4.4188,  4.6439,  4.6754, &
      4.7069,  4.7384,  4.7699,  4.9326,  5.0784,  5.2243,  5.3701, &
      5.5160,  5.5431,  5.5702,  5.9451,  6.0942,  6.2405,  6.3109, &
      6.3781,  6.4423,  6.5037,  6.5625,  6.6189,  6.6732,  6.7255, &
      6.7761,  6.8251,  6.8729,  6.9196,  6.9654,  7.0105,  7.0553, &
      7.0997,  7.1442,  7.1889,  7.2340,  7.2660,  7.2657,  7.2649, &
      7.2647,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
      0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
      0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000, &
      0.0000,  0.0000,  0.0000,  0.0000,  3.5043,  3.5100,  3.5352, &
      3.5582,  3.5791,  3.5977,  3.6141,  3.6284,  3.6404,  3.6503, &
      3.6579,  3.6634,  3.6667,  3.6678 /)

!  Ensure depth is in km and not too large
   if (depth > 6371.0) then
      write(0,'(a,f9.1,a)') '  PREM: depth ',depth,' is too large.'
      stop
   else if (depth < 0.) then
      write(0,'(a)') '  PREM: Depth cannot be negative.'
      stop
   endif

!  Look for the specific point first
   do i=1,88
      if (depth == dep(i)) then
         if (present(rho)) rho = den(i)
         if (present(vp)) vp = vpm(i)
         if (present(vs)) vs = vsm(i)
         twodepths = .false.
         exit
      else
!  Otherwise, find the points above and below this depth
         if (depth > dep(i) .and. depth < dep(i+1)) then
            dep1 = dep(i);    dep2 = dep(i+1)
            if (present(rho)) then
               den1 = den(i); den2 = den(i+1)
            endif
            if (present(vp)) then
               vp1 = vpm(i);  vp2 = vpm(i+1)
            endif
            if (present(vs)) then
               vs1 = vsm(i);  vs2 = vsm(i+1)
            endif
            twodepths = .true.
            exit
         endif
      endif
   enddo

   if (twodepths) then
!  Extrapolate linearly to find density
      if (present(rho)) rho = den1 + (depth-dep1)*(den2-den1)/(dep2-dep1)
      if (present(vp))   vp = vp1  + (depth-dep1)*(vp2-vp1) / (dep2-dep1)
      if (present(vs))   vs = vs1  + (depth-dep1)*(vs2-vs1) / (dep2-dep1)
   endif

   return
   end subroutine prem_old
!-------------------------------------------------------------------------------

!===============================================================================
subroutine prem(depth,vp,vs,rho,Qmu,Qkappa,vpv,vph,vsv,vsh,eta,g)
!===============================================================================
! PREM model
! Dziewonski & Anderson, 1981, Preliminary reference Earth model, PEPI, 25,
! 297--356.
! Parameterised in terms of normalised radius x = r/a, a = 6371 km
! Output vp and vs are isotropic equivalent velocities; use v{p,s}{v,h} to get
! the true model anisotropic output.
   integer, parameter :: nlayers = 13
   real(rs), intent(in) :: depth
   real(rs), intent(out), optional :: vp, vs, rho, Qmu, Qkappa, vpv, vph, vsv, &
                                      vsh, eta, g
   real(rs), dimension(nlayers), parameter :: &
      r    = (/1221.5, 3480.0, 3630.0, 5600.0, 5701.0, 5771.0, 5971.0, 6151.0, &
               6291.0, 6346.0, 6356.0, 6368.0, 6371.0/), &
      rho0 = (/13.0885, 12.5815,  7.9565,  7.9565,  7.9565,  5.3197, 11.2494, &
                7.1089,  2.6910,  2.6910,  2.9000,  2.6000,  1.0200/), &
      rho1 = (/ 0.0000, -1.2638, -6.4761, -6.4761, -6.4761, -1.4836, -8.0298, &
               -3.8045,  0.6924,  0.6924,  0.0000,  0.0000,  0.0000/), &
      rho2 = (/-8.8381, -3.6426,  5.5283,  5.5283,  5.5283,  0.0000,  0.0000, &
                0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000/), &
      rho3 = (/ 0.0000, -5.5281, -3.0807, -3.0807, -3.0807,  0.0000,  0.0000, &
                0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000/), &
      vp0  = (/11.2622, 11.0487, 15.3891, 24.9520, 29.2766, 19.0957, 39.7027, &
               20.3926,  4.1875,  4.1875,  6.8000,  5.8000,  1.4500/), &
      vp1 =  (/ 0.0000, -4.0362, -5.3181,-40.4673,-23.6027, -9.8672,-32.6166, &
              -12.2569,  3.9382,  3.9382,  0.0000,  0.0000,  0.0000/), &
      vp2 =  (/-6.3640,  4.8023,  5.5242, 51.4832,  5.5242,  0.0000,  0.0000, &
                0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000/), &
      vp3 =  (/ 0.0000,-13.5732, -2.5514,-26.6419, -2.5514,  0.0000,  0.0000, &
                0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000/), &
      vs0 =  (/ 3.6678,  0.0000,  6.9254, 11.1671, 22.3459,  9.9839, 22.3512, &
                8.9496,  2.1518,  2.1519,  3.9000,  3.2000,  0.0000/), &
      vs1 =  (/ 0.0000,  0.0000,  1.4672,-13.7818,-17.2473, -4.9324,-18.5956, &
               -4.4597,  2.3481,  2.3481,  0.0000,  0.0000,  0.0000/), &
      vs2 =  (/-4.4475,  0.0000, -2.0834, 17.4575, -2.0834,  0.0000,  0.0000, &
                0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000/), &
      vs3 =  (/ 0.0000,  0.0000,  0.9783, -9.2777,  0.9783,  0.0000,  0.0000, &
                0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000/), &
      vpv0 = (/11.2622, 11.0487, 15.3891, 24.9520, 29.2766, 19.0957, 39.7027, &
               20.3926,  0.8317,  0.8317,  6.8000,  5.8000,  1.4500/), &
      vpv1 = (/ 0.0000, -4.0362, -5.3181,-40.4673,-23.6027, -9.8672,-32.6166, &
              -12.2569,  7.2180,  7.2180,  0.0000,  0.0000,  0.0000/), &
      vph0 = (/11.2622, 11.0487, 15.3891, 24.9520, 29.2766, 19.0957, 39.7027, &
               20.3926,  3.5908,  3.5908,  6.8000,  5.8000,  1.4500/), &
      vph1 = (/ 0.0000, -4.0362, -5.3181,-40.4673,-23.6027, -9.8672,-32.6166, &
              -12.2569,  4.6172,  4.6172,  0.0000,  0.0000,  0.0000/), &
      vsv0 = (/ 3.6678,  0.0000,  6.9254, 11.1671, 22.3459,  9.9839, 22.3512, &
                8.9496,  5.8582,  5.8582,  3.9000,  3.2000,  0.0000/), &
      vsv1 = (/ 0.0000,  0.0000,  1.4672,-13.7818,-17.2473, -4.9324,-18.5956, &
               -4.4597, -1.4678, -1.4678,  0.0000,  0.0000,  0.0000/), &
      vsh0 = (/ 3.6678,  0.0000,  6.9254, 11.1671, 22.3459,  9.9839, 22.3512, &
                8.9496, -1.0839, -1.0839,  3.9000,  3.2000,  0.0000/), &
      vsh1 = (/ 0.0000,  0.0000,  1.4672,-13.7818,-17.2473, -4.9324,-18.5956, &
               -4.4597,  5.7176,  5.7176,  0.0000,  0.0000,  0.0000/), &
      Qmu_model =  (/84.6, -1., 312., 312., 312., 143., 143., 143., 80., 600., &
                     600., 600., -1./), &
      Qkappa_model = (/1327.7, 57823., 57823., 57823., 57823., 57823., 57823., &
                       57823., 57823., 57823., 57823., 57823., 57823./), &
      eta0 = (/1., 1., 1., 1., 1., 1., 1., 1., 3.3687, 3.3687, 1., 1., 1./), &
      eta1 = (/1., 1., 1., 1., 1., 1., 1., 1.,-2.4778,-2.4778, 1., 1., 1./)
   real(rs), parameter :: a = r(nlayers)
   real(rs), parameter, dimension(nlayers) :: rho0SI = rho0*1.e3, rho1SI = rho1/a, &
                          rho2SI = rho2*1.e-3/a**2, rho3SI = rho3*1.e-6/a**3
   real(rs) :: x, x0, M, r0, r1
   integer :: i, j

   if (depth > a) then
      write(0,'(a,f9.1,a)') '  PREM: depth ',depth,' is too large.'
      stop
   else if (depth < 0.) then
      write(0,'(a)') '  PREM: Depth cannot be negative.'
      stop
   endif

   x = (a - depth)/a
   i = 1
   do while(i < nlayers)
      if (x < r(i)/a) exit
      i = i + 1
   enddo

   if (present(rho)) rho = rho0(i) + rho1(i)*x + rho2(i)*x**2 + rho3(i)*x**3
   if (present(vp)) vp = vp0(i) + vp1(i)*x + vp2(i)*x**2 + vp3(i)*x**3
   if (present(vs)) vs = vs0(i) + vs1(i)*x + vs2(i)*x**2 + vs3(i)*x**3
   if (present(Qmu)) Qmu = Qmu_model(i)
   if (present(Qkappa)) Qkappa = Qkappa_model(i)
   ! Note for v{p,s}{v,h}, differences are only in x^0 and x^1, so we intentionally
   ! use v{p,s}{2,3}(i)
   if (present(vpv)) vpv = vpv0(i) + vpv1(i)*x + vp2(i)*x**2 + vp3(i)*x**3
   if (present(vph)) vph = vph0(i) + vph1(i)*x + vp2(i)*x**2 + vp3(i)*x**3
   if (present(vsv)) vsv = vsv0(i) + vsv1(i)*x + vs2(i)*x**2 + vs3(i)*x**3
   if (present(vsh)) vsh = vsh0(i) + vsh1(i)*x + vs2(i)*x**2 + vs3(i)*x**3
   if (present(eta)) eta = eta0(i) + eta1(i)*x

   ! Calculate gravity by integrating the density upwards
   if (present(g)) then
      M = 0._rs
      do j = 1, i
         if (j == 1) then
            r0 = 0._rs
         else
            r0 = r(j-1)*1.e3
         endif
         if (j < i) then
            r1 = r(j)*1.e3
         else
            r1 = (a - depth)*1.e3
         endif
         M = M + rho0SI(j)*(r1**3 - r0**3)/3._rs + rho1SI(j)*(r1**4 - r0**4)/4._rs + &
                 rho2SI(j)*(r1**5 - r0**5)/5._rs + rho3SI(j)*(r1**6 - r0**6)/6._rs
      enddo
      if (r1 < epsilon(r1)) then
         g = 0._rs
      else
         g = bigG*(4._rs*pi*M)/r1**2
      endif
   endif

end subroutine prem
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
end module global_1d_models


!=============================================================================!
        subroutine eigdrv3d()
!
!  Driver for eigenvalue problem (LAPack)
!
!=============================================================================!
        use global
        use local2d
        use local3d
        implicit none
!=============================================================================!
        complex :: v(ndof,nx,ny)
        complex :: matx(5,ndof,ndof,nx,ny)
        complex :: mat(ndof,nx,ndof,nx)
        real :: dtl(nx,ny)

!.... LAPack variables

        integer :: lwork, info
        real, allocatable :: rwork(:)
        complex, allocatable :: work(:)
        complex :: eval(ndof*nx), evec(ndof,nx,ndof*nx)

        integer :: i, j, idof, jdof
        character*80 :: name, code='EigDrv$'
!=============================================================================!

        dtl = one

        call lhs1f3D( matx, Ah, Dh, Dhi, Vh11, ABhi, dtl, v )

!.... Remove identity matrix

        do j = 1, ny
          do i = 1, nx
            do idof = 1, ndof
              matx(3,idof,idof,i,j) = matx(3,idof,idof,i,j) - one
            end do
          end do
        end do

!.... Convert to LAPack general matrix storage

        j = 1

        i = 1
        do idof = 1, ndof
          do jdof = 1, ndof
            mat(idof,i,jdof,nx-2) = matx(1,idof,jdof,i,j)
            mat(idof,i,jdof,nx-1) = matx(2,idof,jdof,i,j)
            mat(idof,i,jdof,i  )  = matx(3,idof,jdof,i,j)
            mat(idof,i,jdof,i+1)  = matx(4,idof,jdof,i,j)
            mat(idof,i,jdof,i+2)  = matx(5,idof,jdof,i,j)
          end do
        end do

        i = 2
        do idof = 1, ndof
          do jdof = 1, ndof
            mat(idof,i,jdof,nx-1) = matx(1,idof,jdof,i,j)
            mat(idof,i,jdof,i-1)  = matx(2,idof,jdof,i,j)
            mat(idof,i,jdof,i  )  = matx(3,idof,jdof,i,j)
            mat(idof,i,jdof,i+1)  = matx(4,idof,jdof,i,j)
            mat(idof,i,jdof,i+2)  = matx(5,idof,jdof,i,j)
          end do
        end do

        do i = 3, nx-2
          do idof = 1, ndof
            do jdof = 1, ndof
              mat(idof,i,jdof,i-2) = matx(1,idof,jdof,i,j)
              mat(idof,i,jdof,i-1) = matx(2,idof,jdof,i,j)
              mat(idof,i,jdof,i  ) = matx(3,idof,jdof,i,j)
              mat(idof,i,jdof,i+1) = matx(4,idof,jdof,i,j)
              mat(idof,i,jdof,i+2) = matx(5,idof,jdof,i,j)
            end do
          end do
        end do

        i = nx-1
        do idof = 1, ndof
          do jdof = 1, ndof
            mat(idof,i,jdof,i-2) = matx(1,idof,jdof,i,j)
            mat(idof,i,jdof,i-1) = matx(2,idof,jdof,i,j)
            mat(idof,i,jdof,i  ) = matx(3,idof,jdof,i,j)
            mat(idof,i,jdof,i+1) = matx(4,idof,jdof,i,j)
            mat(idof,i,jdof,2)   = matx(5,idof,jdof,i,j)
          end do
        end do

        i = nx
        do idof = 1, ndof
          do jdof = 1, ndof
            mat(idof,i,jdof,i-2) = matx(1,idof,jdof,i,j)
            mat(idof,i,jdof,i-1) = matx(2,idof,jdof,i,j)
            mat(idof,i,jdof,i  ) = matx(3,idof,jdof,i,j)
            mat(idof,i,jdof,2)   = matx(4,idof,jdof,i,j)
            mat(idof,i,jdof,3)   = matx(5,idof,jdof,i,j)
          end do
        end do

        lwork = max(1,3*(ndof*nx))
        allocate( work(lwork), rwork(2*(ndof*nx)) )
        call ZGEGV ( 'N', 'V', ndof*nx, mat, ndof*nx, eval, &
                     evec, ndof*nx, evec, ndof*nx,          &
                     work, lwork, rwork, info )
        deallocate( work, rwork )

!.... Output the eigenvalues and eigenvectors

        open(11,file='eig.dat', form='unformatted', status='unknown')
        write(11) ndof*nx, 0.0, nx, 1, nz, ndof, &
             Re, Ma, Pr, gamma, cv
        write(11) eval
        write(11) evec
        close(11)

        end subroutine eigdrv3d


      SUBROUTINE BALGEN (N,MA,A,MB,B,LOW,IGH,CSCALE,CPERM,WK)
CSE
C
CPS        PURPOSE:
C
C             BALANCES THE MATRICES A AND B FOR COMPUTATION
C             BY QZ-TYPE ALGORITHMS OF THE EIGENSYSTEM OF THE
C             GENERALIZED EIGENVALUE PROBLEM A*X = (LAMBDA)*B*X .
C
CPE
CAS             ***  ARGUMENT LIST  ***
C
C  INPUT PARAMETERS:
C
C  N - THE ORDER OF THE MATRICES A AND B;
C
C  MA - THE ROW (FIRST) DIMENSION OF THE ARRAY A AS SPECIFIED
C       IN THE CALLING PROGRAM;
C
C  A - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MA AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX A AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE;
C
C  MB - THE ROW (FIRST) DIMENSION OF THE ARRAY B AS SPECIFIED IN
C       THE CALLING PROGRAM;
C
C  B - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MB AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX B AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE;
C
C  WK - AN ARRAY OF ANY DIMENSION THAT MUST BE PROVIDED BY THE
C       USER FOR WORK SPACE. WK MUST CONTAIN AT LEAST 6*N STORAGE
C       LOCATIONS.
C
C  OUTPUT PARAMETERS:
C
C  A - CONTAINS THE BALANCED A MATRIX;
C
C  B - CONTAINS THE BALANCED B MATRIX;
C
C  LOW - THE INTEGER SPECIFYING THE BEGINNING INDEX OF THE SUBMATRICES
C        OF A AND B CONTAINING THE NON-ISOLATED EIGENVALUES;
C
C  IGH - THE INTEGER SPECIFYING THE ENDING INDEX OF THE SUBMATRICES
C        OF A AND B CONTAINING THE NON-ISOLATED EIGENVALUES. IF
C        IGH=1 (THEN LOW MUST BE 1 ALSO), THE A AND B MATRICES
C        HAVE BEEN PERMUTED INTO UPPER TRIANGULAR FORM AND HAVE
C        NOT BEEN BALANCED;
C
C  CSCALE - THE REAL ARRAY OF DIMENSION AT LEAST N CONTAINING THE
C           EXPONENTS OF THE COLUMN SCALING FACTORS IN ITS LOW THROUGH
C           IGH LOCATIONS AND THE REDUCING COLUMN PERMUTATIONS IN ITS
C           FIRST LOW-1 AND ITS IGH+1 THROUGH N LOCATIONS;
C
C  CPERM - THE REAL ARRAY OF DIMENSION AT LEAST N CONTAINING IN
C          ITS LOW THROUGH IGH LOCATIONS THE COLUMN PERMUTATIONS
C          APPLIED IN GRADING THE A AND B SUBMATRICES;
C
C  WK - CONTAINS THE EXPONENTS OF THE ROW SCALING FACTORS IN ITS
C       LOW THROUGH IGH LOCATIONS, THE REDUCING ROW PERMUTATIONS
C       IN ITS FIRST LOW-1 AND ITS IGH+1 THROUGH N LOCATIONS, AND
C       THE ROW PERMUTATIONS APPLIED IN GRADING THE A AND B SUBMATRICES
C       IN ITS N+LOW THROUGH N+IGH LOCATIONS.
C
CAE
C  REQUIRED SUBPROGRAMS - REDUCE,SCALEG,GRADEQ
C
C  REQUIRED FUNCTIONS - NONE
C
C  REFERENCE - R.C. WARD, BALANCING THE GENERALIZED EIGENVALUE
C              PROBLEM, TECHNICAL REPORT ORNL/CSD-47, OAK RIDGE,
C              TENNESSEE, 1979.
C
C              [SAME TITLE] SIAM J. SCI. STAT. COMPUT., VOL 2,
C                           NO 2, JUNE 1981, PP 141-152.
C
C ****
C
      DIMENSION A(MA,N),B(MB,N),CSCALE(N),CPERM(N),WK(N,6)
      DOUBLE PRECISION A,B,CSCALE,CPERM,WK
      CALL REDUCE (N,MA,A,MB,B,LOW,IGH,CSCALE,WK)
      IF (LOW .EQ. IGH) GO TO 5
      CALL SCALEG (N,MA,A,MB,B,LOW,IGH,CSCALE,CPERM,WK)
      CALL GRADEQ (N,MA,A,MB,B,LOW,IGH,CPERM,WK(1,2))
    5 CONTINUE
      RETURN
      END


      subroutine drdiv(a,ia,b,ib,r,ir,n,ierr)
c!    purpose
c     computes r=a./b with a and b real
c
c     ia,ib,ir : increment between two consecutive element of vectors a
c                b and r
c     n        : vectors length
c     ierr     : returned error flag:
c                o   : ok
c                <>0 : b(ierr)=0
c!
c     Copyright INRIA
      double precision a(*),b(*),r(*)
      integer ia,ib,ir,n
      jr=1
      jb=1
      ja=1
      k=0
      ierr=0
      if (ia.eq.0) then
         do 10 k=1,n
            if(b(jb).eq.0.0d0) then
               ierr=k
               return
            endif
            r(jr)=a(ja)/b(jb)
            jr=jr+ir
            jb=jb+ib
 10      continue
      elseif(ib.eq.0) then
         if(b(jb).eq.0.0d0) then
            ierr=1
            return
         endif
         do 11 k=1,n
            r(jr)=a(ja)/b(jb)
            jr=jr+ir
            ja=ja+ia
 11      continue
      else
         do 12 k=1,n
            if(b(jb).eq.0.0d0) then
               ierr=k
               return
            endif
            r(jr)=a(ja)/b(jb)
            jr=jr+ir
            jb=jb+ib
            ja=ja+ia
 12      continue
      endif
      end


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Driver for the tangent linear model (TLM)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

PROGRAM KPP_ROOT_TLM_Driver

  USE KPP_ROOT_Model
  USE KPP_ROOT_Initialize, ONLY: Initialize

      KPP_REAL :: T, DVAL(NSPEC)
      INTEGER :: i, j, ind_1 = 1, ind_2 = 2
      ! INTEGER :: ind_1 = ind_NO2, ind_2 = ind_O3

! ---  Number of sensitivity coefficients to compute
! ---  Note: this value is set for sensitivities w.r.t. all initial values
! ---       it may have to be changed for other applications
      INTEGER NTLM
      PARAMETER (NTLM = 2)
      KPP_REAL  Y_TLM(NVAR,NTLM)

! ---- TIME VARIABLES ------------------

      STEPMIN = 0.0d0
      STEPMAX = 0.0d0

      DO i=1,NVAR
        RTOL(i) = 1.0d-4
        ATOL(i) = 1.0d-2
      END DO

      CALL Initialize()
!~~~> Note: the initial values below are for sensitivities
!           w.r.t. initial values;
!           they have to be changed for other applications
      DO j=1,NTLM
        DO i=1,NVAR
           Y_TLM(i,j) = 0.0d0
        END DO
      END DO
      Y_TLM(ind_1,1) = 1.0d0
      Y_TLM(ind_2,2) = 1.0d0

! ~~~~~~~~~ BEGIN TIME LOOP ~~~~~~~~~~

      CALL InitSaveData()

      T = TSTART

kron: DO WHILE (T < TEND)

        CALL GetMass( C, DVAL )
        WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T,      &
                    (TRIM(SPC_NAMES(MONITOR(i))),          &
                      C(MONITOR(i))/CFACTOR, i=1,NMONITOR),&
                    (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS)

        CALL SaveData()

        CALL INTEGRATE_TLM( NTLM, VAR, Y_TLM, T, T+DT )

        T = T+DT

      END DO kron

      CALL GetMass( C, DVAL )
      WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T,        &
                  (TRIM(SPC_NAMES(MONITOR(i))),            &
                    C(MONITOR(i))/CFACTOR, i=1,NMONITOR),  &
                  (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS)

      CALL SaveData()

! ~~~~~~~~~ END TIME LOOP ~~~~~~~~~~

      OPEN(20, FILE='KPP_ROOT_TLM_results.m')
      WRITE(6,*) '**************************************************'
      WRITE(6,*) ' Concentrations and Sensitivities at final time '
      WRITE(6,*) ' were written in the file KPP_ROOT_TLM_results.m'
      WRITE(6,*) '**************************************************'
      DO j=1,NTLM
        WRITE(20,993) ( Y_TLM(i,j), i=1,NVAR )
      END DO

      CALL CloseSaveData()

      WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_1)), &
                   Y_TLM(ind_1,1)
      WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_2)), &
                   Y_TLM(ind_2,2)
      WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_2)), &
                   Y_TLM(ind_2,1)
      WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_1)), &
                   Y_TLM(ind_1,2)

 991  FORMAT(F6.1,'%. T=',E10.3,3X,20(A,'=',E10.4,';',1X))
 993  FORMAT(1000(E24.16,2X))
 995  FORMAT('TLM: d[',A,'](tf)/d[',A,'](t0)=',E14.7)

END PROGRAM KPP_ROOT_TLM_Driver


*     AB13MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 10, MMAX = 10 )
      INTEGER          LDZ
      PARAMETER        ( LDZ = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 4*MMAX-2, NMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 2*NMAX*NMAX*MMAX - NMAX*NMAX +
     $                            9*MMAX*MMAX + NMAX*MMAX + 11*NMAX +
     $                            33*MMAX - 11 )
      INTEGER          LZWORK
      PARAMETER        ( LZWORK = 6*NMAX*NMAX*MMAX + 12*NMAX*NMAX +
     $                            6*MMAX + 6*NMAX - 3 )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, M, N
      DOUBLE PRECISION BOUND
*     .. Local Arrays ..
      INTEGER          ITYPE(MMAX), IWORK(LIWORK), NBLOCK(MMAX)
      DOUBLE PRECISION D(NMAX), DWORK(LDWORK), G(NMAX), X(2*MMAX-1)
      COMPLEX*16       Z(LDZ,NMAX), ZWORK(LZWORK)
*     .. External Subroutines ..
      EXTERNAL         AB13MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE
         READ ( NIN, FMT = * ) ( NBLOCK(I), I = 1, M )
         READ ( NIN, FMT = * ) ( ITYPE(I), I = 1, M )
         READ ( NIN, FMT = * ) ( ( Z(I,J), J = 1,N ), I = 1,N )
*        Computing mu.
         CALL AB13MD( 'N', N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, G,
     $               IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO )
*
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99991 ) BOUND
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB13MD =',I2)
99997 FORMAT (' The value of the structured singular value is'/)
99991 FORMAT (D17.10)
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
      END


SUBROUTINE DVBES1(FJ,DJ,SM,RI,NT)
  !-----X----X----X----X----X----X----X----X----X----X----X----X----X----X
  !-----X CALCULATE THE DERIVATIVES OF THE BESSEL FUNCTIONS.   X----X----X
  !-----X   DJ=DFJ/DX WHERE X=SM*RI                                 X----X
  !-----X                    D.D.KOELLING                      X----X----X
  !-----X----X----X----X----X----X----X----X----X----X----X----X----X----X
  IMPLICIT REAL*8 (A-H,O-Z)
  DIMENSION DJ(*),FJ(*)
  DATA ZUP/1.0D-5/,ZERO/0.0D0/,THIRD/0.3333333333333D0/,ONE/1.0D0/
  X=SM
  IF(X.GT.ZUP) GOTO 20
  DJ(1)=ZERO
  DJ(2)=THIRD
  DO L=3,NT
     DJ(L)=ZERO
  ENDDO
  RETURN
20 CONTINUE
  Q2=-ONE/X
  Q3=Q2
  DJ(1)=-FJ(2)
  LM=1
  DO L=2,NT
     Q3=Q3+Q2
     DJ(L)=FJ(LM)+Q3*FJ(L)
     LM=LM+1
  ENDDO
  RETURN
END SUBROUTINE DVBES1


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine maxwell: randomly selected speed from
!              3D-Maxwell-Boltzmann distribution
!
!       literature reference:
!     P. W. Atkins, "Physical Chemistry, 4th Edition", W. H. Freeman,
!     New York, 1990; see section 24.2 for general discussion
!
!     part of EVB
!
function maxwell(mass1,temper)
use general
implicit none
real(kind=8)::maxwell
real(kind=8)::mass1,temper
real(kind=8)::rho,beta
real(kind=8)::random,erfinv
real(kind=8)::xspeed,yspeed
real(kind=8)::zspeed
external::erfinv
!
!
!     set normalization factor for cumulative velocity distribution
!
beta = sqrt(mass1 / (2.0d0*boltzmann*temper))
!
!     pick a randomly distributed velocity along each of three axes
!
rho = random ()
xspeed = erfinv(rho) / beta
rho = random ()
yspeed = erfinv(rho) / beta
rho = random ()
zspeed = erfinv(rho) / beta
!
!     set the final value of the particle speed in 3-dimensions
!
maxwell = sqrt(xspeed**2 + yspeed**2 + zspeed**2)

return
end function maxwell


c test rebinning subroutines

      program testrebin

      parameter (IFCONST=0)
      parameter (nmax=1000)

      real w(nmax),warb(nmax),wlog(nmax)
      real wlin(nmax),wlin2(nmax)
      real flux1(nmax),fluxlog(nmax),fluxlin(nmax)
      real flux2(nmax),flux2log(nmax),flux2lin(nmax)
      real ferr1(nmax),ferrlog(nmax),ferrlin(nmax)
      character toplabel*100

      integer ilines(10)
      real rlinekern(11)

      n=300
      nlog=300
      nlin=400
c      n=100
c      nlog=100
c      nlin=100
      narb=n
      w0=6500
      dw=0.5

c make the log scale cover slightly more than the linear scale
      w0log= log10(w0-10.)
      wlogmax = log10(w0+dw*n+10.)
      dwlog = (wlogmax-w0log)/nlog

      write(*,'(a,4(2x,f11.5))') "w0,dw,w0log,dwlog",w0,dw,w0log,dwlog

      nlines=4
      do j=1,nlines
         ilines(j) = 61*j
      end do
c construct gaussian kernel for lines
      iradkern=4
      nlinekern=2*iradkern+1
      gsigma = 1.1
      do j=1,nlinekern
         rlinekern(j) = 10.* exp(-(iradkern+1-j)**2/2./gsigma**2)
      end do

      do i=1,n
c standard linear wl scale
         w(i) = w0+i*dw
c wl not quite linear
         warb(i) = w(i) + 0.02*(i-1)
      end do
      do i=1,nlog
         wlog(i) = w0log + dwlog*i
      end do

      if (IFCONST .eq. 1) then
c make it all flat
         do i=1,n/2
            flux1(i) =15.
         end do
         do i=n/2+1,n
            flux1(i) =25.
         end do
      else
c constant part
         do i=1,50
            flux1(i) = 15.
         end do
c quadratic increase
         do i=51,150
            flux1(i) = flux1(50) + 0.001*(i-50)**2
         end do
c lin decrease
         do i=151,250
            flux1(i) = flux1(150) - 0.1*(i-150)
         end do
c zero patch
         do i=251,260
            flux1(i)=0.
         end do
c constant w/offset
         do i=261,270
            flux1(i) = flux1(250) + 5.
         end do
c lin increase
         do i=271,300
            flux1(i) = flux1(270) + 0.1*(i-270)
         end do
c add a few lines
         do j=1,nlines
            do ikern=1,nlinekern
               i=ilines(j)+ikern-iradkern-1
               flux1(i) = flux1(i) + rlinekern(ikern)
            end do
         end do
      end if

      rnsq=16.0
      do i=1,n
         ferr1(i) = sqrt(flux1(i) + rnsq)
      end do

      call pgbeg(0,'?',2,2)
      call pgscf(2)
      call pgsch(1.5)

      call showspecerr(n,w,flux1,ferr1)
      call pglabel('linear wavelength','counts','linear original')

      call logrebinerr(flux1,ferr1,n,w0,dw,nlog,w0log,dwlog,
     $     fluxlog,ferrlog)
      call logrebin(flux1,n,w0,dw,nlog,w0log,dwlog,
     $     flux2log)

      call showspecerr(nlog,wlog,fluxlog,ferrlog)
      write(toplabel,700) n,nlog,dw,dwlog
 700  format("log rebin, nlin= ",i4,", nlog= ",i4,
     $     ", dw= ",f4.2,", dwlog= ",f7.5)
      call pglabel('log wavelength','rebinned counts',toplabel)
      call pgsci(2)
      call pgsls(2)
      call pgline(nlog,wlog,flux2log)
      call pgsci(1)
      call pgsls(1)

      call pgpage()
      call pgpage()

      call showspecerr(narb,warb,flux1,ferr1)
      call pglabel('non-linear wavelength','counts',
     $     'non-linear original')

      call linrebinerr(narb,warb,flux1,ferr1,nlin,w0lin,dwlin,
     $     fluxlin,ferrlin)
      call linrebin(narb,warb,flux1,nlin,w0lin2,dwlin2,flux2lin)

      do i=1,nlin
         wlin(i) = w0lin +i*dwlin
         wlin2(i) = w0lin2 + i*dwlin2
      end do
      call showspecerr(nlin,wlin,fluxlin,ferrlin)
      call pglabel('linearized wavelength','rebinned counts',
     $     'linearized rebin of non-linear original')
      call pgsci(2)
      call pgsls(2)
      call pgline(nlin,wlin2,flux2lin)
      call pgsci(1)
      call pgsls(1)

      call logrebinerr(fluxlin,ferrlin,nlin,w0lin,dwlin,nlog,w0log,
     $     dwlog,fluxlog,ferrlog)
      call logrebin(fluxlin,nlin,w0lin2,dwlin2,nlog,w0log,dwlog,
     $     flux2log)

      call showspecerr(nlog,wlog,fluxlog,ferrlog)
      write(toplabel,710) nlin,nlog,dwlin,dwlog
 710  format("log rebin, nlin= ",i4,", nlog= ",i4,
     $     ", dw= ",f4.2,", dwlog= ",f7.5)
      call pglabel('log wavelength','rebinned counts',toplabel)
      call pgsci(2)
      call pgsls(2)
      call pgline(nlog,wlog,flux2log)
      call pgsci(1)
      call pgsls(1)

      call pgend()

      end


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_INIT_CURVED_GEOS

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_COORS
    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_GRID_SYS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_INIT_CURVED_GEOS

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_INIT_CURVED_GEOS( FILE_XMDF_NAME , ERROR , ERRMSG )

    USE MR_MOD_OPERATOR_XUV

    IMPLICIT NONE

    CHARACTER(   *   ) , INTENT(IN ) :: FILE_XMDF_NAME

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    REAL   (XYRD_KIND) ,               DIMENSION(          1:2) , PARAMETER :: FACTOR = (/+1.0,-1.0/)

    INTEGER(IJID_KIND) :: I , J
    INTEGER(IJID_KIND) :: P , Q

    INTEGER            :: DIM

    ALLOCATE( XYUV(1:NI1(NI,XYRD_KIND),1:NJ,1:2) )
    ALLOCATE( XYUU(0:NI0(NI,XYRD_KIND),1:NJ,1:2) , XYVV(1:NI1(NI,XYRD_KIND),0:NJ,1:2) )
    ALLOCATE( XYOO(0:NI0(NI,XYRD_KIND),0:NJ,1:2) )

    CALL MR_INIT_COORS( FILE_XMDF_NAME , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" when initializing curved geometry"
    ELSE

      DO DIM = 1 , 2
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            JUV( I , J ,DIM,1) = XYUU( I , J ,DIM) - XYUU(I-1, J ,DIM)
          END DO
        END DO
      END DO
      DO DIM = 1 , 2
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            JUV( I , J ,DIM,2) = XYVV( I , J ,DIM) - XYVV( I ,J-1,DIM)
          END DO
        END DO
      END DO
      JUV = JUV / XYR
      IF( ALLOCATED(GUV) ) GUV = ( .MRXUVTPS. JUV ) .MRXUVMAT. JUV
      IF( ALLOCATED(MW) ) THEN
        MW = .MRXUVDTM. JUV
        IF( ALLOCATED(IUV) ) THEN
          IUV = MW .MRXUVIVS. JUV
          IF( ALLOCATED(FUV) ) THEN
            FUV = IUV .MRXUVMAT. ( .MRXUVTPS. IUV )
          END IF
        END IF
      END IF

      DO DIM = 1 , 2
        DO J = 1 , NJ
          I = 0
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JUU( I , J ,DIM,1) =   &
            ( ( XYUV(I+1, J ,DIM) - XYUU( I , J ,DIM) )   &
            + ( XYUU( P , Q ,DIM) - XYUV( P , Q ,DIM) ) * FACTOR(DIM)   &
            )
          !END I = 0
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI-1
            JUU( I , J ,DIM,1) = XYUV(I+1, J ,DIM) - XYUV( I , J ,DIM)
          END DO
          I = NI
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JUU( I , J ,DIM,1) =   &
            ( ( XYUV(P+1, Q ,DIM) - XYUU( P , Q ,DIM) ) * FACTOR(DIM)   &
            + ( XYUU( I , J ,DIM) - XYUV( I , J ,DIM) )   &
            )
          !END I = NI
        END DO
      END DO
      DO DIM = 1 , 2
        DO J = 1 , NJ
          I = 0
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JUU( I , J ,DIM,2) =   &
            ( ( XYOO( I , J ,DIM) - XYOO( I ,J-1,DIM) )   &
            + ( XYOO( P ,Q-1,DIM) - XYOO( P , Q ,DIM) ) * FACTOR(DIM)   &
            ) / 2.0
          !END I = 0
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI-1
            JUU( I , J ,DIM,2) = XYOO( I , J ,DIM) - XYOO( I ,J-1,DIM)
          END DO
          I = NI
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JUU( I , J ,DIM,2) =   &
            ( ( XYOO( P ,Q-1,DIM) - XYOO( P , Q ,DIM) ) * FACTOR(DIM)   &
            + ( XYOO( I , J ,DIM) - XYOO( I ,J-1,DIM) )   &
            ) / 2.0
          !END I = NI
        END DO
      END DO
      JUU = JUU / XYR
      IF( ALLOCATED(GUU) ) GUU = ( .MRXUVTPS. JUU ) .MRXUVMAT. JUU
      IF( ALLOCATED(MU) ) THEN
        MU = .MRXUVDTM. JUU
        IF( ALLOCATED(IUU) ) THEN
          IUU = MU .MRXUVIVS. JUU
          IF( ALLOCATED(FUU) ) THEN
            FUU = IUU .MRXUVMAT. ( .MRXUVTPS. IUU )
          END IF
        END IF
      END IF

      DO DIM = 1 , 2
        DO J = 0 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            JVV( I , J ,DIM,1) = XYOO( I , J ,DIM) - XYOO(I-1, J ,DIM)
          END DO
        END DO
      END DO
      DO DIM = 1 , 2
        J = 0
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            JVV( I , J ,DIM,2) = 2.0 * ( XYUV( I ,J+1,DIM) - XYVV( I , J ,DIM) )
          END DO
        !END J = 0
        DO J = 1 , NJ-1
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            JVV( I , J ,DIM,2) = XYUV( I ,J+1,DIM) - XYUV( I , J ,DIM)
          END DO
        END DO
        J = NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            JVV( I , J ,DIM,2) = 2.0 * ( XYVV( I , J ,DIM) - XYUV( I , J ,DIM) )
          END DO
        !END J = NJ
      END DO
      JVV = JVV / XYR
      IF( ALLOCATED(GVV) ) GVV = ( .MRXUVTPS. JVV ) .MRXUVMAT. JVV
      IF( ALLOCATED(MV) ) THEN
        MV = .MRXUVDTM. JVV
        IF( ALLOCATED(IVV) ) THEN
          IVV = MV .MRXUVIVS. JVV
          IF( ALLOCATED(FVV) ) THEN
            FVV = IVV .MRXUVMAT. ( .MRXUVTPS. IVV )
          END IF
        END IF
      END IF

      DO DIM = 1 , 2
        DO J = 0 , NJ
          I = 0
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,1) =   &
            ( ( XYVV(I+1, J ,DIM) - XYOO( I , J ,DIM) )   &
            + ( XYOO( P ,Q-1,DIM) - XYVV( P ,Q-1,DIM) ) * FACTOR(DIM)   &
            )
          !END I = 0
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI-1
            JOO( I , J ,DIM,1) = XYVV(I+1, J ,DIM) - XYVV( I , J ,DIM)
          END DO
          I = NI
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,1) =   &
            ( ( XYVV(P+1,Q-1,DIM) - XYOO( P ,Q-1,DIM) ) * FACTOR(DIM)   &
            + ( XYOO( I , J ,DIM) - XYVV( I , J ,DIM) )   &
            )
          !END I = NI
        END DO
      END DO
      DO DIM = 1 , 2
        J = 0
          I = 0
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,2) =   &
            ( ( XYUU( I ,J+1,DIM) - XYOO( I , J ,DIM) )   &
            + ( XYUU( P ,Q-1,DIM) - XYOO( P ,Q-1,DIM) ) * FACTOR(DIM)   &
            )
          !END I = 0
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI-1
            JOO( I , J ,DIM,2) = 2.0 * ( XYUU( I ,J+1,DIM) - XYOO( I , J ,DIM) )
          END DO
          I = NI
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,2) =   &
            ( ( XYUU( I ,J+1,DIM) - XYOO( I , J ,DIM) )   &
            + ( XYUU( P ,Q-1,DIM) - XYOO( P ,Q-1,DIM) ) * FACTOR(DIM)   &
            )
          !END I = NI
        !END J = 0
        DO J = 1 , NJ-1
          I = 0
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,2) =   &
            ( ( XYUU( I ,J+1,DIM) - XYUU( I , J ,DIM) )   &
            + ( XYUU( P ,Q-1,DIM) - XYUU( P , Q ,DIM) ) * FACTOR(DIM)   &
            ) / 2.0
          !END I = 0
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI-1
            JOO( I , J ,DIM,2) = XYUU( I ,J+1,DIM) - XYUU( I , J ,DIM)
          END DO
          I = NI
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,2) =   &
            ( ( XYUU( P ,Q-1,DIM) - XYUU( P , Q ,DIM) ) * FACTOR(DIM)   &
            + ( XYUU( I ,J+1,DIM) - XYUU( I , J ,DIM) )   &
            ) / 2.0
          !END I = NI
        END DO
        J = NJ
          I = 0
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,2) =   &
            ( ( XYOO( P ,Q-1,DIM) - XYUU( P , Q ,DIM) ) * FACTOR(DIM)   &
            + ( XYOO( I , J ,DIM) - XYUU( I , J ,DIM) )   &
            )
          !END I = 0
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI-1
            JOO( I , J ,DIM,2) = 2.0 * ( XYOO( I , J ,DIM) - XYUU( I , J ,DIM) )
          END DO
          I = NI
            P = MOD(NI+I+NI/2,2*NI)-NI/2 ; Q = NJ-J+1
            JOO( I , J ,DIM,2) =   &
            ( ( XYOO( P ,Q-1,DIM) - XYUU( P , Q ,DIM) ) * FACTOR(DIM)   &
            + ( XYOO( I , J ,DIM) - XYUU( I , J ,DIM) )   &
            )
          !END I = NI
        !END J = NJ
      END DO
      JOO = JOO / XYR
      IF( ALLOCATED(GOO) ) GOO = ( .MRXUVTPS. JOO ) .MRXUVMAT. JOO
      IF( ALLOCATED(MO) ) THEN
        MO = .MRXUVDTM. JOO
        IF( ALLOCATED(IOO) ) THEN
          IOO = MO .MRXUVIVS. JOO
          IF( ALLOCATED(FOO) ) THEN
            FOO = IOO .MRXUVMAT. ( .MRXUVTPS. IOO )
          END IF
        END IF
      END IF

    END IF

    DEALLOCATE( XYUV , XYUU , XYVV , XYOO )

  END SUBROUTINE MR_INIT_CURVED_GEOS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_INIT_COORS( FILE_XMDF_NAME , ERROR , ERRMSG )

    USE MR_MOD_OPEN_N_CLOSE_FILE_XMDF
    USE MR_MOD_OPEN_N_CLOSE_MESH_IN_XMDF

    USE MR_MOD_READ_COORS

    IMPLICIT NONE

    CHARACTER(   *   ) , INTENT(IN ) :: FILE_XMDF_NAME

    INTEGER                          :: FILE_XMDF_ID , MESH_IN_XMDF_ID

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    INTEGER                          :: ERROR_DUMMY
    CHARACTER( 2**10 )               :: ERRMSG_DUMMY

    CALL MR_OPEN_FILE_XMDF( FILE_XMDF_NAME , FILE_XMDF_ID , ERROR , ERRMSG , READONLY=.TRUE. )
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" "//TRIM(FILE_XMDF_NAME)
      RETURN
    END IF

    CALL MR_OPEN_MESH_IN_XMDF( FILE_XMDF_ID , MESH_IN_XMDF_ID , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" /"//TRIM(XF_PATH_MESH_IN_XMDF)//" in file "//TRIM(FILE_XMDF_NAME)
      CALL MR_CLOSE_FILE_XMDF( FILE_XMDF_ID , ERROR_DUMMY , ERRMSG_DUMMY )
      RETURN
    END IF

    CALL MR_READ_XY( MESH_IN_XMDF_ID , NND , NI , NJ , EMIDW , NDIDW , NDIDU , NDIDV , NDIDO ,   &
    & XYUV , XYUU , XYVV , XYOO , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" /"//TRIM(XF_PATH_MESH_IN_XMDF)//" in file "//TRIM(FILE_XMDF_NAME)
      CALL MR_CLOSE_MESH_IN_XMDF( MESH_IN_XMDF_ID , ERROR_DUMMY , ERRMSG_DUMMY )
      CALL MR_CLOSE_FILE_XMDF( FILE_XMDF_ID , ERROR_DUMMY , ERRMSG_DUMMY )
      RETURN
    END IF

    CALL MR_CLOSE_MESH_IN_XMDF( MESH_IN_XMDF_ID , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" /"//TRIM(XF_PATH_MESH_IN_XMDF)//" in file "//TRIM(FILE_XMDF_NAME)
      CALL MR_CLOSE_FILE_XMDF( FILE_XMDF_ID , ERROR_DUMMY , ERRMSG_DUMMY )
      RETURN
    END IF

    CALL MR_CLOSE_FILE_XMDF( FILE_XMDF_ID , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" "//TRIM(FILE_XMDF_NAME)
      RETURN
    END IF

  END SUBROUTINE MR_INIT_COORS

  END MODULE MR_MOD_INIT_CURVED_GEOS

__Sources/MR_MOD_PROCESSES/MR_MOD_INITS/MR_MOD_INIT_CURVED_GEOS - for Anti-Symmetry BC.f90


      SUBROUTINE setup_int(xknots,smesh,hx,w,w1,u,u1,nk,nots,nmesh)
      USE stel_kinds
      USE vparams, ONLY: epstan
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER nots, nmesh
      INTEGER, DIMENSION(nots) :: nk
      REAL(rprec), DIMENSION(nots) :: xknots
      REAL(rprec), DIMENSION(nmesh) :: smesh
      REAL(rprec), DIMENSION(nots) :: hx
      REAL(rprec), DIMENSION(nmesh) :: w, w1, u, u1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: ksp1, k, i, k1
      REAL(rprec) :: smesh1, hk6
C-----------------------------------------------
!
!       FOR THE SPLINED FUNCTIONS CORRESPONDING TO XKNOTS (PRESSURE,
!       IOTA), THIS ROUTINE COMPUTES THE A AND B MATRIX ELEMENTS
!       (STORED IN W,U,W1,U1) WHICH ARE NEEDED TO EVALUATE THE FUNCTIONS
!       IN REAL-SPACE IN TERMS OF THEIR (VARIABLE) SPLINE KNOT VALUES.
!       THIS 'UNDOES' WHAT SPLINT ROUTINE DOES. LET Y(I) DENOTE THE
!       FUNCTION AT THE POINT SMESH(I) SUCH THAT
!
!                   XKNOTS(K) < SMESH(I) <= XKNOTS(K)
!
!       THEN,  Y(I) = W(I)*YK  + U(I)*GK  + W1(I)*YK1   + U1(I)*GK1
!
!       WHERE YK, GK ARE THE SPLINE AND 2ND DERIVATIVES AT KNOT K
!             YK1,GK1 ARE THE SAME AT KNOT K+1
!
      ksp1 = nots - 1
      smesh1 = smesh(1)
      IF (smesh1 .le. xknots(1)) smesh(1) = xknots(1) + epstan

      nk = 0

      k = 1
      DO i = 1, nmesh
  140    CONTINUE
         k1 = k + 1
!
!       XKNOTS = SQRT(HS*(JS-1)) DEFINED IN STARK,PRESSURE ROUTINE
!       (THIS CORRESPONDS TO APPROXIMATELY EQUAL SPACING ALONG MIDPLANE)
!
         IF (smesh(i).gt.xknots(k) .and. smesh(i).le.xknots(k1)) THEN
            nk(k) = nk(k) + 1
            hk6 = hx(k)*hx(k)/6.0
            w1(i) = (smesh(i)-xknots(k))/hx(k)
            IF (w1(i)<(-epstan) .or. w1(i)>1.0+epstan) STOP 'w1(i)'
            w(i) = 1.0 - w1(i)
            u(i) = hk6*w(i)*(w(i)*w(i)-1.0)
            u1(i) = hk6*w1(i)*(w1(i)*w1(i)-1.0)
         ELSE
            k = k + 1
            IF (k .gt. ksp1) STOP 'K>KSP1'
            GOTO 140
         ENDIF
      END DO

      smesh(1) = smesh1

      END SUBROUTINE setup_int


      SUBROUTINE MDIAN2(X,N,XMED)
      DIMENSION X(N)
      PARAMETER (BIG=1.E30,AFAC=1.5,AMP=1.5)
      A=0.5*(X(1)+X(N))
      EPS=ABS(X(N)-X(1))
      AP=BIG
      AM=-BIG
1     SUM=0.
      SUMX=0.
      NP=0
      NM=0
      XP=BIG
      XM=-BIG
      DO 11 J=1,N
        XX=X(J)
        IF(XX.NE.A)THEN
          IF(XX.GT.A)THEN
            NP=NP+1
            IF(XX.LT.XP)XP=XX
          ELSE IF(XX.LT.A)THEN
            NM=NM+1
            IF(XX.GT.XM)XM=XX
          ENDIF
          DUM=1./(EPS+ABS(XX-A))
          SUM=SUM+DUM
          SUMX=SUMX+XX*DUM
        ENDIF
11    CONTINUE
      IF(NP-NM.GE.2)THEN
        AM=A
        AA=XP+MAX(0.,SUMX/SUM-A)*AMP
        IF(AA.GT.AP)AA=0.5*(A+AP)
        EPS=AFAC*ABS(AA-A)
        A=AA
        GO TO 1
      ELSE IF(NM-NP.GE.2)THEN
        AP=A
        AA=XM+MIN(0.,SUMX/SUM-A)*AMP
        IF(AA.LT.AM)AA=0.5*(A+AM)
        EPS=AFAC*ABS(AA-A)
        A=AA
        GO TO 1
      ELSE
        IF(MOD(N,2).EQ.0)THEN
          IF(NP.EQ.NM)THEN
            XMED=0.5*(XP+XM)
          ELSE IF(NP.GT.NM)THEN
            XMED=0.5*(A+XP)
          ELSE
            XMED=0.5*(XM+A)
          ENDIF
        ELSE
          IF(NP.EQ.NM)THEN
            XMED=A
          ELSE IF(NP.GT.NM)THEN
            XMED=XP
          ELSE
            XMED=XM
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END


! RUN: bbc -emit-fir %s -o - | FileCheck %s
! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: sqrt_testr
subroutine sqrt_testr(a, b)
  real :: a, b
! CHECK: fir.call @fir.sqrt.f32.f32
  b = sqrt(a)
end subroutine

! CHECK-LABEL: sqrt_testd
subroutine sqrt_testd(a, b)
  real(kind=8) :: a, b
! CHECK: fir.call @fir.sqrt.f64.f64
  b = sqrt(a)
end subroutine

! CHECK-LABEL: sqrt_testc
subroutine sqrt_testc(z)
  complex :: z
! CHECK: fir.call @fir.sqrt.z4.z4
  z = sqrt(z)
end subroutine

! CHECK-LABEL: sqrt_testcd
subroutine sqrt_testcd(z)
  complex(kind=8) :: z
! CHECK: fir.call @fir.sqrt.z8.z8
  z = sqrt(z)
end subroutine

! CHECK-LABEL: @fir.sqrt.f32.f32
! CHECK: fir.call {{.*}}mth_i_sqrt

! CHECK-LABEL: @fir.sqrt.f64.f64
! CHECK: fir.call {{.*}}mth_i_dsqrt

! CHECK-LABEL: func private @fir.sqrt.z4.z4
! CHECK: fir.call {{.*}}fc_sqrt

! CHECK-LABEL: @fir.sqrt.z8.z8
! CHECK: fir.call {{.*}}fz_sqrt


      SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To apply a special similarity transformation to a system given as
C     a triple (A,B,C),
C
C        A <-- P * A * P,  B <-- P * B,  C <-- C * P,
C
C     where P is a matrix with 1 on the secondary diagonal, and with 0
C     in the other entries.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A, the number of rows of matrix B
C             and the number of columns of matrix C.
C             N represents the dimension of the state vector.  N >= 0.
C
C     M       (input) INTEGER.
C             The number of columns of matrix B.
C             M represents the dimension of input vector.  M >= 0.
C
C     P       (input) INTEGER.
C             The number of rows of matrix C.
C             P represents the dimension of output vector.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the system state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed matrix P*A*P.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the system input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed matrix P*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,N) if M > 0.
C             LDB >= 1        if M = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the system output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*P.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The rows and/or columns of the matrices of the triplet (A,B,C)
C     are swapped in a special way.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998.
C
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004.
C
C     KEYWORDS
C
C     Matrix algebra, matrix operations, similarity transformation.
C
C  *********************************************************************
C
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, M, N, P
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
C     ..
C     .. Local Scalars ..
      INTEGER            J, NBY2
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSWAP, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MOD
C     ..
C     .. Executable Statements ..
C
C     Test the scalar input arguments.
C
      INFO  = 0
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -9
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01YD', -INFO )
         RETURN
      END IF
C
      IF( N.LE.1 )
     $   RETURN
C
C     Transform the matrix A.
C
      NBY2 = N/2
C
      DO 10 J = 1, NBY2
         CALL DSWAP( N, A( 1, J ), -1, A( 1, N-J+1 ), 1 )
   10 CONTINUE
C
      IF( MOD( N, 2 ).NE.0 .AND. N.GT.2 )
     $   CALL DSWAP( NBY2, A( NBY2+2, NBY2+1 ), -1, A( 1, NBY2+1 ), 1 )
C
      IF( M.GT.0 ) THEN
C
C        Transform the matrix B.
C
         DO 20 J = 1, NBY2
            CALL DSWAP( M, B( J, 1 ), LDB, B( N-J+1, 1 ), LDB )
   20    CONTINUE
C
      END IF
C
      IF( P.GT.0 ) THEN
C
C        Transform the matrix C.
C
         DO 30 J = 1, NBY2
            CALL DSWAP( P, C( 1, J ), 1, C( 1, N-J+1 ), 1 )
   30    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of TB01YD ***
      END