!
! Atmospheric_Properties
!
! Module containing utility routines to calculate various and sundry
! atmospheric properties.
!
! CONTAINS:
!       MW_Air:                   Function to calculate the effective, water
!                                 vapor weighted molecular weight of air.
!
!       Density:                  Function to calculate gas density using
!                                 the ideal gas law.
!
!       SVP_Water:                Function to calculate the saturation vapor
!                                 pressure over water.
!
!       SVP_Ice:                  Function to calculate the saturation vapor
!                                 pressure over ice.
!
!       Saturation_Mixing_Ratio:  Function to calculate the saturation mixing
!                                 ratio.
!
!       Virtual_Temperature:      Function to calculate the virtual
!                                 temperature, or its inverse.
!
!       Potential_Temperature:    Function to calculate the potential
!                                 temperature, or its inverse.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 01-May-2000
!                       paul.vandelst@noaa.gov
!

MODULE Atmospheric_Properties

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Modules used
  USE Type_Kinds, ONLY: fp
  USE Message_Handler
  USE Profile_Utility_Parameters
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: MW_Air
  PUBLIC :: Density
  PUBLIC :: SVP_Water
  PUBLIC :: SVP_Ice
  PUBLIC :: Saturation_Mixing_Ratio
  PUBLIC :: Virtual_Temperature
  PUBLIC :: Potential_Temperature

  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE MW_Air
    MODULE PROCEDURE MW_Air_scalar
    MODULE PROCEDURE MW_Air_rank1
  END INTERFACE MW_Air

  INTERFACE Density
    MODULE PROCEDURE Density_scalar
    MODULE PROCEDURE Density_rank1a   ! Scalar molecular weight
    MODULE PROCEDURE Density_rank1b   ! Rank-1 molecular weight
  END INTERFACE Density

  INTERFACE SVP_Water
    MODULE PROCEDURE SVPw_scalar
    MODULE PROCEDURE SVPw_rank1
  END INTERFACE SVP_Water

  INTERFACE SVP_Ice
    MODULE PROCEDURE SVPi_scalar
    MODULE PROCEDURE SVPi_rank1
  END INTERFACE SVP_Ice

  INTERFACE Saturation_Mixing_Ratio
    MODULE PROCEDURE SMR_scalar
    MODULE PROCEDURE SMR_rank1
  END INTERFACE Saturation_Mixing_Ratio

  INTERFACE Virtual_Temperature
    MODULE PROCEDURE Tv_scalar
    MODULE PROCEDURE Tv_rank1
  END INTERFACE Virtual_Temperature

  INTERFACE Potential_Temperature
    MODULE PROCEDURE Theta_scalar
    MODULE PROCEDURE Theta_rank1
  END INTERFACE Potential_Temperature

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_RCS_ID = &
  '$Id: Atmospheric_Properties.f90 2018 2008-04-01 20:12:33Z paul.vandelst@noaa.gov $'
  ! Keyword argument set value
  INTEGER, PARAMETER :: SET = 1

CONTAINS

!--------------------------------------------------------------------------------
!S+
! NAME:
!       MW_Air
!
! PURPOSE:
!       Function to calculate the effective, water vapor weighted molecular
!       weight of air.
!
! CALLING SEQUENCE:
!       Molecular_Weight = MW_Air( Pressure,               &  ! Input
!                                  Water_Vapor_Pressure,   &  ! Input
!                                  Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Pressure:              Total atmospheric pressure
!                              UNITS:      hectoPascals, hPa
!                              TYPE:       REAL(fp)
!                              DIMENSION:  Scalar or Rank-1
!                              ATTRIBUTES: INTENT(IN)
!
!       Water_Vapor_Pressure:  Water vapor partial pressure
!                              UNITS:      hectoPascals, hPa.
!                              TYPE:       REAL(fp)
!                              DIMENSION:  Same as Pressure
!                              ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:           Character string specifying a filename in which any
!                              Messages will be logged. If not specified, or if an
!                              error occurs opening the log file, the default action
!                              is to output Messages to standard output.
!                              UNITS:      N/A
!                              TYPE:       CHARACTER(*)
!                              DIMENSION:  Scalar
!                              ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       Molecular_Weight:      The effective molecular weight of air.
!                              If an error occurs, -1.0 is returned.
!                              UNITS:      grams, g
!                              TYPE:       REAL(fp)
!                              DIMENSION:  Same as input Pressure
!
! PROCEDURE:
!       The change in the effective molecular weight of dry air
!       due to water vapor is given by:
!
!                      pp(h2o) * ( MW(H2O) - MW(DRY_AIR) )
!         d(MW_Air) = -------------------------------------
!                                   Pressure
!
!       and the final result is given by:
!
!         MW(Air) = MW(DRY_AIR) + d(MW_Air)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 01-May-2000
!                       paul.vandelst@ssec.wisc.edu
!S-
!--------------------------------------------------------------------------------

  ! ==============
  ! Scalar version
  ! ==============
  FUNCTION MW_Air_scalar( Pressure,             &  ! Input
                          Water_Vapor_Pressure, &  ! Input
                          Message_Log )         &  ! Error messaging
                        RESULT( MW_Air )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Pressure
    REAL(fp),               INTENT(IN) :: Water_Vapor_Pressure
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: MW_Air
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'MW_Air'
    REAL(fp),     PARAMETER :: VOLUME_SCALE_FACTOR = ( CM_TO_M )**3
    ! Local variables
    REAL(fp) :: d_MW_Air

    ! Setup
    MW_Air = -ONE
    IF ( Pressure < TOLERANCE .OR. Water_Vapor_Pressure < ZERO ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Input pressures < or = 0.0.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Calculate change to air molecular weight due to water vapour
    d_MW_Air = Water_Vapor_Pressure * ( MW_H2O - MW_DRYAIR ) / Pressure

    ! Calculate air molecular weight
    MW_Air = MW_DRYAIR + d_MW_Air

  END FUNCTION MW_Air_scalar

  ! ==============
  ! Rank-1 version
  ! ==============
  FUNCTION MW_Air_rank1( Pressure,             &  ! Input
                         Water_Vapor_Pressure, &  ! Input
                         Message_Log )         &  ! Error messaging
                       RESULT( MW_Air )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Pressure(:)
    REAL(fp),               INTENT(IN) :: Water_Vapor_Pressure(:)
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: MW_Air(SIZE(Pressure))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'MW_Air'
    ! Local variables
    INTEGER :: i, n

    ! Setup
    MW_Air = -ONE
    n = SIZE(Pressure)
    IF ( SIZE(Water_Vapor_Pressure) /= n ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Inconsistent input array sizes.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Calculate air molecular weight
    DO i = 1, n
      MW_Air( i ) = MW_Air_scalar( Pressure( i ), &
                                   Water_Vapor_Pressure( i ), &
                                   Message_Log=Message_Log )
      IF ( MW_Air( i ) < ZERO ) RETURN
    END DO

  END FUNCTION MW_Air_rank1

!--------------------------------------------------------------------------------
!S+
! NAME:
!       Density
!
! PURPOSE:
!       Function to calculate gas density using the ideal gas law.
!
! CALLING SEQUENCE:
!       Gas_Density = Density( Pressure,               &  ! Input
!                              Temperature,            &  ! Input
!                              Molecular_Weight,       &  ! Input
!                              Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Pressure:          Pressure of gas
!                          UNITS:      hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or Rank-1
!                          ATTRIBUTES: INTENT(IN)
!
!       Temperature:       Temperature of gas
!                          UNITS:      Kelvin
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Pressure
!                          ATTRIBUTES: INTENT(IN)
!
!       Molecular_Weight:  Molecular weight of the gas.
!                          UNITS:      g.mol^-1
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or same as Pressure
!                          ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:       Character string specifying a filename in which any
!                          Messages will be logged. If not specified, or if an
!                          error occurs opening the log file, the default action
!                          is to output Messages to standard output.
!                          UNITS:      N/A
!                          TYPE:       CHARACTER(*)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       Gas_Density:       The gas density for the specified conditions.
!                          If an error occurs, -1.0 is returned.
!                          UNITS:      kg.m^-3
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Pressure
!
! PROCEDURE:
!       The density is calculated using the ideal gas equation
!
!                    p . MW
!         Density = --------
!                    R0 . T
!
!       where R0 = universal gas constant.
!
!       Units:
!       ------
!       Pressure           : hPa == 100 Pa == 100 kg.m^-1.s^-2
!       Molecular_Weight   : g.mol^-1 == 0.001 kg.mol^-1
!       MOLAR_GAS_CONSTANT : J.K^-1.mol^-1 == kg.m^2.s^-2.K^-1.mol^-1
!       Temperature        : K
!
!                  100 kg.m^-1.s^-2 . 0.001 kg.mol^-1
!       Density = -----------------------------------
!                     kg.m^2.s^-2.K^-1.mol^-1 . K
!
!                  0.1 kg^2.m^-1.s^-2
!               = --------------------
!                      kg.m^2.s^-2
!
!               = 0.1 kg.m^-3
!
!       Thus the result is scaled by 0.1 to return density in units
!       of kg.m^-3.
!
! COMMENTS:
!       Note that the rank-1 interface of this routine can be called with
!       either a scalar molecular weight (e.g. that for dry air for a number
!       of pressure levels) or a rank-1 molecular weight (e.g. that for air
!       where the water vapour contribution has been taken into account.)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 01-May-2000
!                       paul.vandelst@ssec.wisc.edu
!S-
!--------------------------------------------------------------------------------

  ! ==============
  ! Scalar version
  ! ==============
  FUNCTION Density_scalar( Pressure,         &  ! Input
                           Temperature,      &  ! Input
                           Molecular_Weight, &  ! Input
                           Message_Log )     &  ! Error messaging
                         RESULT( Rho )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Pressure
    REAL(fp),               INTENT(IN) :: Temperature
    REAL(fp),               INTENT(IN) :: Molecular_Weight
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: Rho
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Density'
    REAL(fp),     PARAMETER :: SCALE_FACTOR = 0.1_fp

    ! Setup
    Rho = -ONE
    IF ( Pressure         < TOLERANCE .OR. &
         Temperature      < TOLERANCE .OR. &
         Molecular_Weight < TOLERANCE ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Input Pressures/Temperature/MW < or = 0.0 found.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Calculate density
    Rho = SCALE_FACTOR * Pressure * Molecular_Weight / ( R0 * Temperature )

  END FUNCTION Density_scalar

  ! ===========================================
  ! Rank-1 version with scalar molecular weight
  ! ===========================================
  FUNCTION Density_rank1a( Pressure,         &  ! Input
                           Temperature,      &  ! Input
                           Molecular_Weight, &  ! Input
                           Message_Log )     &  ! Error messaging
                         RESULT( Rho )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Pressure(:)
    REAL(fp),               INTENT(IN) :: Temperature(:)
    REAL(fp),               INTENT(IN) :: Molecular_Weight
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: Rho(SIZE(Pressure))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Density'
    ! Local variables
    INTEGER :: i, n

    ! Setup
    Rho = -ONE
    n = SIZE(Pressure)
    IF ( SIZE(Temperature) /= n ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Inconsistent input Pressure/Temperature array sizes.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Calculate density
    DO i = 1, n
      Rho( i ) = Density_scalar( Pressure( i ), &
                                 Temperature( i ), &
                                 Molecular_Weight, &
                                 Message_Log=Message_Log )
      IF ( Rho( i ) < ZERO ) RETURN
    END DO

  END FUNCTION Density_rank1a

  ! ===========================================
  ! Rank-1 version with rank-1 molecular weight
  ! ===========================================
  FUNCTION Density_rank1b( Pressure,         &  ! Input
                           Temperature,      &  ! Input
                           Molecular_Weight, &  ! Input
                           Message_Log )     &  ! Error messaging
                         RESULT( Rho )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Pressure(:)
    REAL(fp),               INTENT(IN) :: Temperature(:)
    REAL(fp),               INTENT(IN) :: Molecular_Weight(:)
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: Rho(SIZE(Pressure))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'DENSITY'
    ! Local variables
    INTEGER :: i, n

    ! Setup
    Rho = -ONE
    n = SIZE(Pressure)
    IF ( SIZE(Temperature)      /= n .OR. &
         SIZE(Molecular_Weight) /= n      ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Inconsistent input array sizes.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Calculate density
    DO i = 1, n
      Rho( i ) = Density_scalar( Pressure( i ), &
                                 Temperature( i ), &
                                 Molecular_Weight( i ), &
                                 Message_Log=Message_Log )
      IF ( Rho( i ) < ZERO ) RETURN
    END DO

  END FUNCTION Density_rank1b

!--------------------------------------------------------------------------------
!S+
! NAME:
!       SVP_Water
!
! PURPOSE:
!       Function to calculate the saturation vapor pressure over water.
!
! CALLING SEQUENCE:
!       svp = SVP_Water( Temperature,            &  ! Input
!                        Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Temperature:      Temperatures for which the saturation vapor
!                         pressure is required.
!                         UNITS:      Kelvin, K
!                         TYPE:       REAL(fp)
!                         DIMENSION:  Scalar or Rank-1
!                         ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:      Character string specifying a filename in which any
!                         Messages will be logged. If not specified, or if an
!                         error occurs opening the log file, the default action
!                         is to output Messages to standard output.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       svp:               The saturation vapor pressure over water
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Temperature
!
! RESTRICTIONS:
!       Valid temperature range is 188K - 343K (-85C - +70C). A warning is
!       reported if the input temperatures are outside this range.
!
! PROCEDURE:
!       Flatau,P.J., R.L.Walko, and W.R.Cotton, 1992: "Polynomial fits to
!         saturation vapor pressure", J.Appl.Met., v31, pp1507-1513
!
!                           __ N
!                          \            i
!         SVP_Water = c0 +  >   c(i) . T
!                          /__
!                             i=1
!
!       where the c(i) are the relative error norm coefficients obtained
!       from the reference above.
!
!       Horner's method is used to evaluate the above polynomial.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 24-Apr-1998
!                       paul.vandelst@ssec.wisc.edu
!S-
!--------------------------------------------------------------------------------

  ! ==============
  ! Scalar version
  ! ==============
  FUNCTION SVPw_scalar( Temperature,   &  ! Input
                        Message_Log  ) &  ! Error messaging
                      RESULT( svp )
    ! Arguments
    REAL(fp),          INTENT(IN) :: Temperature
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: svp
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SVP_Water'
    INTEGER,  PARAMETER :: N_COEFFICIENTS = 8
    REAL(fp), PARAMETER :: COEFFICIENTS(0:N_COEFFICIENTS) = &
      (/ 6.11583699e+00_fp, 4.44606896e-01_fp, 1.43177157e-02_fp, &
         2.64224321e-04_fp, 2.99291081e-06_fp, 2.03154182e-08_fp, &
         7.02620698e-11_fp, 3.79534310e-14_fp,-3.21582393e-16_fp /)
    REAL(fp), PARAMETER :: MIN_TEMPERATURE = 188.15_fp
    REAL(fp), PARAMETER :: MAX_TEMPERATURE = 343.15_fp
    ! Local variables
    CHARACTER(256) :: Message
    INTEGER :: i
    REAL(fp) :: T_Celsius

    ! Setup
    IF ( Temperature < MIN_TEMPERATURE .OR. &
         Temperature > MAX_TEMPERATURE ) THEN
      WRITE( Message,'("Input Temperature ",f6.2,&
                      &" outside valid range: ",&
                      &f6.2,"K < T < ",f6.2,"K" )' ) &
                      Temperature, MIN_TEMPERATURE, MAX_TEMPERATURE
      CALL Display_Message( ROUTINE_NAME, &
                            TRIM(Message), &
                            WARNING, &
                            Message_Log=Message_Log )
    ENDIF

    ! Calculate saturation vapor pressure
    T_Celsius = Temperature - CELSIUS_TO_KELVIN
    svp       = COEFFICIENTS(N_COEFFICIENTS)
    DO i = N_COEFFICIENTS-1, 0, -1
      svp = ( svp * T_Celsius ) + COEFFICIENTS(i)
    END DO

  END FUNCTION SVPw_scalar

  ! ==============
  ! Rank-1 version
  ! ==============
  FUNCTION SVPw_rank1( Temperature,   &  ! Input
                       Message_Log  ) &  ! Error messaging
                     RESULT( svp )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Temperature(:)
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: svp(SIZE(Temperature))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SVP_Water'
    ! Local variables
    INTEGER :: i

    ! Calculate saturation vapor pressure
    DO i = 1, SIZE(Temperature)
      SVP( i ) = SVPw_scalar( Temperature( i ), &
                              Message_Log=Message_Log )
    END DO

  END FUNCTION SVPw_rank1

!--------------------------------------------------------------------------------
!S+
! NAME:
!       SVP_Ice
!
! PURPOSE:
!       Function to calculate the saturation vapor pressure over ice
!
! CALLING SEQUENCE:
!       svp = SVP_Ice( Temperature,            &  ! Input
!                      Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Temperature:      Temperatures for which the saturation vapor
!                         pressure is required.
!                         UNITS:      Kelvin, K
!                         TYPE:       REAL(fp)
!                         DIMENSION:  Scalar or Rank-1
!                         ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:      Character string specifying a filename in which any
!                         Messages will be logged. If not specified, or if an
!                         error occurs opening the log file, the default action
!                         is to output Messages to standard output.
!                         UNITS:      N/A
!                         TYPE:       CHARACTER(*)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       svp:               The saturation vapor pressure over ice
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Temperature
!
! RESTRICTIONS:
!       Valid Temperature range is 183K - 273K (-90C - 0C). An warning is
!       reported if the input Temperatures are outside this range.
!
! PROCEDURE:
!       Flatau,P.J., R.L.Walko, and W.R.Cotton, 1992: "Polynomial fits to
!         saturation vapor pressure", J.Appl.Met., v31, pp1507-1513
!
!                         __ N
!                        \            i
!         SVP_Ice = c0 +  >   c(i) . T
!                        /__
!                           i=1
!
!       where the c(i) are the relative error norm coefficients obtained
!       from the reference above.
!
!       Horner's method is used to evaluate the above polynomial.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 24-Apr-1998
!                       paul.vandelst@ssec.wisc.edu
!S-
!--------------------------------------------------------------------------------

  ! ==============
  ! Scalar version
  ! ==============
  FUNCTION SVPi_scalar( Temperature,   &  ! Input
                        Message_Log  ) &  ! Error messaging
                      RESULT( svp )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Temperature
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: svp
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SVP_Ice'
    INTEGER,  PARAMETER :: N_COEFFICIENTS = 8
    REAL(fp), PARAMETER :: COEFFICIENTS(0:N_COEFFICIENTS) = &
      (/ 6.09868993e+00_fp, 4.99320233e-01_fp, 1.84672631e-02_fp, &
         4.02737184e-04_fp, 5.65392987e-06_fp, 5.21693933e-08_fp, &
         3.07839583e-10_fp, 1.05785160e-12_fp, 1.61444444e-15_fp /)
    REAL(fp), PARAMETER :: MIN_TEMPERATURE = 183.15_fp
    REAL(fp), PARAMETER :: MAX_TEMPERATURE = 273.15_fp
    ! Local variables
    CHARACTER(256) :: Message
    INTEGER  :: i
    REAL(fp) :: T_Celsius

    ! Setup
    IF ( Temperature < MIN_TEMPERATURE .OR. &
         Temperature > MAX_TEMPERATURE ) THEN
      WRITE( Message,'("Input Temperature ",f6.2,&
                      &" outside valid range: ",&
                      &f6.2,"K < T < ",f6.2,"K")' ) &
                      Temperature, MIN_TEMPERATURE, MAX_TEMPERATURE
      CALL Display_Message( ROUTINE_NAME, &
                            TRIM(Message), &
                            WARNING, &
                            Message_Log=Message_Log )
    ENDIF

    ! Calculate saturation vapor pressure
    T_Celsius = Temperature - CELSIUS_TO_KELVIN
    svp       = COEFFICIENTS(N_COEFFICIENTS)
    DO i = N_COEFFICIENTS-1, 0, -1
      svp = ( svp * T_Celsius ) + COEFFICIENTS(i)
    END DO

  END FUNCTION SVPi_scalar

  ! ==============
  ! Rank-1 version
  ! ==============
  FUNCTION SVPi_rank1( Temperature,   &  ! Input
                       Message_Log  ) &  ! Error messaging
                     RESULT( svp )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Temperature(:)
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: svp(SIZE(Temperature))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'SVP_Ice'
    ! Local variables
    INTEGER :: i

    ! Calculate saturation vapor pressure
    DO i = 1, SIZE(Temperature)
      SVP( i ) = SVPi_scalar( Temperature( i ), &
                              Message_Log=Message_Log )
    END DO

  END FUNCTION SVPi_rank1

!--------------------------------------------------------------------------------
!S+
! NAME:
!       Saturation_Mixing_Ratio
!
! PURPOSE:
!       Function to calculate the saturation mixing ratio for a given
!       pressure and temperature
!
! CALLING SEQUENCE:
!       smr = Saturation_Mixing_Ratio( Pressure,                        &  ! Input
!                                      Temperature,                     &  ! Input
!                                      Ice_Temperature=Ice_Temperature, &  ! optional input
!                                      Min_Pressure   =Min_Pressure,    &  ! Optional input
!                                      Message_Log    =Message_Log      )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Pressure:          Total atmospheric pressure.
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or Rank-1
!                          ATTRIBUTES: INTENT(IN)
!
!       Temperature:       Atmospheric Temperature.
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Pressure
!                          ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Ice_Temperature:   Temperature below which the saturation vapor
!                          pressure over ice is used in the conversion.
!                          By default, only the saturation vapor pressure
!                          over water is used.
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Min_Pressure:      Pressure value below which the saturation
!                          mixing ratio is not calculated. The default
!                          is 50hPa. Saturation mixing ratios at pressures
!                          less than the minimum pressure are set to zero.
!                          This is because at pressures less than 50mb, the
!                          saturation vapour pressure, which is based only on
!                          temperature, can exceed the total air pressure.
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Message_Log:       Character string specifying a filename in which any
!                          Messages will be logged. If not specified, or if an
!                          error occurs opening the log file, the default action
!                          is to output Messages to standard output.
!                          UNITS:      N/A
!                          TYPE:       CHARACTER(*)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       smr:               The saturation mixing ratio
!                          If an error occurs, -1.0 is returned.
!                          UNITS:      g/kg
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Pressure
!
! PROCEDURE:
!       The saturation mixing ratio can be defined as:
!
!                rho_ws
!          ws = --------     .....(1)
!                rho_d
!
!       where rho_ws = the partial density of water vapour required to
!                      saturate air with respect to water at a Temperature, T
!             rho_d  = the partial density of dry air.
!
!       Equation (1) can be rewritten as:
!
!                   es
!               ---------
!                R_w . T
!         ws = ------------
!                p - es
!               ---------
!                R_d . T
!
!               R_d       es
!            = ----- . --------
!               R_w     p - es
!
!               M_w       es
!            = ----- . --------     .....(2)
!               M_d     p - es
!
!       where M_w = molecular weight of water
!             M_d = molecular weight of dry air
!             es  = water vapor partial pressure
!             p   = total air pressure
!             R_d = gas constant for dry air
!             R_w = gas constant for water vapor
!
!       The units of equation (2) are:
!
!               g     hPa
!         ws = --- . -----
!               g     hPa
!
!                      g
!            = 1000.0 ----
!                      kg
!
!       A factor of 1000 is used to return values in units of g/kg.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 18-Mar-1998
!                       paul.vandelst@ssec.wisc.edu
!S-
!--------------------------------------------------------------------------------

  ! ==============
  ! Scalar version
  ! ==============
  FUNCTION SMR_scalar( Pressure,        &  ! Input
                       Temperature,     &  ! Input
                       Ice_Temperature, &  ! Optional Input
                       Min_Pressure,    &  ! Optional Input
                       Message_Log )    &  ! Error messaging
                     RESULT( smr )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Pressure
    REAL(fp),               INTENT(IN) :: Temperature
    REAL(fp),     OPTIONAL, INTENT(IN) :: Ice_Temperature
    REAL(fp),     OPTIONAL, INTENT(IN) :: Min_Pressure
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: smr
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Saturation_Mixing_Ratio'
    REAL(fp),     PARAMETER :: DEFAULT_MIN_PRESSURE = 50.0_fp
    ! Local variables
    LOGICAL :: Use_Ice_Temperature
    REAL(fp) :: Ice_T
    REAL(fp) :: Min_P
    REAL(fp) :: svp
    REAL(fp) :: dp

    ! Setup
    smr = -ONE
    IF ( Pressure    < TOLERANCE .OR. &
         Temperature < TOLERANCE ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Input argument values < or = 0.0 found.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF
    IF ( PRESENT( Min_Pressure ) ) THEN
      Min_P = Min_Pressure
    ELSE
      Min_P = DEFAULT_MIN_PRESSURE
    END IF
    ! Default is NOT to use ice Temperature
    Use_Ice_Temperature = .FALSE.
    Ice_T               = ZERO
    ! ...unless Ice_Temperature argument is present
    IF ( PRESENT( Ice_Temperature ) ) THEN
      Use_Ice_Temperature = .TRUE.
      Ice_T               = Ice_Temperature
    END IF

    ! Only do calculation at pressures greater than the minumum
    Pressure_check: IF ( Pressure > Min_P ) THEN

      ! Calculate saturation vapor pressure
      IF ( Use_Ice_Temperature .AND. ( Temperature < Ice_T ) ) THEN
        svp = SVPi_scalar( Temperature, Message_Log=Message_Log )
      ELSE
        svp = SVPw_scalar( Temperature, Message_Log=Message_Log )
      END IF

      ! Calculate saturation mixing ratio only if the
      ! total pressure is greater than the saturation
      ! vapor pressure.
      dp = Pressure - svp
      IF ( dp > ZERO ) THEN
        smr = KG_TO_G * EPS * svp / dp
      ELSE
        smr = ZERO
      END IF

    ELSE

      smr = ZERO

    END IF Pressure_check

  END FUNCTION SMR_scalar

  ! ==============
  ! Rank-1 version
  ! ==============
  FUNCTION SMR_rank1( Pressure,        &  ! Input
                      Temperature,     &  ! Input
                      Ice_Temperature, &  ! Optional Input
                      Min_Pressure,    &  ! Optional Input
                      Message_Log )    &  ! Error messaging
                    RESULT( smr )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Pressure(:)
    REAL(fp),               INTENT(IN) :: Temperature(:)
    REAL(fp),     OPTIONAL, INTENT(IN) :: Ice_Temperature
    REAL(fp),     OPTIONAL, INTENT(IN) :: Min_Pressure
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: smr(SIZE(Pressure))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Saturation_Mixing_Ratio'
    ! Local variables
    INTEGER :: i, n

    ! Setup
    smr = -ONE
    n = SIZE(Pressure)
    IF ( SIZE(Temperature) /=  n ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Inconsistent input Pressure/Temperature array sizes.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Calculate saturation mixing ratio
    DO i = 1, n
      smr( i ) = SMR_scalar( Pressure( i ), &
                             Temperature( i ), &
                             Ice_Temperature = Ice_Temperature, &
                             Min_Pressure    = Min_Pressure, &
                             Message_Log     = Message_Log )
      IF ( smr( i ) < ZERO ) RETURN
    END DO

  END FUNCTION SMR_rank1

!--------------------------------------------------------------------------------
!S+
! NAME:
!       Virtual_Temperature
!
! PURPOSE:
!       Function to calculate the virtual temperature given the temperature and
!       water vapor mixing ratio.
!
!       There is also an "inverse" capability to compute the temperature given
!       the virtual temperature and the water vapor mixing ratio.
!
! CALLING SEQUENCE:
!       Tv = Virtual_Temperature( Temperature,              &  ! Input
!                                 Water_Vapor_Mixing_Ratio, &  ! Input
!                                 Inverse    =Inverse,      &  ! Optional Input
!                                 Message_Log=Message_Log   )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Temperature:               Atmospheric temperature.
!                                  UNITS:      Kelvin, K
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar or Rank-1
!                                  ATTRIBUTES: INTENT(IN)
!
!       Water_Vapor_Mixing_Ratio:  Water vapor mass mixing ratio.
!                                  UNITS:      g/kg
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Same as Temperature
!                                  ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Inverse:                   Set this argument to compute the temperature
!                                  given the input is the virtual temperature.
!                                  If = 0, virtual temperature is calculated (default)
!                                     = 1, input value is assumed to be the virtual
!                                          temperature and the temperature is
!                                          calculated.
!                                  UNITS:      N/A
!                                  TYPE:       INTEGER
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Message_Log:               Character string specifying a filename in which any
!                                  Messages will be logged. If not specified, or if an
!                                  error occurs opening the log file, the default action
!                                  is to output Messages to standard output.
!                                  UNITS:      N/A
!                                  TYPE:       CHARACTER(*)
!                                  DIMENSION:  Scalar
!                                  ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       Tv:                        The virtual temperature. If the optional Inverse
!                                  argument is set, the function result is the
!                                  atmospheric temperature.
!                                  If an error occurs, -1.0 is returned.
!                                  UNITS:      Kelvin, K
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Same as input Temperature
!
! PROCEDURE:
!       The virtual temperature, the temperature that dry air must have in
!       order to have the same density as moist air at the same pressure, is
!       calculated using:
!
!                  [    eps + w    ]
!         Tv = T * [ ------------- ]     .......................(1)
!                  [ eps ( 1 + w ) ]
!
!       where T   = temperature,
!             w   = water vapour mixing ratio, and
!             eps = ratio of the molecular weights of water and dry air.
!
!       An approximation to eqn.(1) is,
!
!                  [      1 - eps    ]
!         Tv = T * [ 1 + --------- w ]
!                  [        eps      ]
!
!            = T * [ 1 + ( 0.608 * w ) ]   .....................(2)
!
!       however, depending on what accuracy is required (keeping in mind that
!       water vapor measurements are probably good to 2-5%), eqn.(2) can
!       differ from (1) by around 0.06-0.08K near the surface.
!
!       If virtual temperature is used to calculate geopotential heights,
!       this difference can lead to errors of up to 0.6-0.7m.
!
!       So I took the slightly more computationally expensive road
!       and use eqn.(1).
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 01-May-2000
!                       paul.vandelst@ssec.wisc.edu
!S-
!--------------------------------------------------------------------------------

  ! ==============
  ! Scalar version
  ! ==============
  FUNCTION Tv_scalar( Temperature,              &  ! Input
                      Water_Vapor_Mixing_Ratio, &  ! Input
                      Inverse,                  &  ! Optional input
                      Message_Log )             &  ! Error messaging
                    RESULT( Tv )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Temperature
    REAL(fp),               INTENT(IN) :: Water_Vapor_Mixing_Ratio
    INTEGER,      OPTIONAL, INTENT(IN) :: Inverse
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: Tv
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Virtual_Temperature'
    ! Local variables
    LOGICAL :: Forward
    REAL(fp) :: mr_H2O
    REAL(fp) :: Wterm

    ! Setup
    Tv = -ONE
    IF ( Temperature < TOLERANCE .OR. Water_Vapor_Mixing_Ratio < ZERO ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Input temperature/water vapor mixing ratio < or = 0.0.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF
    ! Always do the forward calculation....
    Forward = .TRUE.
    ! ...unless the Inverse argument is set
    IF ( PRESENT( Inverse ) ) THEN
      IF( Inverse == SET ) Forward = .FALSE.
    END IF

    ! Calculate the virtual temperature
    mr_H2O = G_TO_KG * Water_Vapor_Mixing_Ratio
    Wterm  = ( EPS + mr_H2O ) / ( EPS * ( ONE + mr_H2O ) )
    IF ( Forward ) THEN
      Tv = Temperature * Wterm
    ELSE
      Tv = Temperature / Wterm
    END IF

  END FUNCTION Tv_scalar

  ! ==============
  ! Rank-1 version
  ! ==============
  FUNCTION Tv_rank1( Temperature,              &  ! Input
                     Water_Vapor_Mixing_Ratio, &  ! Input
                     Inverse,                  &  ! Optional input
                     Message_Log )             &  ! Error messaging
                   RESULT( Tv )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Temperature(:)
    REAL(fp),               INTENT(IN) :: Water_Vapor_Mixing_Ratio(:)
    INTEGER,      OPTIONAL, INTENT(IN) :: Inverse
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: Tv(SIZE(Temperature))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Virtual_Temperature'
    ! Local variables
    INTEGER :: i, n

    ! Setup
    Tv = -ONE
    n = SIZE(Temperature)
    IF ( SIZE(Water_Vapor_Mixing_Ratio) /= n ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Inconsistent input Temperature/Water_Vapor_'//&
                            'Mixing_Ratio array sizes.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Compute the virtual temperature (or inverse)
    DO i = 1, n
      Tv( i ) = Tv_scalar( Temperature( i ), &
                           Water_Vapor_Mixing_Ratio( i ), &
                           Inverse    =Inverse, &
                           Message_Log=Message_Log )
      IF ( Tv( i ) < ZERO ) RETURN
    END DO

  END FUNCTION Tv_rank1

!--------------------------------------------------------------------------------
!S+
! NAME:
!       Potential_Temperature
!
! PURPOSE:
!       Function to calculate the potential temperature given the temperature
!       and pressure.
!
!       There is also an "inverse" capability to compute the temperature given
!       the potential temperature and pressure.
!
! CALLING SEQUENCE:
!       Theta = Potential_Temperature( Temperature,            &  ! Input
!                                      Pressure,               &  ! Input
!                                      Inverse    =Inverse,    &  ! Optional input
!                                      Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Temperature:       Atmospheric temperature.
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or Rank-1
!                          ATTRIBUTES: INTENT(IN)
!
!       Pressure:          Atmospheric pressure
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Temperature
!                          ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Inverse:           Set this argument to compute the temperature
!                          given the input is the potential temperature.
!                          If = 0, potential temperature is calculated (default)
!                             = 1, input value is assumed to be the potential
!                                  temperature and the temperature is
!                                  calculated.
!                          UNITS:      N/A
!                          TYPE:       INTEGER
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Message_Log:       Character string specifying a filename in which any
!                          Messages will be logged. If not specified, or if an
!                          error occurs opening the log file, the default action
!                          is to output Messages to standard output.
!                          UNITS:      N/A
!                          TYPE:       CHARACTER(*)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       Theta:             The potential temperature. If the optional Inverse
!                          argument is set, the function result is the
!                          atmospheric temperature.
!                          If an error occurs, -1.0 is returned.
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Temperature
!
! PROCEDURE:
!       The potential temperature of a parcel of air is that temperature
!       the parcel would have if it were expanded or compressed adiabatically
!       to some reference pressure.
!
!       The conversion is given by Poisson's equation:
!
!                             R/Cp
!                     [  P0  ]
!         Theta = T * [ ---- ]           .......................(1)
!                     [  p   ]
!
!       where T   = temperature,
!             p   = pressure,
!             P0  = standard pressure
!             R   = gas constant,
!             Cp  = specific heat of gas at constant pressure.
!
!       This routine uses the standard atmosphere as the reference pressure,
!       R for dry air, and Cp for an ideal diatomic gas:
!
!               7      R0
!         Cp = --- . -------
!               2     MWair
!
!       where R0    = universal gas constant
!             MWair = molecular weight of dry air
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 11-Sep-2002
!                       paul.vandelst@ssec.wisc.edu
!S-
!--------------------------------------------------------------------------------

  ! ==============
  ! Scalar version
  ! ==============
  FUNCTION Theta_scalar( Temperature,  &  ! Input
                         Pressure,     &  ! Input
                         Inverse,      &  ! Optional Input
                         Message_Log ) &  ! Error messaging
                       RESULT( Theta )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Temperature
    REAL(fp),               INTENT(IN) :: Pressure
    INTEGER,      OPTIONAL, INTENT(IN) :: Inverse
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: Theta
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Potential_Temperature'
    REAL(fp),     PARAMETER :: EXPONENT_TERM = R_DRYAIR / Cp_DRYAIR
    ! Local variables
    LOGICAL  :: Forward
    REAL(fp) :: PressureTerm

    ! Setup
    Theta = -ONE
    IF ( Temperature < TOLERANCE .OR. Pressure < ZERO ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Input temperature/pressure < or = 0.0.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF
    ! Always do the forward calculation....
    Forward = .TRUE.
    ! ...unless the Inverse argument is set
    IF ( PRESENT( Inverse ) ) THEN
      IF( Inverse == SET ) Forward = .FALSE.
    END IF

    ! Calculate the potential temperature
    PressureTerm = ( ( P0 / Pressure )**EXPONENT_TERM )
    IF ( Forward ) THEN
      Theta = Temperature * PressureTerm
    ELSE
      Theta = Temperature / PressureTerm
    END IF

  END FUNCTION Theta_scalar

  ! ==============
  ! Rank-1 version
  ! ==============
  FUNCTION Theta_rank1( Temperature,  &  ! Input
                        Pressure,     &  ! Input
                        Inverse,      &  ! Optional Input
                        Message_Log ) &  ! Error messaging
                      RESULT( Theta )
    ! Arguments
    REAL(fp),               INTENT(IN) :: Temperature(:)
    REAL(fp),               INTENT(IN) :: Pressure(:)
    INTEGER,      OPTIONAL, INTENT(IN) :: Inverse
    CHARACTER(*), OPTIONAL, INTENT(IN) :: Message_Log
    ! Function result
    REAL(fp) :: Theta(SIZE(Temperature))
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Potential_Temperature'
    ! Local variables
    INTEGER :: i, n

    ! Setup
    Theta = -ONE
    n = SIZE(Temperature)
    IF ( SIZE(Pressure) /= n ) THEN
      CALL Display_Message( ROUTINE_NAME, &
                            'Inconsistent input Temperature/Pressure array sizes.', &
                            FAILURE, &
                            Message_Log=Message_Log )
      RETURN
    ENDIF

    ! Calculate the potential temperature
    DO i = 1, n
      Theta( i ) = Theta_scalar( Temperature( i ), &
                                 Pressure( i ), &
                                 Inverse    =Inverse, &
                                 Message_Log=Message_Log )
      IF ( Theta( i ) < ZERO ) RETURN
    END DO

  END FUNCTION Theta_rank1

END MODULE Atmospheric_Properties


program test

use spherical_geometry

implicit none

real(8) :: x1,y1,d,az,x2,y2

x1 = 0.
y1 = 0.
d = 45.
az = 0.

write(*,*) 'start lon,lat = ',x1,y1
write(*,*) 'azimuth = ',az
write(*,*) 'distance = ',d

call step(x1,y1,az,d,x2,y2,degrees=.true.)

write(*,*) 'expected lon,lat = ',0.,45.
write(*,*) 'calculated lon,lat = ',x2,y2

end program test


Function hirnd2(i, xmin, xmax)
  Common /hijhb/rr(10, 201), xx(10, 201)
  Common /rndf77/nseed
  Save
  If (xmin<xx(i,1)) xmin = xx(i, 1)
  If (xmax>xx(i,201)) xmax = xx(i, 201)
  jmin = 1 + int(200*(xmin-xx(i,1))/(xx(i,201)-xx(i,1)))
  jmax = 1 + int(200*(xmax-xx(i,1))/(xx(i,201)-xx(i,1)))
  rx = rr(i, jmin) + (rr(i,jmax)-rr(i,jmin))*ranart(nseed)
  jl = 0
  ju = 202
  10 If (ju-jl>1) Then
    jm = (ju+jl)/2
    If ((rr(i,201)>rr(i,1)) .Eqv. (rx>rr(i,jm))) Then
      jl = jm
    Else
      ju = jm
    End If
    Goto 10
  End If
  j = jl
  If (j<1) j = 1
  If (j>=201) j = 200
  hirnd2 = (xx(i,j)+xx(i,j+1))/2.0
  Return
End Function hirnd2


!> @brief Test the square mesh generator creates a correctly-sized mesh.
!
!> @description A "square" domain of side L should result in a mesh of volume L^d, this can be
!> verified by summing the volumes of all cells.
program test_mesh_square_mesh_volume

  use testing_lib
  use meshing, only : set_cell_location, get_volume
  use mesh_utils, only : build_square_mesh

  implicit none

  type(ccs_mesh) :: mesh

  integer(ccs_int) :: n
  real(ccs_real) :: l
  real(ccs_real) :: vol
  real(ccs_real) :: vol_global
  real(ccs_real) :: expected_vol

  integer(ccs_int) :: i
  type(cell_locator) :: loc_p
  real(ccs_real) :: V

  integer(ccs_int) :: nneg_vol
  integer(ccs_int) :: nneg_vol_global

  call init()

  do n = 1, 100
    l = parallel_random(par_env)
    mesh = build_square_mesh(par_env, n, l)
    expected_vol = l**2 ! XXX: Currently the square mesh is hard-coded 2D...

    vol = 0.0_ccs_real
    nneg_vol = 0
    do i = 1, mesh%nlocal
      call set_cell_location(mesh, i, loc_p)
      call get_volume(loc_p, V)
      if (V <= 0) then
        nneg_vol = nneg_vol + 1
      end if
      vol = vol + mesh%volumes(i)
    end do

    select type(par_env)
    type is(parallel_environment_mpi)
      call MPI_Allreduce(vol, vol_global, 1, real_type, MPI_SUM, par_env%comm, ierr)
      call MPI_Allreduce(nneg_vol, nneg_vol_global, 1, MPI_INT, MPI_SUM, par_env%comm, ierr)
    class default
      write (message,*) "ERROR: Unknown parallel environment!"
      call stop_test(message)
    end select

    ! XXX: This would be a good candidate for a testing library
    if (abs(expected_vol - vol_global) > 1.0e-8) then
      print *, mesh%h, l/n !TODO: not sure if this should be put inside message
      write (message,*) "FAIL: expected ", expected_vol, " got ", vol_global
      call stop_test(message)
    end if

    if (nneg_vol_global /= 0) then
      write (message, *) "FAIL: encountered negative cell volume!"
      call stop_test(message)
    end if
  end do

  call fin()

end program test_mesh_square_mesh_volume


C++*****************************************************************
C Program ARGS_ELLIPSE
C Program to display a portion of an ellipse on the ARGS
C JLP Version of 15-07-87
C--*****************************************************************
	PROGRAM ARGS_ELLIPSE
      implicit real*8 (a-h,o-z)
	PARAMETER (IDIM=2000)
	REAL*4 XPLOT(IDIM),YPLOT(IDIM)
	REAL*8 Z(5),Z1(5)
	CHARACTER ANS*1,COLOUR*1,NCHAR(2)*4

10	FORMAT(A)

	PRINT *,' PROGRAM ARGS_ELLIPSE'
	PRINT *,' FOR AN IMAGE CENTRED IN 256.,256. BY "ADISP"'

	PRINT *,' SIZE NX,NY OF THE DISPLAYED IMAGE ?'
	READ(5,*) NX,NY

	PRINT *,' SCALE IN ARCSEC./PIXEL ?'
	READ(5,*) SCALE

12	PRINT *,' CENTRE OX,OY ?'
	READ(5,*) OX,OY
	Z1(4)=OX
	Z1(5)=OY
	PRINT *,' MAJOR AXIS (ARCSEC.),  AND AXIS RATIO B/A ?'
	READ(5,*) Z(1),ECCEN
	Z1(1)=Z(1)/SCALE
	Z1(2)=Z1(1)*ECCEN
	PRINT *,' THETA, THETA MIN AND THETA MAX (DEGREES)'
	READ(5,*) THETA,THEMI,THEMA
	Z1(3)=THETA*PI/180.

C Generating the portion of ellipse :
	CALL GENE_ELLIPSE(XPLOT,YPLOT,NPLOT,Z1,THEMI,THEMA,1)

C Display a portion of an ellipse on the ARGS
	PRINT *,' COLOUR ? (B, R, Y, OR W)'
	READ(5,10) COLOUR
	PRINT *,' SYMBOL (L=LINE, 54=CROSSES) ?'
	READ(5,10) NCHAR(1)
	CALL ARGS_DISPLAY(XPLOT,YPLOT,NPLOT,NPLOT,
     1	1,NCHAR,COLOUR,NX,NY)

	PRINT *,' DO YOU WANT ANOTHER TRY ?'
	READ(5,10) ANS
	IF(ANS.EQ.'Y') GO TO 12
	END
C********************************************************************
	include 'jlpsub:gene_ellipse.for'
	include 'jlpsub:args_display.for'


module m_ia_angle
!! **Angle potentials**
!!
!! *Style _none_: None
!! *Style _cos_: Cosine. \[U(\theta) = k(1 - \cos \theta) \], \[\theta\] is
!!      the complementary bond angle.
!! *Style _harm_: Harmonic. \[U(\theta) = k \theta^2 \], \[\theta\] is
!!      the complementary bond angle.
!! *Style _tab_ : Tabulated potential

use m_precision
use m_constants_math
use m_ia_types, only: ia_specs_t
use m_spline

implicit none

contains

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

subroutine ia_angle_setup(specs)
    !! Sets up parameters for angle potentials

    type(ia_specs_t), intent(in out) :: specs

    select case(specs%style)
    case('none')
        continue
    case('cos')
        continue
    case('harm')
        continue
    case('tab')
        call ang_tab_set(specs)
    case default
        continue
    end select

    end subroutine

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

subroutine ia_get_angle_energy(rim1, ri, rip1, specs, enrg)
    !! Calculates the energy due to an angle potential.

    real(rp), dimension(3), intent(in) :: rim1
    real(rp), dimension(3), intent(in) :: ri
    real(rp), dimension(3), intent(in) :: rip1
    type(ia_specs_t), intent(in) :: specs
    real(rp), intent(out) :: enrg
    real(rp), dimension(3) :: q1
    real(rp), dimension(3) :: q2
    real(rp), dimension(3) :: q1hat
    real(rp), dimension(3) :: q2hat
    real(rp) :: q1mag
    real(rp) :: q2mag
    real(rp) :: ctheta
    integer  :: ierr

    q1 = ri - rim1; q2 = rip1 - ri
    q1mag = norm2(q1); q2mag = norm2(q2)
    q1hat = q1/q1mag; q2hat = q2/q2mag
    ctheta = dot_product(q1hat, q2hat)
    !Floating point correction
    if (ctheta > 1.0_rp) ctheta = 1.0_rp
    if (ctheta < -1.0_rp) ctheta = -1.0_rp

    select case(specs%style)
    case('none')
        enrg = 0.0_rp
    case('cos')
        call ang_cos(ctheta, specs, enrg)
    case('harm')
        call ang_harm(ctheta, specs, enrg)
    case('tab')
        call ang_tab(ctheta, specs, enrg, ierr)
    end select

    end subroutine

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

subroutine ang_cos(ctheta, specs, enrg)
    !! Calculates energy for angular cosine interaction.
    !! params(1) = k

    real(rp), intent(in) :: ctheta
    type(ia_specs_t), intent(in) :: specs
    real(rp), intent(out) :: enrg
    real(rp) :: kang

    kang = specs%params(1)
    enrg = kang*(1.0_rp - ctheta)

    end subroutine

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

subroutine ang_harm(ctheta, specs, enrg)
    !! Calculates energy for harmonic angular interaction.
    !! params(1) = k

    real(rp), intent(in) :: ctheta
    type(ia_specs_t), intent(in) :: specs
    real(rp), intent(out) :: enrg
    real(rp) :: kang
    real(rp) :: theta

    kang = specs%params(1)
    theta = acos(ctheta)
    enrg = kang*theta*theta

    end subroutine

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

subroutine ang_tab_set(specs)
    !! Setter for tabulated interaction.
    !! params(1) = vtltmin, params(2) = vtgtmax, params(3) = intrp_meth,
    !! params(4) = flag_bc
    !! cache(1) = tmin, cache(2) = tmax

    type(ia_specs_t), intent(in out) :: specs
    integer :: intrp_meth, flag_bc
    integer :: n

    intrp_meth = int(specs%params(3))
    n = specs%tab_size

    allocate( specs%cache(2) )
    specs%cache(1) = minval(specs%tab_t)
    specs%cache(2) = maxval(specs%tab_t)

    if (intrp_meth == 1) then
        allocate( specs%tab_vpp(n) )
        flag_bc = int(specs%params(4))
        if (flag_bc == 0) then
            !Natural BC: second derivative equals zero at the two ends
            call spline_cubic_set(n, specs%tab_t, specs%tab_v, &
                2, 0.0_rp, 2, 0.0_rp, specs%tab_vpp)
        else if (flag_bc == 1) then
            !Spline is quadratic over the first and last interval
            call spline_cubic_set(n, specs%tab_t, specs%tab_v, &
                0, 0.0_rp, 0, 0.0_rp, specs%tab_vpp)
        else if (flag_bc == 2) then
            !Not-a-knot condition
            call spline_cubic_set(n, specs%tab_t, specs%tab_v, &
                3, 0.0_rp, 3, 0.0_rp, specs%tab_vpp)
        end if
    end if

    end subroutine

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

subroutine ang_tab(r, specs, enrg, ierr)
    !! Calculates energy for tabulated interaction.

    !  params(1) = vtltmin, params(2) = vtgtmax, params(3) = intrp_meth,
    !  params(4) = flag_bc
    !  cache(1) = tmin, cache(2) = tmax

    real(rp), intent(in) :: r
    type(ia_specs_t), intent(in) :: specs
    real(rp), intent(out) :: enrg
    integer, intent(out) :: ierr
    real(rp) :: tmin, tmax, vtltmin, vtgtmax
    real(rp) :: vp, vpp
    integer :: intrp_meth, n

    ierr = 0; enrg = 0.0_rp

    n = specs%tab_size
    vtltmin = specs%params(1); vtgtmax = specs%params(2)
    tmin = specs%cache(1); tmax = specs%cache(2)
    intrp_meth = int(specs%params(3))

    if ( r < tmin ) then
        enrg = vtltmin
    else if ( r > tmax ) then
        enrg = vtgtmax
    else
        if (intrp_meth == 0) then
            call spline_linear_val(n, specs%tab_t, specs%tab_v, r, enrg, vp)
        else if (intrp_meth == 1) then
            call spline_cubic_val(n, specs%tab_t, specs%tab_v, specs%tab_vpp, &
                r, enrg, vp, vpp)
        end if
    end if

    end subroutine

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

end module m_ia_angle


C     PI.F                                                              1
C     COPYRIGHT (C) 2020 HUGH COLEMAN                                   2
C                                                                       3
C     THIS FILE IS PART OF HUGHCOLEMAN/FORTRAN, AN ATTEMPT TO           4
C     INVESTIGATE THE FORTRAN PROGRAMMING LANGUAGE AND LEARN ABOUT THE  5
C     EARLY DAYS OF COMPUTING. IT IS RELEASED UNDER THE MIT LICENSE (SEE6
C     LICENSE.)                                                         7
                                                                        8
 10   FORMAT ( 1F12.9 )                                                 9
                                                                        10
C     THIS PROGRAM COMPUTES AN APPROXIMATION OF PI USING LEIBNIZ'       11
C     FORMULA.                                                          12
C                                                                       13
C         PI/4 = SUM(K=0,INF) (-1)**K / 2K + 1                          14
                                                                        15
      RHSUM = 0.0                                                       16
                                                                        17
C     THE NUMERATOR AND DENOMINATOR OF THE TERMS.                       18
      TNUM = 1.0                                                        19
      TDEN = 1.0                                                        20
                                                                        21
C     32768 IS THE FIXED-POINT INTEGER LIMIT - ANY MORE ITERATIONS AND  22
c     THE PROGRAM WILL FREEZE AT RUNTIME. WHY? I DON'T KNOW.            23
      DO 30 I = 0, 32765                                                24
          RHSUM = RHSUM + (TNUM / TDEN)                                 25
                                                                        26
C         NOW, PREPARE THE NUMERATOR AND DENOMINATOR VARIABLES FOR THE  27
c         NEXT TERM.                                                    28
          TNUM = -1.0 * TNUM                                            29
          TDEN = TDEN + 2.0                                             30
 30   CONTINUE                                                          31
                                                                        32
C     SOLVE FOR PI BY MULTIPLYING THE RIGHT-HAND SIDE BY FOUR.          33
      PI = RHSUM * 4.0                                                  34
      PRINT 10, PI                                                      35
                                                                        36
 9999 STOP                                                              37


#include "Definitions.INC"

module jfunctmod
contains

function ffunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: ffunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     ffunct=xval + (fac-1)*(xval+scalingdistance+smoothness/2d0)
  else if (xval.ge.scalingdistance+smoothness) then
     ffunct=xval + (fac-1)*(xval-scalingdistance-smoothness/2d0)
  else if (abs(xval).le.scalingdistance) then
     ffunct=xval
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     ffunct = xval + (fac-1) * smoothness * fscaled(xx)
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     ffunct = xval - (fac-1) * smoothness * fscaled(xx)
  else
     print *, "OOGABLAH0"; stop
  endif
end function ffunct

function jfunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: jfunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     jfunct=fac
  else if (xval.ge.scalingdistance+smoothness) then
     jfunct=fac
  else if (abs(xval).le.scalingdistance) then
     jfunct=1d0
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     jfunct = 1d0 + (fac-1d0) * jscaled(xx)
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     jfunct = 1d0 + (fac-1d0) * jscaled(xx)
  else
     print *, "OOGABLAHd"; stop
  endif
end function jfunct

function djfunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: djfunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     djfunct=0
  else if (xval.ge.scalingdistance+smoothness) then
     djfunct=0
  else if (abs(xval).le.scalingdistance) then
     djfunct=0
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     djfunct = (fac-1d0) * djscaled(xx) / smoothness
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     djfunct = (1d0-fac) * djscaled(xx) / smoothness
  else
     print *, "OOGABLAHd"; stop
  endif
end function djfunct

function ddjfunct(xval)
  use myparams
  implicit none
  real*8, intent(in) :: xval
  DATATYPE :: ddjfunct, fac
  real*8 :: xx

  fac=exp((0d0,1d0)*scalingtheta)*scalingstretch

  if (xval.le.(-1)*(scalingdistance+smoothness)) then
     ddjfunct=0
  else if (xval.ge.scalingdistance+smoothness) then
     ddjfunct=0
  else if (abs(xval).le.scalingdistance) then
     ddjfunct=0
  else if (xval.ge.scalingdistance) then
     xx = (xval-scalingdistance)/smoothness
     ddjfunct = (fac-1d0) * ddjscaled(xx) / smoothness**2
  else if (xval.le.(-1)*scalingdistance) then
     xx = (-xval-scalingdistance)/smoothness
     ddjfunct = (fac-1d0) * ddjscaled(xx) / smoothness**2
  else
     print *, "OOGABLAHd"; stop
  endif
end function ddjfunct

!! f happens to go from 0 to 1/2 on (0,1)

function fscaled(xval)
  use constant_parameters !! IN PARENT DIRECTORY
  implicit none
  real*8 :: fscaled,xval,pixval

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  fscaled = (-1d0)/12d0/pi * sin(pixval)**3 - 1d0/2d0/pi * sin(pixval) + xval/2d0
end function fscaled

function jscaled(xval)
  use constant_parameters !! IN PARENT DIRECTORY
  implicit none
  real*8 :: jscaled,xval,pixval

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  jscaled = 1d0/4d0 * cos(pixval)**3 - 3d0/4d0 * cos(pixval) + 0.5d0
end function jscaled

function djscaled(xval)
  use constant_parameters !! IN PARENT DIRECTORY
  implicit none
  real*8 :: djscaled,xval,pixval

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  djscaled = 0.75d0 * pi * sin(pixval)**3

end function djscaled

function ddjscaled(xval)
  use constant_parameters !! IN PARENT DIRECTORY
  implicit none
  real*8 :: ddjscaled,xval,pixval

  if (xval.lt.0d0.or.xval.gt.1d0) then
     print *, "SCALEDERR F",xval; stop
  endif
  pixval=pi*xval
  ddjscaled = 9d0/4d0*pi**2 * sin(pixval)**2 * cos(pixval)
end function ddjscaled

end module jfunctmod

module ivopotmod
  implicit none
  integer :: numocc=(-1)
  DATATYPE, allocatable :: ivopot(:),ivo_occupied(:,:)
end module ivopotmod

module initspfsmod
contains

subroutine init_spfs(inspfs,numloaded,numfrozen,frozenreduced)
  use myparams
  use pmpimod
  use pfileptrmod
  use ivopotmod
  use tinvsubmod
  use eigenmod      !! IN PARENT DIRECTORY
  use lanblockmod   !! IN PARENT DIRECTORY
  use utilmod !! IN PARENT DIRECTORY
  implicit none
  DATATYPE,intent(inout) :: inspfs(totpoints,numspf)
  integer, intent(in) :: numloaded,numfrozen
  DATATYPE,intent(in) :: frozenreduced(totpoints)
  DATATYPE,allocatable :: lanspfs(:,:),density(:)
  DATAECS,allocatable :: energies(:)
  !$$
  DATAECS,allocatable :: mybigspfham(:,:), bigvects(:,:), bigenergies(:)
  !! AUTOMATIC ::  DATAECS :: mybigspfham(totpoints,totpoints), bigvects(totpoints,totpoints), bigenergies(totpoints)
  integer :: ibig,iorder,ispf,ppfac,ii,jj,kk,olist(numspf),flag
  integer :: null1,null2,null3,null4,null10(10),numcompute

  if (ivoflag.ne.0) then
     if (numloaded.le.0) then
        OFLWR "error, for ivo must load orbitals",numloaded; CFLST
     endif
     numcompute = numspf + max(0,num_skip_orbs) - numloaded
  else
     numcompute = numspf + num_skip_orbs
  endif

  if (numcompute.lt.0) then
     OFLWR "error numcompute lt 0 ", numloaded,numspf; CFLST
  endif
  if (numcompute.eq.0) then
     OFLWR "numcompute eq 0 RETURN"; CFL
     return
  endif
  if (numspf-numloaded.le.0) then
     OFLWR "numget eq 0 return", numspf-numloaded; CFL
     return
  endif

  if (ivoflag.ne.0) then
     kk=0
  else
     if (num_skip_orbs.lt.0) then
        kk=numloaded+num_skip_orbs
     else
        kk=numloaded
     endif
  endif

  ii=1
  do while (ii.le.numspf-numloaded)
     kk=kk+1
     flag=0
     do jj=1,num_skip_orbs
        if (orb_skip(jj).eq.kk) then
           flag=1
           exit
        endif
     enddo
     if (flag.eq.0) then
        olist(ii)=kk
        ii=ii+1
     endif
  enddo

  if (kk.gt.numcompute) then
     OFLWR "FSFFD EEEEE 555",kk,numspf,num_skip_orbs; CFLST
  endif

  if (ivoflag.ne.0) then
     OFLWR "getting IVO pot.  occupations are "
     WRFL loadedocc(1:numloaded); CFL

     allocate(ivopot(totpoints), density(totpoints),ivo_occupied(totpoints,numloaded))
     ivopot(:)=0d0; density(:)=0d0; ivo_occupied=0d0

     numocc=numloaded
     ivo_occupied(:,:)=inspfs(:,1:numloaded)
     do ispf=1,numloaded

        call gramschmidt(totpoints,ispf-1,totpoints,ivo_occupied(:,:),ivo_occupied(:,ispf),orbparflag)

        density(:)=density(:)+ivo_occupied(:,ispf)*CONJUGATE(ivo_occupied(:,ispf))*loadedocc(ispf)
     enddo
     call op_tinv(density,ivopot,1,1,null1,null2,null3,null4,null10)
     deallocate(density)

     if (numfrozen.gt.0) then
        ivopot(:)=ivopot(:)+frozenreduced(:)
     endif
  endif

  allocate(lanspfs(totpoints,numcompute),energies(numcompute))
  lanspfs=0; energies=0

  ibig=totpoints
  ppfac=1
  if (orbparflag) then
     ppfac=nprocs
  endif
  iorder=min(ibig*ppfac,orblanorder)

  if (eigmode.ne.0) then
     OFLWR "CALL BLOCK LAN FOR ORBS, ",numcompute," VECTORS",orbparflag; CFL
     call blocklanczos0(numcompute,numcompute,ibig,ibig,iorder,ibig*ppfac,lanspfs,ibig,&
          energies,1,0,orblancheckmod,orblanthresh,mult_bigspf,orbparflag,orbtargetflag,orbtarget)
     OFLWR "BLOCKLAN CALLED. ENERGIES: ";CFL
  else
     OFLWR "Exact Diagonalization with vector size ",totpoints; CFL
     !$$
     allocate(mybigspfham(totpoints,totpoints),bigvects(totpoints,totpoints), &
          bigenergies(totpoints))
     call getbigspfham(mybigspfham(:,:))
     bigvects=0; bigenergies=0
     call ECSEIG(mybigspfham,ibig,ibig,bigvects,bigenergies)
     lanspfs(:,:) = bigvects(:,1:numcompute)
     energies(:) = bigenergies(1:numcompute)
     !$$
     deallocate(mybigspfham,bigvects,bigenergies)
     OFLWR "DIRECT DIAG CALLED. ENERGIES: ";CFL
  endif
  if (ivoflag.ne.0) then
     deallocate(ivopot,ivo_occupied)
  endif

  do ispf=1,numcompute
     OFLWR ispf,energies(ispf); CFL
  enddo
  OFLWR;  CFL

  do ispf=1,numspf-numloaded
     inspfs(:,ispf+numloaded)=lanspfs(:,olist(ispf))
  enddo

  deallocate(lanspfs,energies)

contains

  subroutine ivo_project(inbigspf,outbigspf)
    use myparams
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    integer :: ii
    outbigspf(:)=0d0
    do ii=1,numocc
       outbigspf(:)=outbigspf(:) + ivo_occupied(:,ii) * ivodot(ivo_occupied(:,ii),inbigspf(:),totpoints)
    enddo

  end subroutine ivo_project

  function ivodot(inbra,inket,size)
    use myparams
    use mpisubmod    !! IN PARENT DIRECTORY
    implicit none
    integer,intent(in) :: size
    DATATYPE,intent(in) :: inbra(size),inket(size)
    DATATYPE :: ivodot,csum
    csum=DOT_PRODUCT(inbra,inket)
    if (orbparflag) then
       call mympireduceone(csum)
    endif
    ivodot=csum
  end function ivodot

  subroutine mult_bigspf_ivo(inbigspf,outbigspf)
    use myparams
    use orbmultsubmod   !! IN PARENT DIRECTORY
    use orbprojectmod   !! IN PARENT DIRECTORY
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    DATATYPE :: tempspf(totpoints),inwork(totpoints),inwork2(totpoints),&
         workspf(totpoints)   !! AUTOMATIC

    tempspf=0; inwork=0; inwork2=0; workspf=0

    call ivo_project(inbigspf,outbigspf)
    call project_onfrozen(inbigspf,workspf)
    outbigspf=outbigspf+workspf

    inwork2(:)=inbigspf(:)-outbigspf(:)

    outbigspf(:)=outbigspf(:) * (1d2)

    call mult_ke(inwork2(:),inwork(:),1,"booga",2)

    call mult_pot(1,inwork2(:),tempspf(:))

    inwork(:) = inwork(:) + tempspf(:) + ivopot(:)*inwork2(:)

    call ivo_project(inwork,inwork2)
    call project_onfrozen(inwork,workspf)
    inwork2=inwork2+workspf

    outbigspf(:) = outbigspf(:) + inwork(:) - inwork2(:)

  end subroutine mult_bigspf_ivo

  subroutine mult_bigspf0(inbigspf,outbigspf)
    use myparams
    use orbmultsubmod   !! IN PARENT DIRECTORY
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    DATATYPE :: tempspf(totpoints)   !! AUTOMATIC

    tempspf=0

    call mult_ke(inbigspf(:),outbigspf(:),1,"booga",2)

    call mult_pot(1,inbigspf(:),tempspf(:))
    outbigspf(:)=outbigspf(:)+tempspf(:)

  end subroutine mult_bigspf0

  subroutine mult_bigspf(inbigspf,outbigspf)
    use myparams
    implicit none
    DATATYPE,intent(in) :: inbigspf(totpoints)
    DATATYPE, intent(out) :: outbigspf(totpoints)
    if (ivoflag.eq.0) then
       call mult_bigspf0(inbigspf,outbigspf)
    else
       call mult_bigspf_ivo(inbigspf,outbigspf)
    endif
  end subroutine mult_bigspf

  subroutine getbigspfham(bigspfham)
    use myparams
    use myprojectmod
    use orbmultsubmod   !! IN PARENT DIRECTORY
    implicit none
    DATAECS,intent(out) :: bigspfham(totpoints,totpoints)
    DATATYPE :: temppot(totpoints) , pot(totpoints)  !! AUTOMATIC
    integer :: ii

    bigspfham = 0; temppot=0; pot=0

    temppot = 1;
    call mult_pot(1,temppot(:),pot(:))

    bigspfham(:,:) = RESHAPE(ketot%mat(:,:,:,:),(/totpoints,totpoints/));
    do ii=1,totpoints
       bigspfham(ii,ii) = bigspfham(ii,ii) + pot(ii)
    enddo

  end subroutine getbigspfham

end subroutine init_spfs

end module initspfsmod

subroutine init_project(inspfs,spfsloaded,pot,halfniumpot,rkemod,proderivmod,skipflag,&
     bondpoints,bondweights,elecweights,elecradii,notused,&
     numfrozen, infrozens, frozenkediag, frozenpotdiag, frozenreduced, notusedreduced)
  use myparams
  use pmpimod
  use pfileptrmod
  use myprojectmod
  use jfunctmod
  use initspfsmod
  use gettwoemod
  implicit none
  integer, intent(in) :: skipflag,notused
  integer,intent(inout) :: spfsloaded
  DATATYPE,intent(inout) :: inspfs(totpoints, numspf)
  DATATYPE,intent(out) :: pot(totpoints),proderivmod(numr,numr),rkemod(numr,numr),&
       bondpoints(numr),bondweights(numr), elecweights(totpoints,3),elecradii(totpoints),&
       halfniumpot(totpoints)
  integer,intent(in) :: numfrozen
  DATATYPE,intent(in) :: infrozens(totpoints,numfrozen)
  DATATYPE,intent(out) :: frozenkediag, frozenpotdiag, &
       frozenreduced(totpoints)
  DATATYPE :: notusedreduced(totpoints)

#ifndef REALGO
  real*8,allocatable :: temppot(:)
#endif
  real*8 :: rsum,pi
  character (len=2) :: th(4)
  integer ::  i,   j,ii,jj,k,l,ilow,ihigh

!! smooth exterior scaling
  DATATYPE,allocatable :: scalefunction(:), djacobian(:), ddjacobian(:)

  pi=4d0*atan(1d0)

#ifndef REALGO
  allocate(temppot(totpoints))
  temppot=0
#endif
  allocate(scalefunction(totpoints), djacobian(totpoints), ddjacobian(totpoints))
  scalefunction=0; djacobian=0; ddjacobian=0

  rkemod(:,:)=0d0; proderivmod(:,:)=0d0; bondpoints(:)=1d0; bondweights(:)=1d0

  elecweights(:,3)=spacing   !! bugfix 011817 was 1/spacing oops
  elecweights(:,1:2)=1d0

  call sineDVR(kevect%rmat(1-gridpoints:gridpoints-1),&
       fdvect%rmat(1-gridpoints:gridpoints-1), sinepoints%mat(:,:),gridpoints,spacing)

  kevect%cmat(:)=kevect%rmat(:)
  fdvect%cmat(:)=fdvect%rmat(:)

  ilow=1; ihigh=nbox
  if (orbparflag) then
     ilow=myrank; ihigh=myrank
  endif
  ii=(ilow-1)*numpoints

  if (toepflag.eq.0) then
     do i=ilow,ihigh
        do j=1,numpoints
           ii=ii+1
           jj=0
           do k=1,nbox
              do l=1,numpoints
                 jj=jj+1
                 ketot%mat(l,k,j,i)=kevect%rmat(ii-jj)
                 fdtot%mat(l,k,j,i)=fdvect%rmat(ii-jj)
                 ketot%tam(l,j,k,i)=kevect%rmat(ii-jj)
                 fdtot%tam(l,j,k,i)=fdvect%rmat(ii-jj)
              enddo
           enddo
        enddo
     enddo

     !! (e.g. coulmode < 0 disables centrifugal)
     !!
     if (twomode .eq. 1 .and. coulmode .ge. 0) then  !! soft coulomb fix
        if (numpoints.ne.totpoints) then
           OFLWR "Error, bad points",numpoints,totpoints; CFLST
        endif
        if (toepflag.ne.0) then
           OFLWR "ERROR, toep not supported with twmode.ne.0 (softcoul)"; CFLST
        endif
        OFLWR "ADDING CENTRIFUGAL"; CFL
        call addit(ketot%mat)    !!! not ketot%tam, can't use ketot%tam
        ketot%tam = 0
     endif  !! two coulmode >=0
  endif

  th=(/ "st", "nd", "rd", "th" /)

!!$  if (skipflag.gt.1) then
!!$     return
!!$  endif

  call get_dipoles()

  if (scalingflag.ne.0) then

     if (debugflag.eq.54321) then
        OFLWR "#Testing scaling..."; CFL
        if (myrank.eq.1) then
           open(76333,file="Contour.Dat",status="unknown")
           do i=-100,100
              rsum=i/100d0*spacing*gridpoints/2d0
              write(76333,'(100F12.5)') rsum, ffunct(rsum), jfunct(rsum), djfunct(rsum), ddjfunct(rsum)
           enddo
           close(76333)
        endif
        call mpibarrier()
        OFLWR "#Done testing scaling"; CFLST
     endif

     OFLWR "Getting scaling..."; CFL

     do i=1,totpoints
        scalefunction(i)=ffunct(real(dipoles(i),8))
        jacobian(i)=jfunct(real(dipoles(i),8))
        djacobian(i)=djfunct(real(dipoles(i),8))
        ddjacobian(i)=ddjfunct(real(dipoles(i),8))
     enddo

     invjacobian(:)=1d0/jacobian(:)

     invsqrtjacobian(:)=sqrt(invjacobian(:))

     invsqrtscaleweights(:) = sqrt(invjacobian(:))

     scalediag(:) = 3d0/8d0 * invjacobian(:)**4 * djacobian(:)**2 &
          - 1d0/4d0 * invjacobian(:)**3 * ddjacobian(:)

     elecweights(:,3)=elecweights(:,3)*jacobian(:)

     dipoles(:)=scalefunction(:)
     OFLWR "    ....Ok got scaling."; CFL
  endif

  elecradii(:)=sqrt( dipoles(:)**2 )

  call get_twoe_new(pot)

  if (numfrozen.gt.0) then
     call call_frozen_matels_core(infrozens,numfrozen,frozenkediag,frozenpotdiag,frozenreduced)
  endif

#ifndef REALGO

  if (capflag.gt.0) then
     temppot(:)=0d0
     do i=1,capflag
        if (capmode.eq.1) then
           temppot(:)=temppot(:) + capstrength(i)*( real(elecradii(:),8)/capstart(i) )**cappower(i)
        else
           temppot(:)=temppot(:) + capstrength(i)*( max(0d0,real(elecradii(:),8)-capstart(i)) )**cappower(i)
        endif
     enddo
     temppot(:)= min(maxcap,max(mincap,temppot(:)))
     halfniumpot(:) = (0d0,-1d0) * temppot(:)
     pot(:)=pot(:) + (0d0,-1d0) * temppot(:)
  else
#endif
     halfniumpot(:)=0d0
#ifndef REALGO
  endif
#endif

  if (spfsloaded.lt.numspf) then
     call init_spfs(inspfs(:,:),spfsloaded,numfrozen,frozenreduced)
  endif

!! now add in harmonic

  if (numcenters.gt.0) then
     pot(:) = pot(:) + 0.5d0 * harmstrength * dipoles(:)**2
  endif

  spfsloaded=numspf   !! for mcscf... really just for BO curve to skip eigen

  if (debugflag.eq.90210) then
     OFLWR "TEMPSTOP init_project debugflag 90210"; CFLST
  endif

#ifndef REALGO
  deallocate(temppot)
#endif
  deallocate(scalefunction, djacobian, ddjacobian)

  !! END INIT_PROJECT !!

contains

  !!
  !! for soft coulomb to reproduce p-wave eigvals need to fix up even parity.
  !!    add P 1/x^2 P  where P projects onto even.. l(l+1)/2 = 1 for p-wave centrifugal potential
  !! even 1d functions = p wave   odd 1d functions = s wave
  !!
  subroutine addit(inoutmat)
    use myparams
    use pfileptrmod
    implicit none
    DATATYPE,intent(inout) :: inoutmat(totpoints,totpoints)
    real*8, allocatable :: pproj(:,:), pproj2(:,:), myarray(:), allarray(:)
    integer :: ii, ihalf, ibot, itop, icenter
    real*8 :: dcenter

    if (coulmode<0) then
       OFLWR "error, addit called when coulmode<0, programmer fail"; CFLST
    endif

    if (twomode.ne.1) then
       OFLWR "error, addit called when twomode.ne.1: ", twomode; CFLST
    endif

    allocate(pproj(totpoints,totpoints), pproj2(totpoints,totpoints), &
         myarray(totpoints), allarray(totpoints))
    pproj=0; pproj2=0; myarray=0; allarray=0;

    myarray(:) = 0d0
    dcenter = (1+totpoints)/2d0
    do ii=1,totpoints
       myarray(ii) = (ii-dcenter)*spacing
    enddo

    do icenter=1,numcenters

       if (coulmode==0) then  !! integer quantum numbers even functions
          allarray(:)= 1d0 / ( softness**2 + ( myarray(:) - centershift(icenter)*spacing/2d0 )**2 )
       else                   !! half-integer quantum numbers even functions
          allarray(:)= 0.375d0 / ( softness**2 + ( myarray(:) - centershift(icenter)*spacing/2d0 )**2 )
       endif

       ihalf = floor((totpoints + 1 +1d-8 + centershift(icenter))/2d0)

       itop = min(totpoints,totpoints+centershift(icenter))
       ibot = max(1,centershift(icenter))

       pproj = 0
       do ii=1,totpoints
          pproj(ii,ii) = 1d0
       enddo
       do ii=ibot,ihalf
          pproj(          ii,           ii) =  0.5d0
          pproj(itop+ibot-ii,           ii) =  0.5d0
          pproj(          ii, itop+ibot-ii) =  0.5d0
          pproj(itop+ibot-ii, itop+ibot-ii) =  0.5d0
       enddo

       do ii=1,totpoints
          pproj2(ii,:) = pproj(ii,:) * allarray
       enddo
       inoutmat = inoutmat + MATMUL( pproj2, pproj )

    enddo

    deallocate(myarray,pproj,pproj2,allarray)

  end subroutine addit

  subroutine get_dipoles()
    use myparams
    use myprojectmod
    implicit none
    call get_one_dipole(dipoles(:),qbox,1,1)
  end subroutine get_dipoles

  subroutine get_one_dipole(out,whichbox,nnn,mmm)
    use myparams
    use myprojectmod
    implicit none
    integer,intent(in) :: mmm,nnn,whichbox
    DATATYPE,intent(out) :: out(nnn,numpoints,mmm)
    integer :: jj,ii
    do jj=1,mmm
       do ii=1,numpoints
          out(:,ii,jj)=sinepoints%mat(ii,whichbox)
       enddo
    enddo
  end subroutine get_one_dipole

end subroutine init_project

!! fixed nuclei only for now

subroutine nucdipvalue(notused,dipoles)
  use myparams
  implicit none
  DATATYPE,intent(in) :: notused(1)
  DATATYPE,intent(out) :: dipoles(3)
  integer :: i
  dipoles(:)=0d0
  do i=1,numcenters
     dipoles(3)=dipoles(3) + nuccharges(i) * centershift(i)/2d0 * spacing
  enddo
end subroutine nucdipvalue


! { dg-do compile }
! PR fortran/32088
!
! Test implicitly defined result variables
!
subroutine dummy
contains
  function quadric(a,b) result(c)
  intent(in) a,b; dimension a(0:3),b(0:3),c(0:9)
    c(0)=a(0)*b(0); c(1:3)=a(1:)*b(0)+a(0)*b(1:); c(4:6)=a(1:)*b(1:)
    c(7:9)=(/a(1)*b(2)+b(1)*a(2),a(1)*b(3)+b(1)*a(3),a(2)*b(3)+b(2)*a(3)/)
  end function
end subroutine dummy

subroutine dummy2
implicit none
contains
  function quadric(a,b) result(c) ! { dg-error "no IMPLICIT type" }
  real :: a, b
  intent(in) a,b; dimension a(0:3),b(0:3),c(0:9)
    c(0)=a(0)*b(0); c(1:3)=a(1:)*b(0)+a(0)*b(1:); c(4:6)=a(1:)*b(1:)
    c(7:9)=(/a(1)*b(2)+b(1)*a(2),a(1)*b(3)+b(1)*a(3),a(2)*b(3)+b(2)*a(3)/)
  end function
end subroutine dummy2
end


program test_ijkl
use scf, only: ijkl2intindex, ijkl2intindex2
use utils, only: assert
implicit none

call testijkl(1)
call testijkl(2)
call testijkl(10)
call testijkl(50)

call testijkl2(1)
call testijkl2(2)
call testijkl2(9)
call testijkl2(15)
! Too slow:
!call testijkl2(50)

contains

subroutine testijkl(n)
integer, intent(in) :: n
integer :: i, j, k, l, ijkl
ijkl = 1
do i = 1, n
    do j = 1, i
        do k = 1, n
            do l = 1, k
                if ((i-1)*i/2 + j < (k-1)*k/2 + l) cycle
                call assert(ijkl2intindex(i, j, k, l) == ijkl)
                call assert(ijkl2intindex(j, i, k, l) == ijkl)
                call assert(ijkl2intindex(i, j, l, k) == ijkl)
                call assert(ijkl2intindex(j, i, l, k) == ijkl)
                call assert(ijkl2intindex(k, l, i, j) == ijkl)
                call assert(ijkl2intindex(l, k, i, j) == ijkl)
                call assert(ijkl2intindex(k, l, j, i) == ijkl)
                call assert(ijkl2intindex(l, k, j, i) == ijkl)
                ijkl = ijkl + 1
            end do
        end do
    end do
end do
ijkl = ijkl - 1
! Test the total number of matrix elements:
call assert(ijkl == n * (n**3 + 2*n**2 + 3*n + 2) / 8)
end subroutine

subroutine testijkl2(n)
integer, intent(in) :: n
integer :: i, j, k, l, ijkl
ijkl = 1
do i = 1, n
    do j = 1, i
        do k = 1, i
            do l = 1, i
                if (i == j .and. k < l) cycle
                if (i == k .and. j < l) cycle
                if (i == l .and. j < k) cycle
                call assert(ijkl2intindex2(i, j, k, l) == ijkl)
                call assert(ijkl2intindex2(j, i, l, k) == ijkl)
                call assert(ijkl2intindex2(k, l, i, j) == ijkl)
                call assert(ijkl2intindex2(l, k, j, i) == ijkl)
                ijkl = ijkl + 1
            end do
        end do
    end do
end do
ijkl = ijkl - 1
! Test the total number of matrix elements:
call assert(ijkl == n**2 * (n**2 + 3) / 4)
end subroutine

end program


! This is not a very good module name, but it'll do for this small program
MODULE ising_functions

  USE random_mod
  USE kinds

  IMPLICIT NONE

  CONTAINS

  SUBROUTINE setup_random_spin_grid(grid)

    INTEGER(KIND=INT16), DIMENSION(0:,0:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz
    INTEGER(KIND=INT32) :: i, j
    REAL(KIND=REAL64) :: rand

    sz = SHAPE(grid)
    grid = 0

    ! All outside edge spins are '+'
    grid(0:sz(1), 0) = 1
    grid(0:sz(1), sz(2)-1) = 1
    grid(0, 0:sz(2)) = 1
    grid(sz(1)-1, 0:sz(2)) = 1

    ! Setup random spins

    DO j = 1, sz(2)-2
      DO i = 1, sz(1)-2
        rand = random()*2.0
        ! note our choice of Int16 gets a bit annoying because
        ! literals default to INT32 so we have to add explicit conversions
        grid(i, j) = INT(2*INT(rand) - 1, KIND=INT16)
      END DO
    END DO

  END SUBROUTINE setup_random_spin_grid

  SUBROUTINE setup_alternating_spin_grid(grid)

    INTEGER(KIND=INT16), DIMENSION(0:,0:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz
    INTEGER(KIND=INT32) :: i, j, offset

    sz = SHAPE(grid)

    ! Setup alternating spins:
    ! Set all to 1, then reverse every second
    grid = 1
    DO j = 1, sz(2)-2
      ! This makes sure rows alternate first and second cell flipped
      offset = 0
      IF(MOD(j, 2) .EQ. 1) offset = 1
      DO i = offset+1, sz(1)-2, 2
        grid(i, j) = -1
      END DO
    END DO

  END SUBROUTINE setup_alternating_spin_grid

  SUBROUTINE iterate_ising_grid(grid, beta, J, max_iters, flips)

    INTEGER(KIND=INT16), DIMENSION(0:,0:), INTENT(INOUT) :: grid

    INTEGER, DIMENSION(2) :: sz
    INTEGER(KIND=INT32) :: iter, flips
    INTEGER(KIND=INT32) :: max_iters
    REAL(KIND=REAL64) :: rand, prob, beta, delta_E, J
    INTEGER :: rand_x, rand_y

    sz = SHAPE(grid)

    flips = 0

    !Iterate random flips
    DO iter = 1, max_iters

      ! Pick random pos'n, excluding "ghost" cells
      rand_x = 1+INT(random()*(sz(1)-2))
      rand_y = 1+INT(random()*(sz(2)-2))

      ! Calc energy change
      delta_E = 0.0
      ! I use this odd indenting to line up the terms for easier reading
      delta_E = delta_E + J * grid(rand_x-1, rand_y)  *grid(rand_x, rand_y)
      delta_E = delta_E + J * grid(rand_x,   rand_y-1)*grid(rand_x, rand_y)
      delta_E = delta_E + J * grid(rand_x,   rand_y+1)*grid(rand_x, rand_y)
      delta_E = delta_E + J * grid(rand_x+1, rand_y)  *grid(rand_x, rand_y)

      ! Check for acceptance and perform flip if necessary
      IF (delta_E .LT. 0) THEN
        grid(rand_x, rand_y) = - grid(rand_x, rand_y)
        flips = flips + 1
      ELSE
        rand = random()
        prob = EXP(- beta * delta_E)
        IF (rand .LT. prob) THEN
          grid(rand_x, rand_y) = - grid(rand_x, rand_y)
          flips = flips + 1
        END IF
      END IF

    END DO

  END SUBROUTINE iterate_ising_grid

  FUNCTION grid_magnetization(grid)

    INTEGER(KIND=INT16), DIMENSION(0:,0:), INTENT(INOUT) :: grid
    REAL(KIND=REAL64) :: grid_magnetization

    grid_magnetization = SUM(grid)

  END FUNCTION grid_magnetization

END MODULE ising_functions

PROGRAM main

  !Provided pretty printing module
  USE ascii_display
  USE sleep_mod
  USE command_line

  USE ising_functions

  IMPLICIT NONE

  INTEGER(KIND=INT32):: N
  INTEGER(KIND=INT32):: max_iters
  INTEGER(KIND=INT16), DIMENSION(:,:), ALLOCATABLE :: grid
  INTEGER(KIND=INT32) :: flips
  REAL(KIND=REAL64) :: beta, J, init_mag, final_mag
  LOGICAL :: success
  CHARACTER :: init

  ! Get command line arguments, and if N or T are given, use them
  CALL parse_args
  ! If not given, we should use sensible defaults for the grid size
  ! and number of iterations

  ! Best and simplest way to use cmd line module
  success = get_arg("max_iters", max_iters)
  IF( .NOT. success) THEN
    max_iters = 10000
  END IF

  ! Or in super-short form
  IF( .NOT. get_arg("N", N)) THEN
    N = 40
  END IF
  !Now N either has user-entered value, or is set to 40
  ! Note that the get_arg routine DOES NOT guarantee what happens
  ! to our passed variable N if keyword isn't found, so we can't set
  ! default BEFORE trying the get

  IF( .NOT. get_arg("beta", beta)) THEN
    beta = 10.0
  END IF
  IF( .NOT. get_arg("J", J)) THEN
    J = 1.0
  END IF

  ! Easiest to have "ghost cells" using non-zero indices
  ! So 1:N is the real domain, and 0 and N+1 are extra cells
  ALLOCATE(grid(0:N+1, 0:N+1))

  ! I use a single-character flag for the initial state,
  ! either 'R' for random, 'A' for alternating or 'F' for flat (=1)
  ! and I default to random if not given or not one of the options
  success = get_arg("init", init)
  IF(init == "F" .OR. init == "f") THEN
    ! We can set everything up '+1'
    grid = 1
  ELSE IF(init == "A" .OR. init == "a") THEN
    ! This will set alternating
    CALL setup_alternating_spin_grid(grid)
  ELSE
    ! This will set random spins
    CALL setup_random_spin_grid(grid)
  END IF

  init_mag = grid_magnetization(grid)

  !I chose to show the initial state, and wait for Enter to run
  CALL display_3val_array(grid, .TRUE.)
  CALL wait_for_enter_key

  !Run the iterations and then display again
  CALL iterate_ising_grid(grid, beta, J, max_iters, flips)
  CALL display_3val_array(grid, .TRUE.)

  PRINT*,'Flipped ', flips, ' states (', REAL(flips)/REAL(max_iters)*100, '%)'

  final_mag = grid_magnetization(grid)
  PRINT*, "Initial magnetization", init_mag
  PRINT*, "Final magnetization  ", final_mag, "(", (final_mag/init_mag - 1.0)*100.0, "%)"

END PROGRAM


module m
implicit none
contains
impure elemental subroutine print_pow(i,pow)
integer, intent(in) :: i, pow
print "(i0,'^',i0,' = ',i0)",i, pow, i**pow
end subroutine print_pow
end module m
!
program main
use m, only: print_pow
call print_pow(i=[1,3,5], pow=3) ; print*
call print_pow(i=2, pow=[1,2,3]) ; print*
call print_pow(i=[2,3], pow=[4,5])
end program main
! output:
! 1^3 = 1
! 3^3 = 27
! 5^3 = 125
!
! 2^1 = 2
! 2^2 = 4
! 2^3 = 8
!
! 2^4 = 16
! 3^5 = 243


! PR fortran/84418
! { dg-do run { target vect_simd_clones } }
! { dg-options "-fno-inline" }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

  real :: a(1024), b(1024), c(1024)
  integer :: i
  do i = 1, 1024
    a(i) = 0.5 * i
    b(i) = 1.5 * i
  end do
  !$omp simd
  do i = 1, 1024
    c(i) = foo (a(i), b(i))
  end do
  do i = 1, 1024
    if (c(i).ne.(2 * i)) call abort
  end do
contains
  real function foo (x, y)
    real :: x, y
    !$omp declare simd linear (ref (x, y))
    foo = x + y
  end function
end


     program demo_curvx
     use M_calcomp
     implicit none
     ! based on concepts of CALIFORNIA COMPUTER PRODUCTS, 1968
     character(len=50) :: ibcd
     integer           :: inteq
     ! INITIALIZE GRAPHICS
        call plots(0.0,10.0,0.0,10.0)
     ! DRAW FRAME
        call plot(7.0,0.0,2)
        call plot(7.0,9.0,2)
        call plot(0.0,9.0,2)
        call plot(0.0,0.0,2)
     ! COMMENTS ARE INSERTED
        ibcd='SAMPLE OF SCIENTIFIC SUBROUTINES PACKAGE'
        call symbol(0.7,8.5,0.14,ibcd,inteq,0.0,40)
        ibcd='USING CURVY SUBROUTINE'
        call symbol(0.7,4.25,0.14,ibcd,inteq,0.0,23)
        ibcd='USING CURVX SUBROUTINE'
        call symbol(0.7,8.25,0.14,ibcd,inteq,0.0,23)
     ! TWO PAIRS OF AXES ARE DRAWN
        ibcd=''
        call axis(1.0,4.75,ibcd,-1,5.0,0.0,0.0,1.0)
        call axis(1.0,4.75,ibcd, 1,3.0,90.0,0.0,1.0)
        call axis(1.0,0.75,ibcd,-1,5.0,0.0,0.0,1.0)
        call axis(1.0,0.75,ibcd, 1,3.0,90.0,0.0,1.0)
     ! CURVX IS DRAWN
        call plot(1.0,4.75,-3)
        call curvx(0.1,5.0,2.40,0.0,0.75,2.0,-0.525,3.0,0.075,4.0)
        call plot(-1.0,-4.75,-3)
     ! CURVY IS DRAWN
        call plot(1.0,0.75,-3)
        call curvy(0.1,3.0,9.0,1.26,-6.0,2.52,1.0,3.78,0.0,0.0)
        call plot(-1.0,-0.75,-3)
     ! EQUATIONS ARE DRAWN
        ibcd='Y=0.075X**4-0.525X**3+0.75X**2+2.40'
        call symbol(3.0,7.75,0.09,ibcd,inteq,0.0,35)
        ibcd='X=Y**3.78-6Y**2.52+9Y**1.26'
        call symbol(3.0,3.90,0.09,ibcd,inteq,0.0,27)
        call nframe()
     !  CLOSE GRAPHICS
        call plot(11.0,0.0,999)
     end program demo_curvx


c=======================================================================
c
c     subroutine TESTSDP
c
c     Matrix test if sdp (0) or not definite positive (1)
c
c-----------------------------------------------------------------------
      SUBROUTINE TESTSDP ( n, X, iwork, dwork, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : input matrix (n*n)                          double
c
c     WORKSPACE
c            iwork  : vector (n)                                 integer
c            dwork  : vector ( n*(2*n+7) )                          double
c
c     OUTPUT
c            info   : diagnostic argument                        integer
c                     =0, X is sdp
c                     =1, X is not sdp
c
c     CALL
c            DGEES  : Schur factorization (cf. LAPACK)
c            EVMIN  : minimum value of a vector (utils/utmat.f)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION X(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piwk, pdwk, pdwev, pdwmat
      DOUBLE PRECISION minvp, EPS
      PARAMETER (EPS = 1.E-12)
c
c     external subroutines
      EXTERNAL schur, EVMIN
c
c-----------------------------------------------------------------------
c
c     initialisations
      info  = 0
      minvp = 0.0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwk = 1
c     piw   : pointer for SCHUR  who needs (n)
c
c     Total size of iwork array ( n )
c
c     pointers for double precision work space  : dwork
c     ----------------------------------------------------------
      pdwk = 1
c     pdwk   : pointer for SCHUR  so (n*(n + 6)
      pdwev = pdwk + ( n*( n + 6 ) )
c     pdwev  : pointer for eigenvalues (n)
      pdwmat = pdwev + n
c     pdwmat : pointer for matrix (n*n)
c
c     Total size of work array = ( n*(2*n + 7) )
c
c-----------------------------------------------------------------------
c
c     computation of the eigenvalues
      CALL schur ( n, X, iwork(piwk), dwork(pdwk),
     &             dwork(pdwev), dwork(pdwmat), info )
c
c     minimum eigenvalue
      CALL EVMIN ( n, dwork(pdwev), minvp )
c
c     if spec(X) < 0 --> exit
      IF (minvp .LT. EPS) THEN
         info = 1
         RETURN
      ENDIF
c
      RETURN
      END