*DECK DBESK
      SUBROUTINE DBESK (X, FNU, KODE, N, Y, NZ,ierr)
C***BEGIN PROLOGUE  DBESK
C***PURPOSE  Implement forward recursion on the three term recursion
C            relation for a sequence of non-negative order Bessel
C            functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions
C            EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive
C            X and non-negative orders FNU.
C***LIBRARY   SLATEC
C***CATEGORY  C10B3
C***TYPE      DOUBLE PRECISION (BESK-S, DBESK-D)
C***KEYWORDS  K BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract  **** a double precision routine ****
C         DBESK implements forward recursion on the three term
C         recursion relation for a sequence of non-negative order Bessel
C         functions K/sub(FNU+I-1)/(X), or scaled Bessel functions
C         EXP(X)*K/sub(FNU+I-1)/(X), I=1,..,N for real X .GT. 0.0D0 and
C         non-negative orders FNU.  If FNU .LT. NULIM, orders FNU and
C         FNU+1 are obtained from DBSKNU to start the recursion.  If
C         FNU .GE. NULIM, the uniform asymptotic expansion is used for
C         orders FNU and FNU+1 to start the recursion.  NULIM is 35 or
C         70 depending on whether N=1 or N .GE. 2.  Under and overflow
C         tests are made on the leading term of the asymptotic expansion
C         before any extensive computation is done.
C
C         The maximum number of significant digits obtainable
C         is the smaller of 14 and the number of digits carried in
C         double precision arithmetic.
C
C     Description of Arguments
C
C         Input      X,FNU are double precision
C           X      - X .GT. 0.0D0
C           FNU    - order of the initial K function, FNU .GE. 0.0D0
C           KODE   - a parameter to indicate the scaling option
C                    KODE=1 returns Y(I)=       K/sub(FNU+I-1)/(X),
C                                        I=1,...,N
C                    KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X),
C                                        I=1,...,N
C           N      - number of members in the sequence, N .GE. 1
C
C         Output     Y is double precision
C           Y      - a vector whose first N components contain values
C                    for the sequence
C                    Y(I)=       k/sub(FNU+I-1)/(X), I=1,...,N  or
C                    Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N
C                    depending on KODE
C           NZ     - number of components of Y set to zero due to
C                    underflow with KODE=1,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, first NZ components of Y set to zero
C                             due to underflow, Y(I)=0.0D0, I=1,...,NZ
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C         Underflow with KODE=1 -  a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C               N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  D1MACH, DASYIK, DBESK0, DBESK1, DBSK0E, DBSK1E,
C                    DBSKNU, I1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBESK
C
      INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ
      INTEGER I1MACH
      DOUBLE PRECISION CN,DNU,ELIM,ETX,FLGIK,FN,FNN,FNU,GLN,GNU,RTZ,
     1 S, S1, S2, T, TM, TRX, W, X, XLIM, Y, ZN
      DOUBLE PRECISION DBESK0, DBESK1, DBSK1E, DBSK0E, D1MACH
      DIMENSION W(2), NULIM(2), Y(*)
      SAVE NULIM
      DATA NULIM(1),NULIM(2) / 35 , 70 /
C***FIRST EXECUTABLE STATEMENT  DBESK
      ierr=0
      NN = -I1MACH(15)
      ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0)
      XLIM = D1MACH(1)*1.0D+3
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280
      IF (FNU.LT.0.0D0) GO TO 290
      IF (X.LE.0.0D0) GO TO 300
      IF (X.LT.XLIM) GO TO 320
      IF (N.LT.1) GO TO 310
      ETX = KODE - 1
C
C     ND IS A DUMMY VARIABLE FOR N
C     GNU IS A DUMMY VARIABLE FOR FNU
C     NZ = NUMBER OF UNDERFLOWS ON KODE=1
C
      ND = N
      NZ = 0
      NUD = INT(FNU)
      DNU = FNU - NUD
      GNU = FNU
      NN = MIN(2,ND)
      FN = FNU + N - 1
      FNN = FN
      IF (FN.LT.2.0D0) GO TO 150
C
C     OVERFLOW TEST  (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE LAST ORDER, FNU+N-1.GE.NULIM
C
      ZN = X/FN
      IF (ZN.EQ.0.0D0) GO TO 320
      RTZ = SQRT(1.0D0+ZN*ZN)
      GLN = LOG((1.0D0+RTZ)/ZN)
      T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ)
      CN = -FN*(T-GLN)
      IF (CN.GT.ELIM) GO TO 320
      IF (NUD.LT.NULIM(NN)) GO TO 30
      IF (NN.EQ.1) GO TO 20
   10 CONTINUE
C
C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE FIRST ORDER, FNU.GE.NULIM
C
      FN = GNU
      ZN = X/FN
      RTZ = SQRT(1.0D0+ZN*ZN)
      GLN = LOG((1.0D0+RTZ)/ZN)
      T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ)
      CN = -FN*(T-GLN)
   20 CONTINUE
      IF (CN.LT.-ELIM) GO TO 230
C
C     ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM
C
      FLGIK = -1.0D0
      CALL DASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y)
      IF (NN.EQ.1) GO TO 240
      TRX = 2.0D0/X
      TM = (GNU+GNU+2.0D0)/X
      GO TO 130
C
   30 CONTINUE
      IF (KODE.EQ.2) GO TO 40
C
C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X)
C     FOR ORDER DNU
C
      IF (X.GT.ELIM) GO TO 230
   40 CONTINUE
      IF (DNU.NE.0.0D0) GO TO 80
      IF (KODE.EQ.2) GO TO 50
      S1 = DBESK0(X)
      GO TO 60
   50 S1 = DBSK0E(X)
   60 CONTINUE
      IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120
      IF (KODE.EQ.2) GO TO 70
      S2 = DBESK1(X)
      GO TO 90
   70 S2 = DBSK1E(X)
      GO TO 90
   80 CONTINUE
      NB = 2
      IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1
      CALL DBSKNU(X, DNU, KODE, NB, W, NZ)
      S1 = W(1)
      IF (NB.EQ.1) GO TO 120
      S2 = W(2)
   90 CONTINUE
      TRX = 2.0D0/X
      TM = (DNU+DNU+2.0D0)/X
C     FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2)
      IF (ND.EQ.1) NUD = NUD - 1
      IF (NUD.GT.0) GO TO 100
      IF (ND.GT.1) GO TO 120
      S1 = S2
      GO TO 120
  100 CONTINUE
      DO 110 I=1,NUD
        S = S2
        S2 = TM*S2 + S1
        S1 = S
        TM = TM + TRX
  110 CONTINUE
      IF (ND.EQ.1) S1 = S2
  120 CONTINUE
      Y(1) = S1
      IF (ND.EQ.1) GO TO 240
      Y(2) = S2
  130 CONTINUE
      IF (ND.EQ.2) GO TO 240
C     FORWARD RECUR FROM FNU+2 TO FNU+N-1
      DO 140 I=3,ND
        Y(I) = TM*Y(I-1) + Y(I-2)
        TM = TM + TRX
  140 CONTINUE
      GO TO 240
C
  150 CONTINUE
C     UNDERFLOW TEST FOR KODE=1
      IF (KODE.EQ.2) GO TO 160
      IF (X.GT.ELIM) GO TO 230
  160 CONTINUE
C     OVERFLOW TEST
      IF (FN.LE.1.0D0) GO TO 170
      IF (-FN*(LOG(X)-0.693D0).GT.ELIM) GO TO 320
  170 CONTINUE
      IF (DNU.EQ.0.0D0) GO TO 180
      CALL DBSKNU(X, FNU, KODE, ND, Y, MZ)
      GO TO 240
  180 CONTINUE
      J = NUD
      IF (J.EQ.1) GO TO 210
      J = J + 1
      IF (KODE.EQ.2) GO TO 190
      Y(J) = DBESK0(X)
      GO TO 200
  190 Y(J) = DBSK0E(X)
  200 IF (ND.EQ.1) GO TO 240
      J = J + 1
  210 IF (KODE.EQ.2) GO TO 220
      Y(J) = DBESK1(X)
      GO TO 240
  220 Y(J) = DBSK1E(X)
      GO TO 240
C
C     UPDATE PARAMETERS ON UNDERFLOW
C
  230 CONTINUE
      NUD = NUD + 1
      ND = ND - 1
      IF (ND.EQ.0) GO TO 240
      NN = MIN(2,ND)
      GNU = GNU + 1.0D0
      IF (FNN.LT.2.0D0) GO TO 230
      IF (NUD.LT.NULIM(NN)) GO TO 230
      GO TO 10
  240 CONTINUE
      NZ = N - ND
      IF (NZ.EQ.0) RETURN
      IF (ND.EQ.0) GO TO 260
      DO 250 I=1,ND
        J = N - I + 1
        K = ND - I + 1
        Y(J) = Y(K)
  250 CONTINUE
  260 CONTINUE
      DO 270 I=1,NZ
        Y(I) = 0.0D0
  270 CONTINUE
      RETURN
C
C
C
  280 CONTINUE
C      CALL XERMSG ('SLATEC', 'DBESK',
C     +   'SCALING OPTION, KODE, NOT 1 OR 2', 2, 1)
      ierr=1
      RETURN
  290 CONTINUE
C      CALL XERMSG ('SLATEC', 'DBESK', 'ORDER, FNU, LESS THAN ZERO', 2,
C     +   1)
      ierr=1
      RETURN
  300 CONTINUE
C      CALL XERMSG ('SLATEC', 'DBESK', 'X LESS THAN OR EQUAL TO ZERO',
C     +   2, 1)
      ierr=1
      RETURN
  310 CONTINUE
C      CALL XERMSG ('SLATEC', 'DBESK', 'N LESS THAN ONE', 2, 1)
      ierr=1
      RETURN
  320 CONTINUE
C      CALL XERMSG ('SLATEC', 'DBESK',
C     +   'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1)
      ierr=2
      RETURN
      END


MODULE UnitsModule

  USE KindModule, ONLY: &
    DP
  USE PhysicalConstantsModule, ONLY: &
    SpeedOfLightMKS, &
    GravitationalConstantMKS, &
    BoltzmannConstantMKS, &
    ElectronVoltMKS, &
    PlanckConstantMKS, &
    AvogadroConstantMKS

  IMPLICIT NONE
  PRIVATE

  LOGICAL, PUBLIC :: UnitsActive = .FALSE.

  REAL(DP), PUBLIC, PARAMETER :: &
    SpeedOfLight          = 1.0_DP, &
    GravitationalConstant = 1.0_DP, &
    BoltzmannConstant     = 1.0_DP

  ! --- Length ---

  REAL(DP), PUBLIC, PARAMETER :: &
    Meter      = 1.0_DP, &
    Centimeter = 1.0e-2_DP * Meter, &
    Kilometer  = 1.0e+3_DP * Meter

  ! --- Time ---

  REAL(DP), PUBLIC, PARAMETER :: &
    Second      = SpeedOfLightMKS / SpeedOfLight * Meter, &
    Millisecond = 1.0e-3_DP * Second, &
    Microsecond = 1.0e-6_DP * Second

  ! --- Mass ---

  REAL(DP), PUBLIC, PARAMETER :: &
    Kilogram  = GravitationalConstantMKS / GravitationalConstant &
                  * Meter**3 / Second**2, &
    Gram      = 1.0e-3_DP * Kilogram, &
    SolarMass = 1.98892e30_DP * Kilogram

  ! --- Other Units of Measure and Constants ---

  REAL(DP), PUBLIC, PARAMETER :: &
    Joule          = Kilogram * ( Meter / Second )**2, &
    Erg            = Gram * ( Centimeter / Second )**2, &
    Bethe          = 1.0e51_DP * Erg, &
    ElectronVolt   = ElectronVoltMKS * Joule, &
    MeV            = 1.0e6_DP * ElectronVolt, &
    Kelvin         = BoltzmannConstantMKS / BoltzmannConstant * Joule, &
    Newton         = Joule / Meter, &
    Dyne           = Erg / Centimeter, &
    PlanckConstant = PlanckConstantMKS * Joule * Second, &
    AtomicMassUnit = Gram / AvogadroConstantMKS

  ! --- Units Displayed During Execution and for IO ---

  CHARACTER(16), PRIVATE, PARAMETER :: &
    DisplayLabel_Null            = '', &
    DisplayLabel_Length_L        = 'km', &
    DisplayLabel_Length_A        = 'rad', &
    DisplayLabel_Time            = 'ms', &
    DisplayLabel_Mass            = 'M_sun', &
    DisplayLabel_MassDensity     = 'g/cm^3', &
    DisplayLabel_ParticleDensity = '1/cm^3', &
    DisplayLabel_Velocity_L      = 'km/s', &
    DisplayLabel_Velocity_A      = '1/s', &
    DisplayLabel_Momentum        = 'g cm/s', &
    DisplayLabel_MomentumDensity = 'g/cm^2/s', &
    DisplayLabel_Energy          = 'MeV', &
    DisplayLabel_EnergyGlobal    = 'B', &
    DisplayLabel_EnergyDensity   = 'erg/cm^3', &
    DisplayLabel_Pressure        = 'erg/cm^3', &
    DisplayLabel_Temperature     = 'K'

  REAL(DP), PRIVATE, PARAMETER :: &
    DisplayUnit_Length_L        = Kilometer, &
    DisplayUnit_Length_A        = 1.0_DP, &
    DisplayUnit_Time            = Millisecond, &
    DisplayUnit_Mass            = SolarMass, &
    DisplayUnit_MassDensity     = Gram / Centimeter**3, &
    DisplayUnit_ParticleDensity = 1.0_DP / Centimeter**3, &
    DisplayUnit_Velocity_L      = Kilometer / Second, &
    DisplayUnit_Velocity_A      = 1.0_DP / Second, &
    DisplayUnit_Momentum        = Gram * Centimeter / Second, &
    DisplayUnit_MomentumDensity = Gram / Centimeter**2 / Second, &
    DisplayUnit_Energy          = MeV, &
    DisplayUnit_EnergyGlobal    = Bethe, &
    DisplayUnit_EnergyDensity   = Erg / Centimeter**3, &
    DisplayUnit_Pressure        = Erg / Centimeter**3, &
    DisplayUnit_Temperature     = Kelvin

  TYPE, PRIVATE :: UnitsDisplayType
    LOGICAL  :: &
      Active = .FALSE.
    CHARACTER(16) :: &
      LengthX1Label        = DisplayLabel_Null, &
      LengthX2Label        = DisplayLabel_Null, &
      LengthX3Label        = DisplayLabel_Null, &
      TimeLabel            = DisplayLabel_Null, &
      MassLabel            = DisplayLabel_Null, &
      MassDensityLabel     = DisplayLabel_Null, &
      ParticleDensityLabel = DisplayLabel_Null, &
      VelocityX1Label      = DisplayLabel_Null, &
      VelocityX2Label      = DisplayLabel_Null, &
      VelocityX3Label      = DisplayLabel_Null, &
      MomentumLabel        = DisplayLabel_Null, &
      MomentumDensityLabel = DisplayLabel_Null, &
      EnergyLabel          = DisplayLabel_Null, &
      EnergyGlobalLabel    = DisplayLabel_Null, &
      EnergyDensityLabel   = DisplayLabel_Null, &
      PressureLabel        = DisplayLabel_Null, &
      TemperatureLabel     = DisplayLabel_Null
    REAL(DP) :: &
      LengthX1Unit        = 1.0_DP, &
      LengthX2Unit        = 1.0_DP, &
      LengthX3Unit        = 1.0_DP, &
      TimeUnit            = 1.0_DP, &
      MassUnit            = 1.0_DP, &
      MassDensityUnit     = 1.0_DP, &
      ParticleDensityUnit = 1.0_DP, &
      VelocityX1Unit      = 1.0_DP, &
      VelocityX2Unit      = 1.0_DP, &
      VelocityX3Unit      = 1.0_DP, &
      MomentumUnit        = 1.0_DP, &
      MomentumDensityUnit = 1.0_DP, &
      EnergyUnit          = 1.0_DP, &
      EnergyGlobalUnit    = 1.0_DP, &
      EnergyDensityUnit   = 1.0_DP, &
      PressureUnit        = 1.0_DP, &
      TemperatureUnit     = 1.0_DP
  END type UnitsDisplayType

  TYPE(UnitsDisplayType), PUBLIC :: UnitsDisplay

  PUBLIC :: ActivateUnitsDisplay
  PUBLIC :: DescribeUnitsDisplay

CONTAINS

  SUBROUTINE ActivateUnitsDisplay( CoordinateSystem_Option )

    CHARACTER(LEN=*), INTENT(in), OPTIONAL ::  CoordinateSystem_Option

    CHARACTER(LEN=16)  :: CoordinateSystem

    CoordinateSystem = 'CARTESIAN'
    IF( PRESENT( CoordinateSystem_Option ) ) &
      CoordinateSystem = TRIM( CoordinateSystem_Option )

    UnitsActive = .TRUE.

    UnitsDisplay % Active = .TRUE.

    UnitsDisplay % TimeLabel            = DisplayLabel_Time
    UnitsDisplay % MassLabel            = DisplayLabel_Mass
    UnitsDisplay % MassDensityLabel     = DisplayLabel_MassDensity
    UnitsDisplay % ParticleDensityLabel = DisplayLabel_ParticleDensity

    SELECT CASE( TRIM( CoordinateSystem ) )

      CASE( 'CARTESIAN' )

        UnitsDisplay % LengthX1Label = DisplayLabel_Length_L
        UnitsDisplay % LengthX2Label = DisplayLabel_Length_L
        UnitsDisplay % LengthX3Label = DisplayLabel_Length_L

        UnitsDisplay % VelocityX1Label = DisplayLabel_Velocity_L
        UnitsDisplay % VelocityX2Label = DisplayLabel_Velocity_L
        UnitsDisplay % VelocityX3Label = DisplayLabel_Velocity_L

      CASE( 'CYLINDRICAL' )

        UnitsDisplay % LengthX1Label = DisplayLabel_Length_L
        UnitsDisplay % LengthX2Label = DisplayLabel_Length_L
        UnitsDisplay % LengthX3Label = DisplayLabel_Length_A

        UnitsDisplay % VelocityX1Label = DisplayLabel_Velocity_L
        UnitsDisplay % VelocityX2Label = DisplayLabel_Velocity_L
        UnitsDisplay % VelocityX3Label = DisplayLabel_Velocity_A

      CASE( 'SPHERICAL' )

        UnitsDisplay % LengthX1Label = DisplayLabel_Length_L
        UnitsDisplay % LengthX2Label = DisplayLabel_Length_A
        UnitsDisplay % LengthX3Label = DisplayLabel_Length_A

        UnitsDisplay % VelocityX1Label = DisplayLabel_Velocity_L
        UnitsDisplay % VelocityX2Label = DisplayLabel_Velocity_A
        UnitsDisplay % VelocityX3Label = DisplayLabel_Velocity_A

      CASE DEFAULT

        WRITE(*,*) 'Invalid choice for coodinate system: ', &
                   TRIM( CoordinateSystem )

    END SELECT

    UnitsDisplay % MomentumLabel        = DisplayLabel_Momentum
    UnitsDisplay % MomentumDensityLabel = DisplayLabel_MomentumDensity
    UnitsDisplay % EnergyLabel          = DisplayLabel_Energy
    UnitsDisplay % EnergyGlobalLabel    = DisplayLabel_EnergyGlobal
    UnitsDisplay % EnergyDensityLabel   = DisplayLabel_EnergyDensity
    UnitsDisplay % PressureLabel        = DisplayLabel_Pressure
    UnitsDisplay % TemperatureLabel     = DisplayLabel_Temperature

    UnitsDisplay % TimeUnit            = DisplayUnit_Time
    UnitsDisplay % MassUnit            = DisplayUnit_Mass
    UnitsDisplay % MassDensityUnit     = DisplayUnit_MassDensity
    UnitsDisplay % ParticleDensityUnit = DisplayUnit_ParticleDensity

    SELECT CASE( TRIM( CoordinateSystem ) )

      CASE( 'CARTESIAN' )

        UnitsDisplay % LengthX1Unit = DisplayUnit_Length_L
        UnitsDisplay % LengthX2Unit = DisplayUnit_Length_L
        UnitsDisplay % LengthX3Unit = DisplayUnit_Length_L

        UnitsDisplay % VelocityX1Unit = DisplayUnit_Velocity_L
        UnitsDisplay % VelocityX2Unit = DisplayUnit_Velocity_L
        UnitsDisplay % VelocityX3Unit = DisplayUnit_Velocity_L

      CASE( 'CYLINDRICAL' )

        UnitsDisplay % LengthX1Unit = DisplayUnit_Length_L
        UnitsDisplay % LengthX2Unit = DisplayUnit_Length_L
        UnitsDisplay % LengthX3Unit = DisplayUnit_Length_A

        UnitsDisplay % VelocityX1Unit = DisplayUnit_Velocity_L
        UnitsDisplay % VelocityX2Unit = DisplayUnit_Velocity_L
        UnitsDisplay % VelocityX3Unit = DisplayUnit_Velocity_A

      CASE( 'SPHERICAL' )

        UnitsDisplay % LengthX1Unit = DisplayUnit_Length_L
        UnitsDisplay % LengthX2Unit = DisplayUnit_Length_A
        UnitsDisplay % LengthX3Unit = DisplayUnit_Length_A

        UnitsDisplay % VelocityX1Unit = DisplayUnit_Velocity_L
        UnitsDisplay % VelocityX2Unit = DisplayUnit_Velocity_A
        UnitsDisplay % VelocityX3Unit = DisplayUnit_Velocity_A

      CASE DEFAULT

        WRITE(*,*) 'Invalid choice for coodinate system: ', &
                   TRIM( CoordinateSystem )

    END SELECT

    UnitsDisplay % MomentumUnit        = DisplayUnit_Momentum
    UnitsDisplay % MomentumDensityUnit = DisplayUnit_MomentumDensity
    UnitsDisplay % EnergyUnit          = DisplayUnit_Energy
    UnitsDisplay % EnergyGlobalUnit    = DisplayUnit_EnergyGlobal
    UnitsDisplay % EnergyDensityUnit   = DisplayUnit_EnergyDensity
    UnitsDisplay % PressureUnit        = DisplayUnit_Pressure
    UnitsDisplay % TemperatureUnit     = DisplayUnit_Temperature

  END SUBROUTINE ActivateUnitsDisplay

  SUBROUTINE DescribeUnitsDisplay

    WRITE(*,*)
    WRITE(*,'(A5,A25,L2)') &
      '', 'Units Activation Status =', UnitsDisplay % Active
    WRITE(*,'(A5,A27)') &
      '', '---------------------------'
    WRITE(*,*)
    WRITE(*,'(A7,A24,A)') &
      '', 'Length (X1) Units: ', &
      TRIM( UnitsDisplay % LengthX1Label )
    WRITE(*,'(A7,A24,A)') &
      '', 'Length (X2) Units: ', &
      TRIM( UnitsDisplay % LengthX2Label )
    WRITE(*,'(A7,A24,A)') &
      '', 'Length (X3) Units: ', &
      TRIM( UnitsDisplay % LengthX3Label )
    WRITE(*,'(A7,A24,A)') &
      '', 'Time Units: ', &
      TRIM( UnitsDisplay % TimeLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Mass Units: ', &
      TRIM( UnitsDisplay % MassLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Mass Density Units: ', &
      TRIM( UnitsDisplay % MassDensityLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Particle Density Units: ', &
      TRIM( UnitsDisplay % ParticleDensityLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Velocity (X1) Units: ', &
      TRIM( UnitsDisplay % VelocityX1Label )
    WRITE(*,'(A7,A24,A)') &
      '', 'Velocity (X2) Units: ', &
      TRIM( UnitsDisplay % VelocityX2Label )
    WRITE(*,'(A7,A24,A)') &
      '', 'Velocity (X3) Units: ', &
      TRIM( UnitsDisplay % VelocityX3Label )
    WRITE(*,'(A7,A24,A)') &
      '', 'Momentum Units: ', &
      TRIM( UnitsDisplay % MomentumLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Momentum Density Units: ', &
      TRIM( UnitsDisplay % MomentumDensityLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Energy Units: ', &
      TRIM( UnitsDisplay % EnergyLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Energy Global Units: ', &
      TRIM( UnitsDisplay % EnergyGlobalLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Energy Density Units: ', &
      TRIM( UnitsDisplay % EnergyDensityLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Pressure Units: ', &
      TRIM( UnitsDisplay % PressureLabel )
    WRITE(*,'(A7,A24,A)') &
      '', 'Temperature Units: ', &
      TRIM( UnitsDisplay % TemperatureLabel )
    WRITE(*,*)

  END SUBROUTINE DescribeUnitsDisplay

END MODULE UnitsModule


      SUBROUTINE BMG2_SymStd_SETUP_lines_x(&
     &                SO, SOR, Nx, Ny, NStncl, JPN&
     &                ) BIND(C,NAME='BMG2_SymStd_SETUP_lines_x')

! ======================================================================
!  --------------------
!   DESCRIPTION:
!  --------------------
!
!     BMG2_SymStd_SETUP_lines_x performs a factorization of the tridiago
!     matrix that arises in x-line relaxation.  It assumes that the syst
!     is diagonally dominant and it works directly with the stencil.
!
! ======================================================================
! $license_flag$
! ======================================================================
!  --------------------
!   INPUT:
!  --------------------
!
!
! ======================================================================
!  --------------------
!   INPUT/OUTPUT:
!  --------------------
!
!
! ======================================================================
!  --------------------
!   OUTPUT:
!  --------------------
!
!
! ======================================================================
!  --------------------
!   LOCAL:
!  --------------------
!
!
! ======================================================================
      USE ModInterface
      IMPLICIT NONE

! -----------------------------
!     Includes
!
      INCLUDE 'BMG_constants_f90.h'
      INCLUDE 'BMG_parameters_f90.h'
      INCLUDE 'BMG_stencils_f90.h'

! ----------------------------
!     Argument Declarations
!
      integer(len_t), VALUE :: Nx, Ny
      integer(c_int), VALUE :: NStncl, JPN
      real(real_t) :: SO(Nx,Ny,NStncl), SOR(Nx,Ny,2)

! ----------------------------
!     Local Declarations
!
      INTEGER   i, j
      INTEGER   INFO, IPN, PER_x, Per_xy

! ======================================================================

      IPN = IABS(JPN)

      DO j=2, Ny-1
         DO i=2, Nx-1
            SOR(i,j,2) = -SO(i,j,KW)  ! off diagonal
            SOR(i,j,1) =  SO(i,j,KO)  ! diagonal
         ENDDO
      ENDDO

      PER_x = IABS(BMG_BCs_def_per_x)
      PER_xy = IABS(BMG_BCs_def_per_xy)
      IF(IPN.EQ.PER_x .OR. IPN.EQ.PER_xy) THEN
         DO j = 2, Ny-1
            SOR(2,j,1) = SOR(2,j,1) + SO(2,j,KW)
            SOR(Nx-1,j,1) = SOR(Nx-1,j,1) + SO(Nx,j,KW)
         ENDDO
      ENDIF

!     calculate the L*D*L' factorizations for the lines in x-direction
      DO j=2,Ny-1
         CALL DPTTRF (Nx-2, SOR(2,j,1), SOR(3,j,2), INFO)
      ENDDO

!      DO j=2, Ny-1
!         SOR(2,j,MSOR)=rONE/SO(2,j,KO)
!         DO i=3, Nx-1
!            SOR(i,j,MSOR)=rONE
!     &                   /( SO(i,j,KO) - SOR(i-1,j,MSOR)*SO(i,j,KW)**2
!         ENDDO
!      ENDDO

! ======================================================================

      RETURN
      END


!-------------------------------------------------------------------------------
! implementation for a dense, fully-connected layer type (DenseLayer)
!-------------------------------------------------------------------------------

module dense_layer_definitions
use net_helper_procedures
implicit none

!===============================================================================
!===============================================================================
! procedures with 2D array input require variables-as-columns form
!===============================================================================
!===============================================================================

!===============================================================================
! types
!===============================================================================

! represents a Dense (fully-connected) Layer in a neural network
!
! we define a DenseLayer as group of nodes and the weights that feed into them
! (which is difsferent than the usual idea of a dense layer just being nodes).
!
! consider a simple neural network with weights w1 and w2,
! and nodes n1 (input), n2 (hidden), and n3 (output):
!
!                    O ----  O  ---- O
!
!                   n1  w1  n2   w2  n3
!
! in the definition used here, there would be only two DenseLayers:
! the first hidden DenseLayer (w1,n2), and the output DenseLayer (w2,n3).
! node n1 is not a DenseLayer on its own, becuase no weights feed into it
!
! in this implementation, all examples in a batch are processed in the same
! forward pass by utilizing more extensive matrix operations
!
! DenseLayer are connected to each other as a doubly-linked list
type :: DenseLayer
    integer                    :: in_nodes, out_nodes, batch_size
    class(DenseLayer), pointer :: prev_layer, next_layer
    character(len=20)          :: activ
    real(kind=8), allocatable  :: w(:,:), & ! weights
                                  b(:,:), & ! biases
                                  z(:,:), & ! weighted inputs
                                  a(:,:), & ! activations
                                  d(:,:), & ! deltas (errors),
                                  drop(:,:) ! dropout inputs (0=drop, 1=keep)
    real                       :: drop_rate ! % of input nodes to drop
contains
    ! procedures that traverse through linked list of DenseLayers
    procedure, pass            :: dense_init, dense_update, &
                                  dense_forw_prop, dense_back_prop, &
                                  dense_dropout_rand
end type
contains

!===============================================================================
! constructors / destructors
!===============================================================================

!-------------------------------------------------------------------------------
! constructs a new DenseLayer
!-------------------------------------------------------------------------------
! in_nodes:  (integer) nodes feeding into DenseLayer
! out_nodes: (integer) nodes output by this DenseLayer
! activ:     (characters) activation function
! drop_rate: (real) % of input nodes to dropout
!-------------------------------------------------------------------------------
! returns :: (DenseLayer pointer) new DenseLayer
!-------------------------------------------------------------------------------
function create_dense_layer(in_nodes, out_nodes, activ, drop_rate)
    class(DenseLayer), pointer :: create_dense_layer
    integer, intent(in)        :: in_nodes, out_nodes
    character(*), intent(in)   :: activ
    real, intent(in)           :: drop_rate

    allocate(create_dense_layer)
    create_dense_layer%in_nodes   =  in_nodes
    create_dense_layer%out_nodes  =  out_nodes
    create_dense_layer%activ      =  activ
    create_dense_layer%drop_rate  =  drop_rate
    create_dense_layer%prev_layer => null()
    create_dense_layer%next_layer => null()
end function

!-------------------------------------------------------------------------------
! deallocate a DenseLayer
!-------------------------------------------------------------------------------
! l:        (DenseLayer pointer)
!-------------------------------------------------------------------------------
! alters :: l is deallocated
!-------------------------------------------------------------------------------
subroutine deallocate_dense_layer(l)
    class(DenseLayer), pointer :: l
    deallocate(l%w, l%b, l%z, l%a, l%d)
    deallocate(l)
end subroutine

!===============================================================================
! DenseLayer procedures
!===============================================================================

!-------------------------------------------------------------------------------
! helper subroutine to initialize the various matrices of DenseLayers
!-------------------------------------------------------------------------------
! this:       (DenseLayer - implicitly passed)
! batch_size: (integer) examples to process (at once) before back prop
!-------------------------------------------------------------------------------
! alters ::   this DenseLayer's matrices are allocated and become usable
!-------------------------------------------------------------------------------
subroutine dense_init(this, batch_size)
    class(DenseLayer)   :: this
    integer, intent(in) :: batch_size

    this%batch_size = batch_size

    allocate(this%w(this%in_nodes, this%out_nodes), &
             this%b(batch_size, this%out_nodes), &
             this%z(batch_size, this%out_nodes), &
             this%a(batch_size, this%out_nodes), &
             this%d(batch_size, this%out_nodes), &
             this%drop(batch_size, this%in_nodes))

    ! initialize weights and biases
    call random_number(this%w)   ! random weights, uniform range: [0,1)
    this%w = (this%w - 0.5) / 10 ! shift and scale to [-0.05, 0.05)
    this%b = 0

    ! traverse next layers
    if (associated(this%next_layer)) then
        call this%next_layer%dense_init(batch_size)
    end if
end subroutine

!-------------------------------------------------------------------------------
! helper subroutine to random initialize/overwrite a DenseLayers dropout array
!-------------------------------------------------------------------------------
! this:     (DenseLayer - implicitly passed)
!-------------------------------------------------------------------------------
! alters :: this DenseLayer's drop array has randomized values
!-------------------------------------------------------------------------------
subroutine dense_dropout_rand(this)
    class(DenseLayer)   :: this

    ! initialize dropout layer; 0=drop, 1=keep (we will be multiplying)
    if (this%drop_rate > 0) then
        call random_number(this%drop) ! random weights, uniform range: [0,1)

        ! this%drop_rate are dropped, so 1 - this%drop_rate are kept;
        ! think of keep = 1 - this%drop_rate; add keep, then cast to int to
        ! truncate kept values to 1 and dropped values to 0;
        !
        ! shift to [keep, 1+keep), so after truncating, so
        ! values in top keep proportion are kept at 1
        this%drop = int(this%drop + 1 - this%drop_rate)
    end if
end subroutine

!-------------------------------------------------------------------------------
! helper subroutine to forward propagate through DenseLayers
!-------------------------------------------------------------------------------
! this:     (DenseLayer - implicitly passed)
! input:    (real(:,:)) input batch to forward propagate
! is_train: (logical) in training iteration
!-------------------------------------------------------------------------------
! alters :: this DenseLayer's z and a are calculated
!-------------------------------------------------------------------------------
subroutine dense_forw_prop(this, input, is_train)
    class(DenseLayer)        :: this
    real(kind=8), intent(in) :: input(:,:)
    logical, intent(in)      :: is_train

    ! z(l) = matmul(a(l-1), w(l)) + b(l); first handle dropout
    if (this%drop_rate > 0 .and. is_train) then
        call this%dense_dropout_rand() ! randomize dropout
        call dgemm_wrapper(input*this%drop, this%w, this%z)
    else
        call dgemm_wrapper(input, this%w, this%z) ! no drops
    end if

    this%z = this%z + this%b

    ! apply activation and traverse next layers (if this is not output layer);
    ! output layer has different activation function usage
    if (associated(this%next_layer)) then
        if (this%activ == 'softmax') then
            print *, '--------------------------------------------'
            print *, '(dense_layer_definitions :: dense_forw_prop)'
            print *, 'invalid activation function.'
            print *, 'softmax only supported for output layer.'
            print *, 'supported: sigmoid, relu, leaky_relu, elu'
            print *, '--------------------------------------------'
            stop -1
        end if

        ! a(l) = activ(z(l))
        this%a = activfunc(this%z, this%activ)
        call this%next_layer%dense_forw_prop(this%a, is_train)
    end if
end subroutine

!-------------------------------------------------------------------------------
! helper subroutine to back propagate through DenseLayers
!-------------------------------------------------------------------------------
! this:     (DenseLayer - implicitly passed)
!-------------------------------------------------------------------------------
! alters :: this DenseLayer's d is calculated
!-------------------------------------------------------------------------------
subroutine dense_back_prop(this)
    class(DenseLayer) :: this

    if (.not. associated(this%next_layer)) then
        print *, '--------------------------------------------'
        print *, '(dense_layer_definitions :: dense_back_prop)'
        print *, 'cannot call dense_back_prop on output layer.'
        print *, '--------------------------------------------'
        stop -1
    end if

    ! deltas for this layer in terms of next layer deltas:
    ! delta(l) = matmul(delta(l+1), transpose(w(l+1))) * activ_deriv(z(l))
    call dgemm_wrapper(this%next_layer%d, this%next_layer%w, this%d, &
                       transb = .true.)

    this%d = this%d * activfunc_deriv(this%z, this%activ)

    ! traverse previous layers
    if (associated(this%prev_layer)) then
        call this%prev_layer%dense_back_prop()
    end if
end subroutine

!-------------------------------------------------------------------------------
! helper subroutine to adjust weights and biases in DenseLayers
!-------------------------------------------------------------------------------
! this:       (DenseLayer - implicitly passed)
! input:      (real(:,:)) previous layer activations
! learn_rate: (real) scale factor for change in weights and biases
! is_train:   (logical) in training iteration
! avg_deltas: (logical) average deltas across batch for update
!-------------------------------------------------------------------------------
! alters ::   this DenseLayer's weights and biases adjusted to minimize loss
!-------------------------------------------------------------------------------
subroutine dense_update(this, input, learn_rate, is_train, avg_deltas)
    class(DenseLayer)             :: this
    real(kind=8), intent(in)      :: input(:,:)
    real, intent(in)              :: learn_rate
    logical, intent(in)           :: is_train, avg_deltas
    real(kind=8), allocatable     :: avg_change_row(:), delta_w(:,:)
    real(kind=8)                  :: scale
    integer                       :: r

    ! multiply deltas by learn_rate
    scale = learn_rate

    ! if avg_deltas, find average across batch
    if (avg_deltas) then
        scale = scale / this%batch_size
    end if

    ! weights:
    ! w = w - avg_change (also handling dropout)
    ! avg_change = matmul(transpose(a(l-1)), delta(l)) * scale
    if (this%drop_rate > 0 .and. is_train) then
        call this%dense_dropout_rand() ! randomize dropout
        call dgemm_wrapper(input*this%drop, this%d, delta_w, transa=.true.)
    else
        call dgemm_wrapper(input, this%d, delta_w, transa=.true.) ! no drops
    end if

    delta_w = delta_w * scale
    this%w = this%w - delta_w

    ! biases:
    ! each row in the deltas corresponds to one example
    ! in the batch. we want to update each example's biases
    ! by the same amount, so we find the average row
    ! in the batch (the vector of col-averages across the batch)
    !
    ! b = (each row of b) - avg_change_row
    ! avg_change_row = col_sums(delta(l)) * scale;
    !
    ! unfortunately, this specific location gives an -Wuninitialized warning,
    ! but this behavior is defined in the allocatable standard (and used
    ! throughout the rest of this code with no warnings).
    ! copy/pasting this line to each of the if/else branches above removes the
    ! warning, but I think makes the code more convoluted...
    avg_change_row = sum(this%d, dim=1) * scale ! dim=1 finds col sums

    ! update each row of b
    do r = 1, this%batch_size
        this%b(r,:) = this%b(r,:) - avg_change_row
    end do

    ! traverse next layers
    if (associated(this%next_layer)) then
        call this%next_layer%dense_update(this%a, learn_rate, is_train, &
                                          avg_deltas)
    end if
end subroutine
end module


program tst_bim
use constants
implicit none
integer, parameter :: dp = selected_real_kind(15,307)
! program to calculate tst rate
real (dp) :: deltag,rate,temp,deg,corr
! read deltag (in kcal/mol) and temperature (in K)
read(*,*) deltag,temp,deg
corr=ratm*temp
rate=deg*boltz*temp/planck*exp(-deltag/r/temp)
! rate in s-1
print*, rate*corr

end program tst_bim


      SUBROUTINE SB02ND( DICO, FACT, UPLO, JOBL, N, M, P, A, LDA, B,
     $                   LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F,
     $                   LDF, OUFACT, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the optimal feedback matrix F for the problem of
C     optimal control given by
C
C                        -1
C          F = (R + B'XB)  (B'XA + L')                           (1)
C
C     in the discrete-time case and
C
C               -1
C          F = R  (B'X + L')                                     (2)
C
C     in the continuous-time case, where A, B and L are N-by-N, N-by-M
C     and N-by-M matrices respectively; R and X are M-by-M and N-by-N
C     symmetric matrices respectively.
C
C     Optionally, matrix R may be specified in a factored form, and L
C     may be zero.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the equation from which F is to be determined,
C             as follows:
C             = 'D':  Equation (1), discrete-time case;
C             = 'C':  Equation (2), continuous-time case.
C
C     FACT    CHARACTER*1
C             Specifies how the matrix R is given (factored or not), as
C             follows:
C             = 'N':  Array R contains the matrix R;
C             = 'D':  Array R contains a P-by-M matrix D, where R = D'D;
C             = 'C':  Array R contains the Cholesky factor of R;
C             = 'U':  Array R contains the symmetric indefinite UdU' or
C                     LdL' factorization of R. This option is not
C                     available for DICO = 'D'.
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the possibly factored matrix R
C             (or R + B'XB, on exit) is or should be stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     JOBL    CHARACTER*1
C             Specifies whether or not the matrix L is zero, as follows:
C             = 'Z':  L is zero;
C             = 'N':  L is nonzero.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and X.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C             This parameter must be specified only for FACT = 'D'.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             If DICO = 'D', the leading N-by-N part of this array must
C             contain the state matrix A of the system.
C             If DICO = 'C', this array is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= MAX(1,N) if DICO = 'D';
C             LDA >= 1        if DICO = 'C'.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input matrix B of the system.
C             If DICO = 'D' and FACT = 'D' or 'C', the contents of this
C             array is destroyed.
C             Otherwise, B is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry, if FACT = 'N', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the upper
C             triangular part or lower triangular part, respectively,
C             of the symmetric input weighting matrix R.
C             On entry, if FACT = 'D', the leading P-by-M part of this
C             array must contain the direct transmission matrix D of the
C             system.
C             On entry, if FACT = 'C', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the Cholesky
C             factor of the positive definite input weighting matrix R
C             (as produced by LAPACK routine DPOTRF).
C             On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M
C             upper triangular part (if UPLO = 'U') or lower triangular
C             part (if UPLO = 'L') of this array must contain the
C             factors of the UdU' or LdL' factorization, respectively,
C             of the symmetric indefinite input weighting matrix R (as
C             produced by LAPACK routine DSYTRF).
C             The stricly lower triangular part (if UPLO = 'U') or
C             stricly upper triangular part (if UPLO = 'L') of this
C             array is used as workspace.
C             On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the Cholesky factor of the given input weighting
C             matrix (for DICO = 'C'), or that of the matrix R + B'XB
C             (for DICO = 'D').
C             On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the factors of the UdU' or LdL' factorization,
C             respectively, of the given input weighting matrix
C             (for DICO = 'C'), or that of the matrix R + B'XB
C             (for DICO = 'D').
C             On exit R is unchanged if FACT = 'U'.
C
C     LDR     INTEGER.
C             The leading dimension of the array R.
C             LDR >= MAX(1,M)   if FACT <> 'D';
C             LDR >= MAX(1,M,P) if FACT =  'D'.
C
C     IPIV    (input/output) INTEGER array, dimension (M)
C             On entry, if FACT = 'U', this array must contain details
C             of the interchanges performed and the block structure of
C             the d factor in the UdU' or LdL' factorization of matrix R
C             (as produced by LAPACK routine DSYTRF).
C             On exit, if OUFACT(1) = 2, this array contains details of
C             the interchanges performed and the block structure of the
C             d factor in the UdU' or LdL' factorization of matrix R (or
C             D'D) or R + B'XB (or D'D + B'XB), as produced by LAPACK
C             routine DSYTRF.
C             This array is not referenced for DICO = 'D' or FACT = 'D',
C             or 'C'.
C
C     L       (input) DOUBLE PRECISION array, dimension (LDL,M)
C             If JOBL = 'N', the leading N-by-M part of this array must
C             contain the cross weighting matrix L.
C             If JOBL = 'Z', this array is not referenced.
C
C     LDL     INTEGER
C             The leading dimension of array L.
C             LDL >= MAX(1,N) if JOBL = 'N';
C             LDL >= 1        if JOBL = 'Z'.
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, the leading N-by-N part of this array must
C             contain the solution matrix X of the algebraic Riccati
C             equation as produced by SLICOT Library routines SB02MD or
C             SB02OD. Matrix X is assumed non-negative definite.
C             On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 1,
C             and INFO = 0, the N-by-N upper triangular part of this
C             array contains the Cholesky factor of the given matrix X,
C             which is found to be positive definite.
C             On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2,
C             and INFO = 0, the leading N-by-N part of this array
C             contains the matrix of orthonormal eigenvectors of X.
C             On exit X is unchanged if DICO = 'C' or FACT = 'N'.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= MAX(1,N).
C
C     RNORM   (input) DOUBLE PRECISION
C             If FACT = 'U', this parameter must contain the 1-norm of
C             the original matrix R (before factoring it).
C             Otherwise, this parameter is not used.
C
C     F       (output) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading M-by-N part of this array contains the
C             optimal feedback matrix F.
C
C     LDF     INTEGER
C             The leading dimension of array F.  LDF >= MAX(1,M).
C
C     OUFACT  (output) INTEGER array, dimension (2)
C             Information about the factorization finally used.
C             OUFACT(1) = 1:  Cholesky factorization of R (or R + B'XB)
C                             has been used;
C             OUFACT(1) = 2:  UdU' (if UPLO = 'U') or LdL' (if UPLO =
C                             'L') factorization of R (or R + B'XB)
C                             has been used;
C             OUFACT(2) = 1:  Cholesky factorization of X has been used;
C             OUFACT(2) = 2:  Spectral factorization of X has been used.
C             The value of OUFACT(2) is not set for DICO = 'C' or for
C             DICO = 'D' and FACT = 'N'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and DWORK(2) contains the reciprocal condition
C             number of the matrix R (for DICO = 'C') or of R + B'XB
C             (for DICO = 'D').
C             If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),...,
C             DWORK(N+2) contain the eigenvalues of X, in ascending
C             order.
C
C     LDWORK  INTEGER
C             Dimension of working array DWORK.
C             LDWORK >= max(2,3*M)         if FACT = 'N';
C             LDWORK >= max(2,2*M)         if FACT = 'U';
C             LDWORK >= max(2,3*M)         if FACT = 'C', DICO = 'C';
C             LDWORK >= N+3*M+2            if FACT = 'C', DICO = 'D';
C             LDWORK >= max(2,min(P,M)+M)  if FACT = 'D', DICO = 'C';
C             LDWORK >= max(N+3*M+2,4*N+1) if FACT = 'D', DICO = 'D'.
C             For optimum performance LDWORK should be larger.
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             = i:  if the i-th element of the d factor is exactly zero;
C                   the UdU' (or LdL') factorization has been completed,
C                   but the block diagonal matrix d is exactly singular;
C             = M+1:  if the matrix R (if DICO = 'C'), or R + B'XB
C                   (if DICO = 'D') is numerically singular (to working
C                   precision);
C             = M+2:  if one or more of the eigenvalues of X has not
C                   converged.
C
C     METHOD
C
C     The optimal feedback matrix F is obtained as the solution to the
C     system of linear equations
C
C        (R + B'XB) * F = B'XA + L'
C
C     in the discrete-time case and
C
C        R * F = B'X + L'
C
C     in the continuous-time case, with R replaced by D'D if FACT = 'D'.
C     The factored form of R, specified by FACT <> 'N', is taken into
C     account. If FACT = 'N', Cholesky factorization is tried first, but
C     if the coefficient matrix is not positive definite, then UdU' (or
C     LdL') factorization is used. The discrete-time case involves
C     updating of a triangular factorization of R (or D'D); Cholesky or
C     symmetric spectral factorization of X is employed to avoid
C     squaring of the condition number of the matrix. When D is given,
C     its QR factorization is determined, and the triangular factor is
C     used as described above.
C
C     NUMERICAL ASPECTS
C
C     The algorithm consists of numerically stable steps.
C                                    3     2
C     For DICO = 'C', it requires O(m  + mn ) floating point operations
C                           2
C     if FACT = 'N' and O(mn ) floating point operations, otherwise.
C     For DICO = 'D', the operation counts are similar, but additional
C        3
C     O(n ) floating point operations may be needed in the worst case.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C     Supersedes Release 2.0 routine SB02BD by M. Vanbegin, and
C     P. Van Dooren, Philips Research Laboratory, Brussels, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, matrix algebra, optimal control,
C     optimal regulator.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, FACT, JOBL, UPLO
      INTEGER           INFO, LDA, LDB, LDF, LDL, LDR, LDWORK, LDX, M,
     $                  N, P
      DOUBLE PRECISION  RNORM
C     .. Array Arguments ..
      INTEGER           IPIV(*), IWORK(*), OUFACT(2)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*),
     $                  L(LDL,*), R(LDR,*), X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           DISCR, LFACTA, LFACTC, LFACTD, LFACTU, LUPLOU,
     $                  WITHL
      INTEGER           I, IFAIL, ITAU, J, JW, JWORK, JZ, WRKOPT
      DOUBLE PRECISION  EPS, RCOND, RNORMP, TEMP
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANSY
      EXTERNAL          DLAMCH, DLANSY, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DGEQRF, DLASET, DPOCON,
     $                  DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, DSYTRF,
     $                  DSYTRS, DTRCON, DTRMM, MB04KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      INFO = 0
      DISCR  = LSAME( DICO, 'D' )
      LFACTC = LSAME( FACT, 'C' )
      LFACTD = LSAME( FACT, 'D' )
      LFACTU = LSAME( FACT, 'U' )
      LUPLOU = LSAME( UPLO, 'U' )
      WITHL  = LSAME( JOBL, 'N' )
      LFACTA = LFACTC.OR.LFACTD.OR.LFACTU
C
C     Test the input scalar arguments.
C
      IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) .OR.
     $         ( DISCR .AND. LFACTU ) ) THEN
         INFO = -2
      ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( P.LT.0 ) THEN
         INFO = -7
      ELSE IF( ( .NOT.DISCR .AND. LDA.LT.1 )             .OR.
     $         (      DISCR .AND. LDA.LT.MAX( 1, N ) ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( (              LDR.LT.MAX( 1, M ) )   .OR.
     $         ( LFACTD .AND. LDR.LT.MAX( 1, P ) ) ) THEN
         INFO = -13
      ELSE IF( ( .NOT.WITHL .AND. LDL.LT.1 )             .OR.
     $         (      WITHL .AND. LDL.LT.MAX( 1, N ) ) ) THEN
         INFO = -16
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -18
      ELSE IF( LFACTU ) THEN
         IF( RNORM.LT.ZERO )
     $      INFO = -19
      END IF
      IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -21
      ELSE IF( ( ( .NOT.LFACTA .OR. ( LFACTC .AND. .NOT.DISCR ) )
     $                         .AND. LDWORK.LT.MAX( 2, 3*M ) ) .OR.
     $         (        LFACTU .AND. LDWORK.LT.MAX( 2, 2*M ) ) .OR.
     $    ( DISCR .AND. LFACTC .AND. LDWORK.LT.N + 3*M + 2 )   .OR.
     $(.NOT.DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( 2, MIN(P,M) + M ) )
     $                                                         .OR.
     $    ( DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( N + 3*M + 2,
     $                                              4*N + 1 ) ) ) THEN
         INFO = -25
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. M.EQ.0 .OR. ( LFACTD .AND. P.EQ.0 ) ) THEN
        DWORK(1) = ONE
        DWORK(2) = ONE
        RETURN
      END IF
C
      WRKOPT = 1
      EPS = DLAMCH( 'Epsilon' )
C
C     Determine the right-hand side of the matrix equation.
C     Compute  B'X  in F.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      CALL DGEMM( 'Transpose', 'No transpose', M, N, N, ONE, B, LDB, X,
     $            LDX, ZERO, F, LDF )
C
      IF ( .NOT.LFACTA ) THEN
         IF ( DISCR ) THEN
C
C           Discrete-time case with R not factored. Compute R + B'XB.
C
            IF ( LUPLOU ) THEN
C
               DO 10 J = 1, M
                  CALL DGEMV( 'No transpose', J, N, ONE, F, LDF, B(1,J),
     $                        1, ONE, R(1,J), 1 )
   10          CONTINUE
C
            ELSE
C
               DO 20 J = 1, M
                  CALL DGEMV( 'Transpose', N, J, ONE, B, LDB, F(J,1),
     $                        LDF, ONE, R(J,1), LDR )
   20          CONTINUE
C
            END IF
         END IF
C
C        Compute the 1-norm of the matrix  R  or  R + B'XB.
C        Workspace: need M.
C
         RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK )
         WRKOPT = MAX( WRKOPT, M )
      END IF
C
      IF ( DISCR ) THEN
C
C        For discrete-time case, postmultiply B'X by A.
C        Workspace: need N.
C
         DO 30 I = 1, M
            CALL DCOPY( N, F(I,1), LDF, DWORK, 1 )
            CALL DGEMV( 'Transpose', N, N, ONE, A, LDA, DWORK, 1, ZERO,
     $                  F(I,1), LDF )
   30    CONTINUE
C
         WRKOPT = MAX( WRKOPT, N )
      END IF
C
      IF( WITHL ) THEN
C
C        Add L'.
C
         DO 50 I = 1, M
C
            DO 40 J = 1, N
               F(I,J) = F(I,J) + L(J,I)
   40       CONTINUE
C
   50    CONTINUE
C
      END IF
C
C     Solve the matrix equation.
C
      IF ( LFACTA ) THEN
C
C        Case 1: Matrix R is given in a factored form.
C
         IF ( LFACTD ) THEN
C
C           Use QR factorization of D.
C           Workspace: need   min(P,M) + M,
C                      prefer min(P,M) + M*NB.
C
            ITAU = 1
            JWORK = ITAU + MIN( P, M )
            CALL DGEQRF( P, M, R, LDR, DWORK(ITAU), DWORK(JWORK),
     $                   LDWORK-JWORK+1, IFAIL )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C           Make positive the diagonal elements of the triangular
C           factor. Construct the strictly lower triangle, if requested.
C
            DO 70 I = 1, M
               IF ( R(I,I).LT.ZERO ) THEN
C
                  DO 60 J = I, M
                     R(I,J) = -R(I,J)
   60             CONTINUE
C
               END IF
               IF ( .NOT.LUPLOU )
     $            CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR )
   70       CONTINUE
C
            IF ( P.LT.M ) THEN
               CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR )
               IF ( .NOT.DISCR ) THEN
                  DWORK(2) = ZERO
                  INFO = M + 1
                  RETURN
               END IF
            END IF
         END IF
C
         JW = 1
         IF ( DISCR ) THEN
C
C           Discrete-time case. Update the factorization for B'XB.
C           Try first the Cholesky factorization of X, saving the
C           diagonal of X, in order to recover it, if X is not positive
C           definite. In the later case, use spectral factorization.
C           Workspace: need N.
C           Define     JW = 1   for Cholesky factorization of X,
C                      JW = N+3 for spectral factorization of X.
C
            CALL DCOPY( N, X, LDX+1, DWORK, 1 )
            CALL DPOTRF( 'Upper', N, X, LDX, IFAIL )
            IF ( IFAIL.EQ.0 ) THEN
C
C              Use Cholesky factorization of X to compute chol(X)*B.
C
               OUFACT(2) = 1
               CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non unit',
     $                     N, M, ONE, X, LDX, B, LDB )
            ELSE
C
C              Use spectral factorization of X, X = UVU'.
C              Workspace: need   4*N+1,
C                         prefer N*(NB+2)+N+2.
C
               JW = N + 3
               OUFACT(2) = 2
               CALL DCOPY( N, DWORK, 1, X, LDX+1 )
               CALL DSYEV( 'Vectors', 'Lower', N, X, LDX, DWORK(3),
     $                     DWORK(JW), LDWORK-JW+1, IFAIL )
               IF ( IFAIL.GT.0 ) THEN
                  INFO = M + 2
                  RETURN
               END IF
               WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 )
               TEMP = ABS( DWORK(N+2) )*EPS
C
C              Count the negligible eigenvalues and compute sqrt(V)U'B.
C              Workspace: need 2*N+2.
C
               JZ = 0
C
   80          CONTINUE
               IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN
                  JZ = JZ + 1
                  IF ( JZ.LT.N) GO TO 80
               END IF
C
               DO 90 J = 1, M
                  CALL DCOPY( N, B(1,J), 1, DWORK(JW), 1 )
                  CALL DGEMV( 'Transpose', N, N, ONE, X, LDX, DWORK(JW),
     $                        1, ZERO, B(1,J), 1 )
   90          CONTINUE
C
               DO 100 I = JZ + 1, N
                  CALL DSCAL( M, SQRT( ABS( DWORK(I+2) ) ), B(I,1), LDB
     $                      )
  100          CONTINUE
C
               IF ( JZ.GT.0 )
     $            CALL DLASET( 'Full', JZ, M, ZERO, ZERO, B, LDB )
            END IF
C
C           Update the triangular factorization.
C
            IF ( .NOT.LUPLOU ) THEN
C
C              For efficiency, use the transposed of the lower triangle.
C
               DO 110 I = 2, M
                  CALL DCOPY( I-1, R(I,1), LDR, R(1,I), 1 )
  110          CONTINUE
C
            END IF
C
C           Workspace: need JW+2*M-1.
C
            CALL MB04KD( 'Full', M, 0, N, R, LDR, B, LDB, DUMMY, N,
     $                   DUMMY, M, DWORK(JW), DWORK(JW+N) )
            WRKOPT = MAX( WRKOPT, JW + 2*M - 1 )
C
C           Make positive the diagonal elements of the triangular
C           factor.
C
            DO 130 I = 1, M
               IF ( R(I,I).LT.ZERO ) THEN
C
                  DO 120 J = I, M
                     R(I,J) = -R(I,J)
  120             CONTINUE
C
               END IF
  130       CONTINUE
C
            IF ( .NOT.LUPLOU ) THEN
C
C              Construct the lower triangle.
C
               DO 140 I = 2, M
                  CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR )
  140          CONTINUE
C
            END IF
         END IF
C
C        Compute the condition number of the coefficient matrix.
C
         IF ( .NOT.LFACTU ) THEN
C
C           Workspace: need JW+3*M-1.
C
            CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND,
     $                    DWORK(JW), IWORK, IFAIL )
            OUFACT(1) = 1
            WRKOPT = MAX( WRKOPT, JW + 3*M - 1 )
         ELSE
C
C           Workspace: need 2*M.
C
            CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK,
     $                   IWORK, INFO )
            OUFACT(1) = 2
            WRKOPT = MAX( WRKOPT, 2*M )
         END IF
         DWORK(2) = RCOND
         IF( RCOND.LT.EPS ) THEN
            INFO = M + 1
            RETURN
         END IF
C
      ELSE
C
C        Case 2: Matrix R is given in an unfactored form.
C
C        Save the given triangle of  R  or  R + B'XB  in the other
C        strict triangle and the diagonal in the workspace, and try
C        Cholesky factorization.
C        Workspace: need M.
C
         CALL DCOPY( M, R, LDR+1, DWORK, 1 )
         IF( LUPLOU ) THEN
C
            DO 150 J = 2, M
               CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR )
  150       CONTINUE
C
         ELSE
C
            DO 160 J = 2, M
               CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 )
  160       CONTINUE
C
         END IF
         CALL DPOTRF( UPLO, M, R, LDR, INFO )
         OUFACT(1) = 1
         IF( INFO.EQ.0 ) THEN
C
C           Compute the reciprocal of the condition number of R.
C           Workspace: need 3*M.
C
            CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK,
     $                   INFO )
C
C           Return if the matrix is singular to working precision.
C
            DWORK(2) = RCOND
            IF( RCOND.LT.EPS ) THEN
               INFO = M + 1
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, 3*M )
         ELSE
C
C           Use UdU' or LdL' factorization, first restoring the saved
C           triangle.
C
            CALL DCOPY( M, DWORK, 1, R, LDR+1 )
            IF( LUPLOU ) THEN
C
               DO 170 J = 2, M
                  CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 )
  170          CONTINUE
C
            ELSE
C
               DO 180 J = 2, M
                  CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR )
  180          CONTINUE
C
            END IF
C
C           Workspace: need   1,
C                      prefer M*NB.
C
            CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO )
            OUFACT(1) = 2
            IF( INFO.GT.0 )
     $         RETURN
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C           Compute the reciprocal of the condition number of R.
C           Workspace: need   2*M.
C
            CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK,
     $                   IWORK, INFO )
C
C           Return if the matrix is singular to working precision.
C
            DWORK(2) = RCOND
            IF( RCOND.LT.EPS ) THEN
               INFO = M + 1
               RETURN
            END IF
         END IF
      END IF
C
      IF (OUFACT(1).EQ.1 ) THEN
C
C        Solve the positive definite linear system.
C
         CALL DPOTRS( UPLO, M, N, R, LDR, F, LDF, INFO )
      ELSE
C
C        Solve the indefinite linear system.
C
         CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, F, LDF, INFO )
      END IF
C
C     Set the optimal workspace.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SB02ND ***
      END


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   r3b :    The Restricted 3-Body Problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

 SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
   DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
   DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,*), DFDP(NDIM,*)

   DOUBLE PRECISION x,y,z,xp,yp,zp,rl,rmu,dE,dM,rmc,dE3,dM3

   x  = U(1)
   y  = U(2)
   z  = U(3)
   xp = U(4)
   yp = U(5)
   zp = U(6)

   rl  = PAR(1)
   rmu = PAR(2)

   dE  = SQRT((x+rmu)**2 + y**2 + z**2)
   dM  = SQRT( (x-1+rmu)**2 + y**2 + z**2 )
   rmc = 1 - rmu
   dE3 = 1./dE**3
   dM3 = 1./dM**3

   F(1)= xp
   F(2)= yp
   F(3)= zp
   F(4)= 2*yp + x - rmc*dE3*(x+rmu) - rmu*dM3*(x-1+rmu) + rl*xp
   F(5)=-2*xp + y - rmc*dE3*y       - rmu*dM3*y         + rl*yp
   F(6)=          - rmc*dE3*z       - rmu*dM3*z         + rl*zp

 END SUBROUTINE FUNC
!----------------------------------------------------------------------
 SUBROUTINE STPNT(NDIM,U,PAR,T)
!---------- -----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM
   DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM), PAR(*)
   DOUBLE PRECISION, INTENT(IN) :: T

   DOUBLE PRECISION rl,rmu

   rl  =  0.
   rmu =  0.

   PAR(:2) = (/ rl, rmu /)

   U = (/ 0.14107D0, 0.99D0, 0D0, 0D0, 0D0, 0D0 /)

 END SUBROUTINE STPNT
!----------------------------------------------------------------------
 SUBROUTINE PVLS(NDIM,U,PAR)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
   DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

   DOUBLE PRECISION GETP,rmu,x,y,z,xp,yp,zp,d1,d2,EU,E,realfm,imagfm,ncmplx
   DOUBLE PRECISION routh,pi
   INTEGER i,j

   rmu = PAR(2)

   x  = U(1)
   y  = U(2)
   z  = U(3)
   xp = U(4)
   yp = U(5)
   zp = U(6)

   d1 = SQRT((x+rmu)**2 + y**2 + z**2)
   d2 = SQRT( (x-1+rmu)**2 + y**2 + z**2 )

   EU = (x**2 + y**2)/2 + (1-rmu)/d1 + rmu/d2
   E  = (xp**2 + yp**2 + zp**2)/2 - EU - rmu*(1-rmu)/2
   PAR(3) = E
   PAR(16)=y

! Maximum real Floquet multiplier: PAR(4)
! If there are two real multipliers with absolute value > 1
! then PAR(4)=0.

   PAR(4) = 0
   ncmplx = 0
   DO i=1,NDIM
      imagfm = GETP('EIG',I*2,U)
      IF (imagfm == 0) THEN
         realfm = GETP('EIG',I*2-1,U)
         IF (ABS(realfm) > ABS(PAR(4))) THEN
            PAR(4) = realfm
         ENDIF
      ELSE
         ncmplx = ncmplx + 1
      ENDIF
   ENDDO
   IF (ncmplx == 0) THEN
      ! no complex multipliers mean 6 real multipliers: 1,1, two with
      ! absolute value greater than 1 and two less than one
      PAR(4) = 0
   ELSEIF (ncmplx == 4) THEN
      ! all non-trivial multipliers complex: must be 1 without rounding
      ! errors
      PAR(4) = 1
   ENDIF

!  Put purely imaginary eigenvalues in PAR(5), PAR(6) and PAR(7)

   j=1
   PAR(5) = 0
   PAR(6) = 0
   PAR(7) = 0
   pi = 4*ATAN(1d0)
   DO i=1,NDIM
      imagfm = GETP('EIG',I*2,U)
      IF (imagfm > 1d-5) THEN
         realfm = GETP('EIG',I*2-1,U)
         routh = 0.5d0*(1d0-sqrt(69d0)/9d0)
         ! above Routh's ratio we have one period for L4/L5, otherwise 3.
         IF (ABS(realfm) < EPSILON(1d0) .OR. rmu < routh .OR. ABS(y) < 0.1) THEN
            PAR(4+j) = 2*pi/imagfm
            j=j+1
         ENDIF
      ENDIF
   ENDDO

 END SUBROUTINE PVLS
!----------------------------------------------------------------------
!----------------------------------------------------------------------
 SUBROUTINE BCND
 END SUBROUTINE BCND

 SUBROUTINE ICND
 END SUBROUTINE ICND

 SUBROUTINE FOPT
 END SUBROUTINE FOPT
!----------------------------------------------------------------------
!----------------------------------------------------------------------


      SUBROUTINE tool_invrt(latt,rlatt,det)

      implicit none

      real*8 latt,rlatt,det

      dimension latt(3,3),rlatt(3,3)

      rlatt(1,1)=latt(2,2)*latt(3,3)-latt(3,2)*latt(2,3)
      rlatt(2,1)=latt(3,1)*latt(2,3)-latt(2,1)*latt(3,3)
      rlatt(3,1)=latt(2,1)*latt(3,2)-latt(3,1)*latt(2,2)
      rlatt(1,2)=latt(3,2)*latt(1,3)-latt(1,2)*latt(3,3)
      rlatt(2,2)=latt(1,1)*latt(3,3)-latt(3,1)*latt(1,3)
      rlatt(3,2)=latt(3,1)*latt(1,2)-latt(1,1)*latt(3,2)
      rlatt(1,3)=latt(1,2)*latt(2,3)-latt(2,2)*latt(1,3)
      rlatt(2,3)=latt(2,1)*latt(1,3)-latt(1,1)*latt(2,3)
      rlatt(3,3)=latt(1,1)*latt(2,2)-latt(2,1)*latt(1,2)

      det=latt(1,1)*rlatt(1,1)+latt(1,2)*rlatt(2,1)+latt(1,3)*rlatt(3,1)
      if(abs(det).gt.0.d0)det=1.d0/det

      rlatt(1,1)=det*rlatt(1,1)
      rlatt(2,1)=det*rlatt(2,1)
      rlatt(3,1)=det*rlatt(3,1)
      rlatt(1,2)=det*rlatt(1,2)
      rlatt(2,2)=det*rlatt(2,2)
      rlatt(3,2)=det*rlatt(3,2)
      rlatt(1,3)=det*rlatt(1,3)
      rlatt(2,3)=det*rlatt(2,3)
      rlatt(3,3)=det*rlatt(3,3)

      return

      end
c $Id$


integer function fib(n)
  integer, intent(in) :: n
  if (n < 0 ) then
    write (*,*) 'Bad argument: fib(',n,')'
    stop
  else
    fib = purefib(n)
  end if
contains
  recursive pure integer function purefib(n) result(f)
    integer, intent(in) :: n
    if (n < 2 ) then
      f = n
    else
      f = purefib(n-1) + purefib(n-2)
    end if
  end function purefib
end function fib


module initial_stress_condition

  use common, only : wp

  implicit none

contains
  subroutine initial_stress_tensor(s0,x,problem,Mat)

    ! s0 = (/sxx0,syy0,szz0,sxy0,sxz0,syz0 /)
    !           1    2    3    4    5    6

    implicit none

    real(kind = wp), intent(in) :: x(:)
    real(kind = wp), optional, intent(in) :: Mat(3)
    real(kind = wp) :: Rx,Ry,Rt
    real(kind = wp), intent(out) :: s0(:)
    character(*),intent(in) :: problem
    real(kind = wp) :: Omega, b11, b33, b13, sigma22, Pf, u0, psi
    real(kind = wp),parameter::pi=3.14159265359_wp

    select case(problem)

    case('TPV26')
       if (x(2) .le. 15d0) then
          Omega = 1d0
       elseif (x(2) .ge. 15d0 .and. x(2) .le. 20d0) then
          Omega = (20d0 - x(2))/5d0
       elseif (x(2) .ge. 20d0) then

          Omega = 0d0

       end if

       b11 = 0.926793d0
       b33 = 1.073206d0
       b13 = -0.169029d0

       Pf = 9.8d0*x(2)

       sigma22 = -2.67d0*9.8d0*x(2)

       s0(1) = Omega*(b33*(sigma22 + Pf) - Pf) + (1d0-Omega)*sigma22 + Pf
       s0(2) = sigma22 + Pf
       s0(3) = Omega*(b11*(sigma22 + Pf) - Pf) + (1d0-Omega)*sigma22 + Pf
       s0(4) = 0d0
       s0(5) = Omega*(b13*(sigma22 + Pf))
       s0(6) = 0d0

    case('TPV27')
       if (x(2) .le. 15d0) then
          Omega = 1d0
       elseif (x(2) .ge. 15d0 .and. x(2) .le. 20d0) then
          Omega = (20d0 - x(2))/5d0
       elseif (x(2) .ge. 20d0) then

          Omega = 0d0

       end if

       b11 = 0.926793d0
       b33 = 1.073206d0
       b13 = -0.169029d0

       Pf = 9.8d0*x(2)

       sigma22 = -2.67d0*9.8d0*x(2)

       s0(1) = Omega*(b33*(sigma22 + Pf) - Pf) + (1-Omega)*sigma22 + Pf
       s0(2) = sigma22 + Pf
       s0(3) = Omega*(b11*(sigma22 + Pf) - Pf) + (1-Omega)*sigma22 + Pf
       s0(4) = 0d0
       s0(5) = Omega*(b13*(sigma22 + Pf))
       s0(6) = 0d0

    case('TPV28')
       s0(1) = -60d0
       s0(2) = 0d0
       s0(3) = 60d0
       s0(4) = 0d0
       s0(5) = 29.38d0
       s0(6) = 0d0

    case('TPV29','TPV30')

       if (x(2) .le. 17d0) then
          Omega = 1d0
       elseif (x(2) .ge. 17d0 .and. x(2) .le. 22d0) then
          Omega = (22d0 - x(2))/5d0
       elseif (x(2) .ge. 22d0) then
          Omega = 0d0
       end if

       b11 = 1.025837d0
       b33 = 0.974162d0
       b13 =-0.158649d0

       Pf = 9.8d0*x(2)

       sigma22 = -2.67d0*9.8d0*x(2)

       s0(1) = Omega*(b33*(sigma22 + Pf) - Pf) + (1d0-Omega)*sigma22 + Pf
       s0(2) = sigma22 + Pf
       s0(3) = Omega*(b11*(sigma22 + Pf) - Pf) + (1d0-Omega)*sigma22 + Pf
       s0(4) = 0d0
       s0(5) = Omega*(b13*(sigma22 + Pf))
       s0(6) = 0d0

    case('TPV101', 'TPV102')
       s0(1) = -120d0
       s0(2) = 0d0
       s0(3) = -120d0
       s0(4) = 0d0
       s0(5) = 75d0
       s0(6) = 0d0

    case('TPV31','TPV32')

       u0 = 32.03812032_wp

       s0(1) = -60_wp*Mat(2)/u0
       s0(2) = 0_wp
       s0(3) = -60_wp*Mat(2)/u0
       s0(4) = 0_wp
       s0(5) = 30_wp*Mat(2)/u0
       s0(6) = 0_wp

    case('TPV33')

       if(x(3) < -9.8_wp) then
           Rx = (-x(3)-9.8_wp)/10.0_wp
       elseif(x(3) > 1.1_wp) then
           Rx = (x(3)-1.1_wp)/10.0_wp
       else
           Rx = 0.0_wp
       end if

       if(x(2) < 2.3_wp) then
           Ry = (-x(2)+2.3_wp)/10.0_wp
       elseif(x(2) > 8.0_wp) then
           Ry = (x(2)-8.0_wp)/10.0_wp
       else
           Ry = 0.0_wp
       end if

       Rt = min(1.0_wp,sqrt(Rx**2+Ry**2))

       s0(1) = -60.0_wp
       s0(2) = 0.0_wp
       s0(3) = 0.0_wp
       s0(4) = 0.0_wp
       s0(5) = 30.0_wp*(1_wp-Rt)
       s0(6) = 0.0_wp

    case('TPV34')

       ! Bring in material properties for point, use shear modulus
       u0 = 32.03812032_wp

       s0(1) = -60_wp*Mat(2)/u0
       s0(2) = 0_wp
       s0(3) = -60_wp*Mat(2)/u0
       s0(4) = 0_wp
       s0(5) = 30_wp*Mat(2)/u0
       s0(6) = 0_wp

    case('SCITS2016')

       ! Bring in material properties for point, use shear modulus
       u0 = 32.03812032_wp

       s0(1) = -60_wp*Mat(2)/u0
       s0(2) = 0_wp
       s0(3) = -60_wp*Mat(2)/u0
       s0(4) = 0_wp
       s0(5) = 30_wp*Mat(2)/u0
       s0(6) = 0_wp

    case('rate-weakening')

       psi = 50.0_wp/180.0_wp*pi
       s0(1) = -126.0_wp
       s0(5) = 42.0_wp
       s0(3) = (1.0_wp - 2.0_wp*s0(5)/(s0(1)*tan(2.0_wp*psi)))*s0(1)
       s0(2) = 0.5_wp*(s0(1) + s0(3))
       s0(4) = 0.0_wp
       s0(6) = 0.0_wp

    case('mg_a1')

       s0(1) = -60.0_wp
       s0(2) = 0.0_wp
       s0(3) = -60.0_wp
       s0(4) = 0.0_wp
       s0(5) = 29.38_wp
       s0(6) = 0_wp

    case('mg_b1a')

       s0(1) = -60.0_wp
       s0(2) = 0.0_wp
       s0(3) = -60.0_wp
       s0(4) = 0.0_wp
       s0(5) = 31.0_wp
       s0(6) = 0_wp

    case('TPV10')

       s0(1) = -7.378*x(2)
       s0(2) = 0.0_wp
       s0(3) = - 7.378*x(2)
       s0(4) = 0.0_wp
       s0(5) = -0.55_wp*s0(1)
       s0(6) = 0d0

    case('wasatch100')

       Pf = 9.8d0*(x(2)+2.149d0)
       sigma22=-2.7*9.8d0*(x(2)+2.149d0)

       !print *, x(2)

       !Pf = 9.8d0*(x(2)+0d0*2.781d0)
       !sigma22=-2.7*9.8d0*(x(2)+0d0*2.781d0)
!       Omega=3.3*x(2)

       s0(1) = sigma22+Pf-0.4d0*sigma22
       s0(2) = sigma22+Pf
!       s0(3)=sigma22+Pf+0.25d0*(-0.4d0*sigma22)
       s0(3)=(s0(1)+s0(2))*0.5d0
!       s0(1) = sigma22+Pf+Omega
!       s0(2) = sigma22+Pf
!       s0(3)=sigma22+Pf+0.25d0*Omega
       s0(4) = 0d0
       s0(5) = 0d0
       s0(6) = 0d0

    case default

       stop 'invalid problem in intial stress tensor'

    end select

  end subroutine initial_stress_tensor

end module initial_stress_condition


	subroutine neclumpN(x,y,z,necN,FcN,hitclump)
c returns electron density necN and fluctuation parameter FcN
c at position designated by l,b,d,x,y,z c for a set of
c clumps with parameters read in from file  neclumpN.dat

c input:
c	x,y,z	coordinates	(kpc)  (as in TC93)
c
c output:
c	necN	electron density in clump at (x,y,z)
c	FcN	fluctuation parameter
c 	hitclump = 0:   no clump hit
c		   j>0: j-th clump hit

	implicit none
	real x,y,z,necN,FcN
	integer hitclump

	integer nclumpsmax
	parameter (nclumpsmax=2000)

c	character*15 losname(nclumpsmax)
c	character*1 type(nclumpsmax)
	real lc(nclumpsmax), bc(nclumpsmax), dc(nclumpsmax)
        real xc(nclumpsmax), yc(nclumpsmax), zc(nclumpsmax)
        real nec(nclumpsmax), rc(nclumpsmax), Fc(nclumpsmax)
        integer edge(nclumpsmax)
	integer nclumps
	integer hitclumpflag
	common /clumps/ nclumps, hitclumpflag(nclumpsmax)

c parameters:
c	lc	= galactic longitude of clump center
c	bc	= galactic latitude of clump center
c	(xc,yc,zc) = clump center location (calculated)
c       nec	= internal peak electron density
c	rc	= clump radius at 1/e
c       Fc      = clump fluctuation parameter
c	edge    = 0 => use exponential rolloff out to 5rc
c                 1 => uniform and truncated at 1/e

	real radian
	parameter(radian = 57.29577951)

	real rsun
	parameter (rsun=8.5)

	logical first
	data first/.true./

	real slc, clc, sbc, cbc
	real rgalc

	real arg

	integer luclump
	data luclump/11/
	integer j
	integer clumpflag

	save

c first time through, read input clump parameters and calculate
c LOS quantities.
c lc,bc = Galactic coordinates (deg)
c   nec = clump electron density (cm^{-3})
c    Fc = fluctuation parameter
c    dc = clump distance from Earth (kpc)
c    rc = clump radius (kpc)
c  edge = 0,1  0=> Gaussian, 1=> Gaussian w/ hard edge at e^{-1}
c  type = LOS type (P pulsar, G other Galactic, X extragalactic
c losname = useful name
	if(first) then 		!read clump parameters
	  j=1
c	  write(6,*) 'reading neclumpN.NE2001.dat'
	  open(luclump, file='neclumpN.NE2001.dat', status='old')
	  read(luclump,*)				! label line
    5     read(luclump,*,end=99) clumpflag,lc(j),bc(j),nec(j),Fc(j),
     .           dc(j),rc(j),edge(j)
          if(clumpflag .eq. 0) then
	    slc = sin(lc(j)/radian)
	    clc = cos(lc(j)/radian)
	    sbc = sin(bc(j)/radian)
	    cbc = cos(bc(j)/radian)
	    rgalc = dc(j)*cbc
	    xc(j) = rgalc*slc
	    yc(j) = rsun-rgalc*clc
	    zc(j) = dc(j)*sbc
c	  write(6,"(a15,1x,8(f8.3,1x))")
c    .           losname(j),lc(j),bc(j),dc(j),
c    .           nec(j),Fc(j),xc(j),yc(j),zc(j)
	    j=j+1
	  endif
	  go to 5
   99     continue
	  first = .false.
	  nclumps = j-1
	  close(luclump)
	endif

	necN = 0.
	hitclump = 0
	FcN = 0.
	do j=1,nclumps
	  arg =
     .      ((x-xc(j))**2 + (y-yc(j))**2 + (z-zc(j))**2) / rc(j)**2
	  if(edge(j) .eq. 0 .and. arg .lt. 5.) then
	    necN = necN + nec(j) * exp(-arg)
            FcN = Fc(j)
	    hitclump = j
            hitclumpflag(j) = 1
	  endif
	  if(edge(j) .eq. 1 .and. arg .le. 1.) then
c    	    necN = necN + nec(j) * exp(-arg)
	    necN = necN + nec(j)
            FcN = Fc(j)
	    hitclump = j
            hitclumpflag(j) = 1
	  endif
	enddo

	return
	end


!-----------------------------------------------------------------------------
!> Calculate speed of sound for full (P,T, chemical potential) equilibrium
!>
!>
!>
!-----------------------------------------------------------------------------
module speed_of_sound
  !
  !
  use thermopack_constants, only: VAPPH,LIQPH,SOLIDPH, &
       Rgas, TREND
  use thermopack_var, only: nc, nph, get_active_thermo_model, thermo_model
  implicit none
  private
  save

  public :: sound_velocity_2ph
  public :: twoPhaseSpeedOfSound, singlePhaseSpeedOfSound, solidSpeedOfSound
  public :: speed_of_sound_TV

  include "trend_interface.f95"

contains

  !-----------------------------------------------------------------------------
  !> Calculate speed-of-sound for single-phase flow.
  !>
  !> \author KYL, 2013-10
  !-----------------------------------------------------------------------------
  function singlePhaseSpeedOfSound(t,p,Z,phase) result(sos)
    use eos, only: specificVolume, entropy, moleWeight
    use trend_solver, only: trend_density
    implicit none
    real,                  intent(in) :: t     !< Temperature [K]
    real,                  intent(in) :: p     !< Pressure [Pa]
    real, dimension(nc),   intent(in) :: Z     !< Overall molar compozition [-]
    integer,               intent(in) :: phase !< Phase spec
    real :: sos
    real :: v,dvdt,dvdp
    real :: s,dsdt,dsdp,dtdp
    real :: rho_trend
    type(thermo_model), pointer :: act_mod_ptr

    act_mod_ptr => get_active_thermo_model()
    select case(act_mod_ptr%eoslib)
      case(TREND)
        call trend_density(T,p,z,phase,rho_trend)
        sos = trend_speedofsound(T,rho_trend,z)
      case default
        ! Find s, dsdt_p, dsdp_t, and then dtdp_s
        !
        call entropy(t,p,Z,phase,s,dsdt,dsdp)
        dtdp = -dsdp/dsdt

        !
        ! Find v, dvdt_p, dvdp_t, and then dvdp_s
        !
        call specificVolume(t,p,Z,phase,v,dvdt,dvdp)
        dvdp = dvdp + dvdt*dtdp

        !
        ! Finally find speed of sound
        !
        if (dvdp < 0.0) then
          sos = sqrt(-1000*v*v/(moleWeight(Z)*dvdp))
        else
           sos = 0.0
           ! Tesing process optimisation - close to critical
!           point/saturation line .... supressing warning and continue
!
!           write (*,*) "speed_of_sound:singlePhaseSpeedOfSound, negative drho/dp-term, set to zero"

!           Will probaly crash sooner of later if this close the the
!           two-phase region...

!           call stoperror('speed_of_sound:singlePhaseSpeedOfSound')
        endif
      end select

  end function singlePhaseSpeedOfSound

  !-----------------------------------------------------------------------------
  !> Calculate speed-of-sound for liqid-liquid or gas-liquid mixtures.
  !>
  !> \author MH, 2013-09
  !-----------------------------------------------------------------------------
  function twoPhaseSpeedOfSound(nph,t,p,Z,beta,X,phase) result(sos)
    use state_functions, only: getStateFuncMatrix
    use eos, only: moleWeight
    implicit none
    integer,               intent(in) :: nph   !< Maximum number of phases
    real,                  intent(in) :: t     !< Temperature [K]
    real,                  intent(in) :: p     !< Pressure [Pa]
    real, dimension(nc),   intent(in) :: Z     !< Overall molar compozition [-]
    real, dimension(nph),  intent(in) :: beta  !< Phase molar fraction [-]
    real, dimension(nph,nc), intent(in) :: X     !< Phase molar compozition [-]
    integer, dimension(nph), intent(in) :: phase !< Phase spec
    real :: sos
    ! Locals
    real, dimension(nc+2,nc+2) :: M !< Jacobian matrix
    real, dimension(nc+2) :: RHS !< Right hand side
    real, dimension(2) :: vspec
    integer, dimension(nc+2) :: ipiv
    real, dimension(3*nc) ::  work
    integer :: ifail
    real :: v, dpdv, mw

    vspec = 0.0
    call getStateFuncMatrix(t,p,Z,beta(2),beta(1),X(1,:),X(2,:), &
                            'SV',vspec,M,RHS,phase)
    v = Rgas*t*RHS(nc+2)/p
    RHS(nc+2) = p/(Rgas*t)
    RHS(1:nc+1) = 0.0

    ! lapack routines
    ! symmetric indefinite matrix
    call dsysv('u', nc+2, 1, M, nc+2, ipiv, RHS, nc+2, work, 3*nc, ifail)
    if (ifail /= 0 .or. RHS(nc+2) /= RHS(nc+2)) then
      dpdv = 1.0 ! Force single phase calculation
    else
      mw = moleWeight(Z)
      dpdv = p*RHS(nc+2) ! Convert from d lnP to d P
    endif

    if (dpdv < 0.0) then
      sos = sqrt(-1000*dpdv*v*v/mw)
    else
      ! Use single phase liquid speed of sound
      sos = singlePhaseSpeedOfSound(t,p,Z,LIQPH)
    endif

  end function twoPhaseSpeedOfSound

  !-----------------------------------------------------------------------------
  !> Calculate speed-of-sound for liqid-solid or gas-solid mixtures.
  !>
  !> Equation set considered:
  !> \f{align*}{
  !>   & f(1) = \ln\left(x^F(js)\varphi^F(js)\right) - \ln\left(\varphi^S\right) \\
  !>   & f(2) = \frac{S_{\text{spec}}-S_{\text{mix}}}{R} \\
  !>   & f(3) = \frac{P\left(v_{\text{mix}}-v_{\text{spec}}\right)}{R T} \\
  !> \f}
  !> Variable vector:
  !> \f[
  !>   X^\intercal =  \left[n^F(js),\ln T, \ln P\right]
  !> \f]
  !>
  !> \author MH, 2013-09
  !-----------------------------------------------------------------------------
  function solidSpeedOfSound(t,p,Z,betaF,Xf,Xs,phase) result(sos)
    use eos, only: moleWeight, thermo, entropy, specificVolume
    use solideos, only: solid_thermo, solid_entropy, &
         solid_specificVolume
    implicit none
    real, intent(in) :: betaF !< Fluid phase molar fraction [-]
    real, dimension(nc), intent(in) :: Z !< Overall molar compozition [-]
    real, dimension(nc), intent(in) :: Xf !< Fluid molar compozition [-]
    real, dimension(nc), intent(in) :: Xs !< Solid molar compozition [-]
    real, intent(in) :: t !< Temperature [K]
    real, intent(in) :: p !< Pressure [Pa]
    integer, intent(in) :: phase !< Fluid phase integer
    real :: sos
    ! Locals
    real, dimension(3,3) :: M !< Jacobian matrix
    real, dimension(3) :: RHS !< Right hand side
    integer, dimension(3) :: ipiv
    real, dimension(9) :: work
    integer :: ifail, js
    integer, dimension(1) :: imax
    real :: mw,ss,dssdt,s,dsdt,lnphis,lnphist,lnphisp
    real :: v,dvdt,dvdp,vs,dvsdt,dvsdp,dpdv
    real, dimension(nc) :: lnphi,lnphiT,lnphiP
    real, dimension(nc,nc) :: lnphiX
    !
    imax = maxloc(Xs)
    js = imax(1)

    ! Solid properties
    call solid_thermo(t,p,Xs,lnphis,lnphist,lnphisp)
    call solid_entropy(t,p,Xs,ss,dssdt)
    call solid_specificVolume(t,p,Xs,vs,dvsdt,dvsdp)

    ! Fluid properties
    call thermo(t,p,Xf,phase,lnphi,lnFUGX=lnphiX,lnfugt=lnphiT,lnfugp=lnphiP) ! ln phi
    call entropy(t,p,Xf,phase,s,dsdt=dsdt)
    call specificVolume(t,p,Xf,phase,v,dvdt=dvdt,dvdp=dvdp)

    ! Variable Xf(js), ln T, ln P
    M(1,1) = (1.0/(XF(js)*betaF) - 1.0/betaF + lnphiX(js,js)/betaF)
    M(1,2) = T*(lnphiT(js) - lnphisT)
    M(1,3) = P*(lnphiP(js) - lnphisP)
    M(2,1) = M(1,2)
    M(3,1) = M(1,3)

    dsdt = T*(betaF*dsdt + (1.0-betaF)*dssdt)
    M(2,2) = -dsdt/Rgas

    v = betaF*v + (1.0-betaF)*vs
    dVdp = betaF*dvdp + (1.0-betaF)*dvsdp
    dVdt = betaF*dvsdt + (1.0-betaF)*dvsdt
    M(3,3) = p*p*dVdp/(Rgas*t)
    M(2,3) = p*dVdt/Rgas
    M(3,2) = M(2,3)

    ! Right hand side
    RHS(3) = p/(Rgas*t)
    RHS(1:2) = 0.0

    ! lapack routines
    ! symmetric indefinite matrix
    call dsysv('u', 3, 1, M, 3, ipiv, RHS, 3, work, 9, ifail)
    if (ifail .ne. 0) then
      call stoperror('Matrix error in speed_of_sound::solidSpeedOfSound')
    endif

    mw = moleWeight(Z)
    dpdv = p*RHS(3) ! Convert from d lnP to d P
    sos = sqrt(-1000*dpdv*v*v/mw)

  end function solidSpeedOfSound

  !-----------------------------------------------------------------------------
  !> Calculate speed of sound for single phase or gas-liquid. Alternative
  !! interface to sound_velocity.
  !!
  !! \author MH, 2014-05
  !-----------------------------------------------------------------------------
  function sound_velocity_2ph(t,p,X,Y,Z,betaV,betaL,phase,ph) result(sos)
    use thermopack_constants, only: TWOPH,VAPPH,LIQPH,SINGLEPH
    implicit none
    real,                   intent(in) :: t     !< Temperature [K]
    real,                   intent(in) :: p     !< Pressure [Pa]
    real, dimension(nc),    intent(in) :: Z     !< Overall molar compozition [-]
    real,                   intent(in) :: betaV !< Vapor molar fraction [-]
    real,                   intent(in) :: betaL !< Liquid molar fraction [-]
    real, dimension(nc),    intent(in) :: X     !< Liquid molar compozition [-]
    real, dimension(nc),    intent(in) :: Y     !< Vapor molar compozition [-]
    integer,                intent(in) :: phase !< Phase spec
    integer, dimension(2), optional, intent(in) :: ph !< Override phase integers
    real :: sos !< Speed of sound [m/s]
    ! Locals
    real, dimension(2) :: betaVec
    real, dimension(2,nc) :: XVec
    integer, dimension(2) :: phaseVec

    if (phase == TWOPH) then
      ! Gas-Liquid speed of sound
      betaVec(1) = betaV
      XVec(1,:) = Y
      betaVec(2) = betaL
      XVec(2,:) = X
      if (present(ph)) then
        if (ph(1) == SINGLEPH) then
          phaseVec(1) = LIQPH
        else
          phaseVec(1) = ph(1)
        endif
        if (ph(2) == SINGLEPH) then
          phaseVec(2) = LIQPH
        else
          phaseVec(2) = ph(2)
        endif
      else
        phaseVec(1) = VAPPH
        phaseVec(2) = LIQPH
      endif
      sos = twoPhaseSpeedOfSound(2,t,p,Z,betaVec,XVec,phaseVec)
    else
      if (phase == SINGLEPH) then
        sos = singlePhaseSpeedOfSound(t,p,Z,LIQPH)
      else
        sos = singlePhaseSpeedOfSound(t,p,Z,phase)
      endif
    endif
  end function sound_velocity_2ph

  !> Calculate speed of sound for single phase given temperature,
  !! volume and mol numbers
  !!
  !! \author MH, 2019-06
  !-----------------------------------------------------------------------------
  function speed_of_sound_TV(t,v,n) result(sos)
    use eosTV, only: pressure, entropy_tv
    use eos, only: moleWeight
    implicit none
    real,                   intent(in) :: t     !< Temperature [K]
    real,                   intent(in) :: v     !< Pressure [m3]
    real, dimension(nc),    intent(in) :: n     !< Mol numbers [mol]
    real :: sos !< Speed of sound [m/s]
    ! Locals
    real :: p, dpdv, dpdt, s, dsdt, dsdv, dtdv, dpdrho, rho
    p = pressure(t,v,n,dpdv,dpdt)
    call entropy_tv(t,v,n,s,dsdt,dsdv)
    dtdv = -dsdv/dsdt
    dpdv = dpdv + dpdt*dtdv
    if (dpdv < 0.0) then
      rho = sum(n)/v
      dpdrho = -1000*v*dpdv/rho/moleWeight(n/sum(n))
      sos = sqrt(dpdrho)
    else
      sos = 0.0
    endif
  end function speed_of_sound_TV

end module speed_of_sound