MODULE Conversions
    USE Kinds
    IMPLICIT NONE
    !>@brief
    !> This file contains the subroutines used to perform unit conversions and holds the conversion factors used in the code.
    !>@author
    !> Developed by Ian Porter, NRC
    !>@date
    !> April, 2014

    PUBLIC

    !
    ! ** Burnup **
    !
    REAL(r8k), PARAMETER :: MWskgUtoMWdMTU = 1000.0_r8k / 86400.0_r8k! ((1000 kg * 1 day) / (1 Tonne * 86400s))
    !
    ! ** Constants **
    !
    ! Avogadro's Number
    REAL(r8K), PARAMETER :: Avogadro = 6.0221413E23_r8k              ! (molecules / mol)
    ! Boltzmann's Constant
    REAL(r8k), PARAMETER :: Boltzmann = 1.3806505E-23_r8k            ! (J / K)
    ! Gravitational Acceleration
    REAL(r8K), PARAMETER :: Gravity_SI = 9.80665_r8k                 ! (m / s)
    ! Ideal Gas Constant
    REAL(r8K), PARAMETER :: R_JmolK = 8.3144621_r8k                  ! (J / mol - K)
    ! Ideal Gas Constant
    REAL(r8k), PARAMETER :: R_in3psiRlbmol = 10.73159_r8k            ! (in^3*psi)/(Rankine*lb-mol)
    ! Pi
    REAL(r8k), PARAMETER :: pi = 3.1415926535897932_r8k              ! Value for pi
    ! Speed of Light
    REAL(r8K), PARAMETER :: speedlight = 2.99792458E8_r8k            ! (m / s)
    !
    ! ** Distance **
    !
    ! Convert feet to inches
    REAL(r8k), PARAMETER :: fttoin = 12.0_r8k                        ! (inch / ft)
    ! Convert inches to cm
    REAL(r8k), PARAMETER :: intocm = 2.54_r8k                        ! (cm / in)
    ! Convert feet to cm
    REAL(r8k), PARAMETER :: ftocm = (fttoin * intocm)                ! (cm / ft)
    ! Convert feet to m
    REAL(r8k), PARAMETER :: ftom = ftocm / 100.0_r8k                 ! (meter / ft)
    ! Convert inches to to feet
    REAL(r8k), PARAMETER :: intoft = 1.0_r8k / fttoin                ! (ft / in)
    ! Convert inches to mm
    REAL(r8k), PARAMETER :: intomm = 10.0_r8k * intocm               ! (mm / in)
    ! Convert inches to meter
    REAL(r8k), PARAMETER :: intom = 0.01_r8k * intocm                ! (m / in)
    ! Convert meter to feet
    REAL(r8k), PARAMETER :: mtoft = 1.0_r8k / ftom                   ! (ft / m)
    ! Convert cm to feet
    REAL(r8k), PARAMETER :: cmtoft = 1.0_r8k / ftocm                 ! (ft / cm)
    ! Convert cm to inches
    REAL(r8k), PARAMETER :: cmtoin = 1.0_r8k / intocm                ! (in / cm)
    ! Convert cm to meter
    REAL(r8k), PARAMETER :: cmtom = 0.01_r8k                         ! (m / cm)
    ! Convert meter to inches
    REAL(r8k), PARAMETER :: mtoin = 100.0_r8k * cmtoin               ! (in / m)
    ! Convert meter to cm
    REAL(r8k), PARAMETER :: mtocm = 1.0_r8k / cmtom                  ! (cm / m)
    ! Convert meter to mil
    REAL(r8k), PARAMETER :: mtomil = 1000.0_r8k  * mtoin             ! (m / mil)
    ! Convert mil to meter
    REAL(r8k), PARAMETER :: miltom = 1.0_r8k / mtomil                ! (mil / m)
    ! Convert mil to foot
    REAL(r8k), PARAMETER :: miltoft = 0.001_r8k * intoft             ! (ft / mil)
    ! Convert foot to mil
    REAL(r8k), PARAMETER :: fttomil = 1.0_r8k / miltoft              ! (mil / ft)
    ! Convert mil to millimeter
    REAL(r8k), PARAMETER :: miltomm = 0.01_r8k * intocm              ! (mm / mil)
    ! Convert mil to micrometer
    REAL(r8k), PARAMETER :: miltoum = 10.0_r8k * intocm              ! (micrometer / mil)
    ! Convert micrometer to mil
    REAL(r8k), PARAMETER :: umtomil = 0.1_r8k * cmtoin               ! (mil / micrometer)
    ! Convert micrometer to meter
    REAL(r8k), PARAMETER :: umtom = 1.0E-6_r8k                       ! (meter / micrometer)
    !
    ! ** Area **
    !
    ! Convert ft^2 to in^2
    REAL(r8k), PARAMETER :: ft2toin2 = fttoin ** 2                   ! (in^2 / ft^2)
    ! Convert ft^2 to m^2
    REAL(r8k), PARAMETER :: ft2tom2 = ftom ** 2                      ! (in^2 / ft^2)
    ! Convert in^2 to cm^2
    REAL(r8k), PARAMETER :: in2tocm2 = intocm ** 2                   ! (cm^2 / in^2)
    ! Convert in^2 to cm^2
    REAL(r8k), PARAMETER :: in2tom2 = intom ** 2                     ! (cm^2 / in^2)
    ! Convert in^2 to ft^2
    REAL(r8k), PARAMETER :: in2toft2 = intoft ** 2                   ! (ft^2 / in^2)
    !
    ! ** Volume **
    !
    ! Convert ft^3 to in^3
    REAL(r8k), PARAMETER :: ft3toin3 = fttoin ** 3                   ! (in^3 / ft^3)
    ! Convert ft^3 to m^3
    REAL(r8k), PARAMETER :: ft3tom3 = ftom ** 3                      ! (m^3 / ft^3)
    ! Convert in^3 to cm^3
    REAL(r8k), PARAMETER :: in3tocm3 = intocm ** 3                   ! (cm^3 / in^3)
    ! Convert in^3 to mm^3
    REAL(r8k), PARAMETER :: in3tomm3 = intomm ** 3                   ! (m^3 / in^3)
    ! Convert in^3 to m^3
    REAL(r8k), PARAMETER :: in3tom3 = intom ** 3                     ! (m^3 / in^3)
    ! Convert in^3 to ft^3
    REAL(r8k), PARAMETER :: in3toft3 = intoft ** 3                   ! (ft^3 / in^3)
    ! Convert cm^3 to in^3
    REAL(r8k), PARAMETER :: cm3toin3 = cmtoin ** 3                   ! (in^3 / cm^3)
    ! Convert cm^3 to m^3
    REAL(r8k), PARAMETER :: cm3tom3 = cmtom ** 3                     ! (m^3 / cm^3)
    ! Convert m^3 to cm^3
    REAL(r8k), PARAMETER :: m3tocm3 = mtocm ** 3                     ! (cm^3 / m^3)
    ! Convert m^3 to in^3
    REAL(r8k), PARAMETER :: m3toin3 = mtoin ** 3                     ! (in^3 / m^3)
    !
    ! ** Time **
    !
    ! Convert day to hour
    REAL(r8k), PARAMETER :: daytohr = 24.0_r8k                       ! (hour / day)
    ! Convert day to seconds
    REAL(r8k), PARAMETER :: daytosec = 86400.0_r8k                   ! (second / day)
    ! 1 day
    REAL(r8k), PARAMETER :: oneday = daytosec                        ! 1 day in seconds
    ! Convert day to year
    REAL(r8k), PARAMETER :: daytoyr = 1.0_r8k / 365.25_r8k           ! (yr / day)
    ! Convert hour to day
    REAL(r8k), PARAMETER :: hrtoday = 1.0_r8k / daytohr              ! (day / hour)
    ! Convert hour to seconds
    REAL(r8k), PARAMETER :: hrtosec = 3600.0_r8k                     ! (second / hour)
    ! Convert second to hour
    REAL(r8k), PARAMETER :: sectohr = 1.0_r8k / hrtosec              ! (hour / second)
    ! Convert second to day
    REAL(r8k), PARAMETER :: sectoday = 1.0_r8k / daytosec            ! (second / day)
    ! Convert years to days
    REAL(r8k), PARAMETER :: yrtoday = 1.0_r8k / daytoyr              ! (day / year)
    ! Convert years to seconds
    REAL(r8k), PARAMETER :: yrtosec = 3.1536E7_r8k                   ! (second / year)
    !
    ! ** Energy **
    !
    ! Convert BTU/lb to J/kg
    REAL(r8k), PARAMETER :: BTUlbtoJkg = 2326.000292_r8k             ! (J/kg / BTU/lb)
    ! Convert J/kg to BTU/lb
    REAL(r8k), PARAMETER :: JkgtoBTUlb = 1.0_r8k / BTUlbtoJkg        ! (BTU/lb / J/kg)
    !
    ! ** Heat Conductance (Thermal Conductivity) **
    !
    ! Convert Btu/(hr*ft*F) to W/(m*K)
    REAL(r8k), PARAMETER :: BhftFtoWmK = 1.73073467_r8k              ! (W/m*K / Btu/hr*ft*F)
    ! Convert W/(m*K) to Btu/(hr*ft*F)
    REAL(r8k), PARAMETER :: WmKtoBhftF = 1.0_r8k / BhftFtoWmK        ! (Btu/hr*ft*F / W/m*K)
    ! Convert W/(m*K) to Btu/(s*ft*F)
    REAL(r8k), PARAMETER :: WmKtoBsftF = WmKtoBhftF / 3600.0_r8k     ! (Btu/s*ft*F / W/m*K)
    ! Convert Btu/(hr*ft*F) to Btu/(sec*ft*F)
    REAL(r8k), PARAMETER :: BhftFtoBsftF = 1.0_r8k / hrtosec         ! (Btu/(sec*ft*F) / Btu/(hr*ft*F))
    ! Convert Btu/(sec*ft*F) to Btu/(hr*ft*F)
    REAL(r8k), PARAMETER :: BsftFtoBhftF = hrtosec                   ! (Btu/(hr*ft*F) / Btu/(sec*ft*F))
    !
    ! ** Heat Capacity **
    !
    ! Convert Btu/(lb*F) to J/(kg*K)
    REAL(r8k), PARAMETER :: BtulbFtoJkgK = 4183.995381_r8k           ! (J/kg*K / Btu/lb*F) or (J/kg*C)
    ! Convert J/(kg*K) to Btu/(lb*F)
    REAL(r8k), PARAMETER :: JkgKtoBtulbF = 1.0_r8k / BtulbFtoJkgK    ! (Btu/lb*F / J/kg*K) or (J/kg*C)
    !
    ! ** Heat Flux **
    !
    ! Convert (Btu/(hr*ft^2)) to (W/m^2)
    REAL(r8k), PARAMETER :: Bhft2toWm2 = 3.152481_r8k                ! (W/m2) / (Btu/h*ft2)
    ! Note:  3.154590745 (BTU(IT)) or 3.152481 (BTU(TH))
    ! Convert (Btu/(hr*ft^2)) to (W/m^2)
    REAL(r8k), PARAMETER :: Wm2toBhft2 = 1.0_r8k / Bhft2toWm2        ! (Btu/h*ft2) / (W/m2)
    !
    ! ** Heat Transfer Coefficients **
    !
    ! Convert Btu/(hr*ft^2*F) to W/(m^2*K)
    ! Note: 5.6744658974 (BTU(TH)) or 5.6782633411 (BTU(IT))
    REAL(r8k), PARAMETER :: Bhft2FtoWm2K = 5.6782633411_r8k          ! Convert gap HTC (W/(m^2*K) / Btu/hr*ft^2*F)
    ! Convert W/(m^2*K) to Btu/(hr*ft^2*F)
    REAL(r8k), PARAMETER :: Wm2KtoBhft2F = 1.0_r8k / Bhft2FtoWm2K    ! Convert gap HTC (Btu/(hr*ft^2*F) / W/(m^2*K))
    !
    ! ** Mass **
    !
    ! Convert lb to grams
    REAL(r8k), PARAMETER :: lbtog = 453.5923699997481_r8k            ! (grams / lb)
    ! Convert grams to lb
    REAL(r8k), PARAMETER :: gtolb = 1.0_r8k / lbtog                  ! (lb / gram)
    ! Convert kg to grams
    REAL(r8k), PARAMETER :: kgtog = 1000.0_r8k                       ! (grams / kg)
    ! Convert grams to kg
    REAL(r8k), PARAMETER :: gtokg = 1.0_r8k / kgtog                  ! (kg / gram)
    !
    ! ** Mass Flux **
    !
    ! Convert kg/(s*m^2) to lbm/(hr*ft^2)
    REAL(r8k), PARAMETER :: ksm2tolbhrft2 = 737.3422919_r8k          ! (lbm/(hr*ft^2) / kg/(s*m^2))
    ! Convert lbm/(hr*ft^2) kg/(s*m^2)
    REAL(r8k), PARAMETER :: lbhrft2toksm2 = 1.0_r8k / ksm2tolbhrft2  ! (kg/(s*m^2) / lbm/(hr*ft^2))
    !
    ! ** Density **
    !
    ! Convert lb/ft3 to kg/m3
    REAL(r8k), PARAMETER :: lbft3tokgm3 = 16.0184634_r8k             ! (kg/m^3 / lb/ft^3)
    ! Convert kg/m3 to lb/ft3
    REAL(r8k), PARAMETER :: kgm3tolbft3 = 1.0_r8k / lbft3tokgm3      ! (lb/ft^3 / kg/m^3)
    ! Convert kg/m3 to g/in3
    REAL(r8k), PARAMETER :: kgm3togin3 = kgtog / m3toin3             ! (g/in^3 / kg/m^3)
    !
    ! ** Specific Volume **
    !
    ! Convert ft3/lb to m3/kg
    REAL(r8k), PARAMETER :: ft3lbtom3kg = 1.0_r8k / lbft3tokgm3      ! (m^3/kg / ft^3/lb)
    ! Convert m3/kg to ft3/lb
    REAL(r8k), PARAMETER :: m3kgtoft3lb = 1.0_r8k / ft3lbtom3kg      ! (ft^3/lb / m^3/kg)
    !
    ! ** Power **
    !
    ! Convert watt to btu/hr
    ! Note: 3.41214163513 (BTU(IT)) or 3.41442595 (BTU(TH))
    REAL(r8k), PARAMETER :: WtoBTUh = 3.41442595_r8k                 ! (Btu/hr / W)
    ! Convert watt to btu/s
    REAL(r8k), PARAMETER :: WtoBTUs = WtoBTUh / hrtosec              ! (Btu/second / W)
    ! Convert kilowatt to btu/hr
    REAL(r8k), PARAMETER :: kWtoBTUh = WtoBTUh * 1.0E3_r8k           ! (Btu/hr / kW)
    ! Convert kilowatt to btu/s
    REAL(r8k), PARAMETER :: kWtoBTUs = kWtoBTUh / hrtosec            ! (Btu/second / kW)
    ! Convert megawatt to btu/hr
    REAL(r8k), PARAMETER :: MWtoBTUh = WtoBTUh * 1.0E6_r8k           ! (Btu/hr / MW)
    ! Convert megawatt to btu/s
    REAL(r8k), PARAMETER :: MWtoBTUs = MWtoBTUh / hrtosec            ! (Btu/second / MW)
    ! Convert btu/hr to watt
    REAL(r8k), PARAMETER :: BTUhtoW = 1.0_r8k / WtoBTUh              ! (W / Btu/hr)
    ! Convert btu/hr to kilowatt
    REAL(r8k), PARAMETER :: BTUhtokW = 1.0_r8k / kWtoBTUh            ! (kW / Btu/hr)
    ! Convert btu/hr to megawatt
    REAL(r8k), PARAMETER :: BTUhtoMW = 1.0_r8k / MWtoBTUh            ! (MW / Btu/hr)
    ! Convert btu/s to watt
    REAL(r8k), PARAMETER :: BTUstoW = 1.0_r8k / WtoBTUs              ! (W / Btu/sec)
    ! Convert btu/s to kilowatt
    REAL(r8k), PARAMETER :: BTUstokW = 1.0_r8k / kWtoBTUs            ! (kW / Btu/sec)
    ! Convert btu/s to megawatt
    REAL(r8k), PARAMETER :: BTUstoMW = 1.0_r8k / MWtoBTUs            ! (MW / Btu/sec)
    ! Convert kW/m to kW/ft
    REAL(r8k), PARAMETER :: kWmtokWft = ftom                         ! (kW/ft / kW/m)
    ! Convert kW/ft to kW/m
    REAL(r8k), PARAMETER :: kWfttokWm = 1.0_r8k / kWmtokWft          ! (kW/m / kW/ft)
    ! Convert kW/ft to W/m
    REAL(r8k), PARAMETER :: kWfttoWm = 1.0E3_r8k * kWfttokWm         ! (W/m / kW/ft)
    ! Convert W/m to kW/ft
    REAL(r8k), PARAMETER :: WmtokWft = 1.0_r8k / kWfttoWm            ! (kW/ft / W/m)
    ! Convert W/cm^3 to kW/m^3
    REAL(r8k), PARAMETER :: Wcm3tokWm3 = 1.0E-3_r8k / cm3tom3        ! (kW/m^3 / W/cm^3)
    !
    ! ** Power Density **
    !
    ! Convert btu/hr*ft^3 to watt/m^3
    REAL(r8k), PARAMETER :: BTUhft3toWm3 = BTUhtoW / ft3tom3         ! (W / Btu/hr)
    !
    ! ** Pressure **
    !
    ! Convert atm to psi
    REAL(r8k), PARAMETER :: ATMtoPSI = 14.6959488_r8k                ! (psi / atm)
    ! Convert psi to atm
    REAL(r8k), PARAMETER :: PSItoATM = 1.0_r8k / ATMtoPSI            ! (atm / psi)
    ! Convert psi to lb/ft^2
    REAL(r8k), PARAMETER :: PSItolbft2 = 144.0_r8k                   ! (lb/in^2 / lb/ft^2)
    ! Convert kg/cm^2 to psi
    REAL(r8k), PARAMETER :: kgcm2toPSI = 14.2233433_r8k              ! (psi / kg-Force/cm^2)
    ! Convert psi to kg/cm^2
    REAL(r8k), PARAMETER :: PSItokgcm2 = 1.0_r8k / kgcm2toPSI        ! (kg-Force/cm^2 / psi)
    ! Convert psi to kPa
    REAL(r8k), PARAMETER :: PSItokPa = 6.89475728_r8k                ! (kPa / psi)
    ! Convert psi to Pa
    REAL(r8k), PARAMETER :: PSItoPa = 1.0E3_r8k * PSItokPa           ! (Pa / psi)
    ! Convert psi to MPa
    REAL(r8k), PARAMETER :: PSItoMPa = 1.0E-3_r8k * PSItokPa         ! (MPa / psi)
    ! Convert Pa to psi
    REAL(r8k), PARAMETER :: PatoPSI = 1.0_r8k / PSItoPa              ! (Pa / psi)
    ! Convert MPa to psi
    REAL(r8k), PARAMETER :: MPatoPSI = 1.0_r8k / PSItoMPa            ! (Pa / psi)
    !
    ! ** Viscosity **
    !
    ! Convert kg/m*s to lbm/ft*hr
    REAL(r8k), PARAMETER :: kgmstolbfthr = 2419.088310502_r8k        ! (lbm/ft*hr / kg/m*s)
    ! Convert lbm/ft*hr to kg/m*s
    REAL(r8k), PARAMETER :: lbfthrtokgms = 1.0_r8k / kgmstolbfthr    ! (kg/m*s / lbm/ft*hr)
    !
    CONTAINS
    !
    ! ** Temperature Conversion Functions **
    !
    !
    ! ** Temperature Conversion Functions **
    !
    PURE ELEMENTAL FUNCTION tkf (T_Kelvin) RESULT (T_Fahrenheit)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion: K to F
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 3/14/2016
    REAL(r8k), INTENT(IN) :: T_Kelvin
    REAL(r8k) :: T_Fahrenheit

    T_Fahrenheit = (T_Kelvin * 1.8_r8k) - 459.67_r8k

    END FUNCTION tkf
    !
    !
    !
    PURE ELEMENTAL FUNCTION tfr (T_Fahrenheit) RESULT (T_Rankine)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion function: convert  F  to  R
    REAL(r8k), INTENT(IN) :: T_Fahrenheit
    REAL(r8k) :: T_Rankine

    T_Rankine = T_Fahrenheit + 459.67_r8k

    END FUNCTION tfr
    !
    !
    !
    PURE ELEMENTAL FUNCTION tkc (T_Kelvin) RESULT (T_Celcius)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion: Kelvin to Celcius
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 3/23/2016
    REAL(r8k), INTENT(IN) :: T_Kelvin
    REAL(r8k) :: T_Celcius

    T_Celcius = T_Kelvin - 273.15_r8k

    END FUNCTION tkc
    !
    !
    !
    PURE ELEMENTAL FUNCTION tck (T_Celcius) RESULT (T_Kelvin)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion: Celcius to Kelvin
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 3/23/2016
    REAL(r8k), INTENT(IN) :: T_Celcius
    REAL(r8k) :: T_Kelvin

    T_Kelvin = T_Celcius + 273.15_r8k

    END FUNCTION tck
    !
    !
    !
    PURE ELEMENTAL FUNCTION trc (T_Rankine) RESULT (T_Celcius)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion function: convert  R  to  C
    REAL(r8k), INTENT(IN) :: T_Rankine
    REAL(r8k) :: T_Celcius

    T_Celcius = (T_Rankine / 1.8_r8k) - 273.15_r8k

    END FUNCTION trc
    !
    !
    !
    PURE ELEMENTAL FUNCTION tfk (T_Fahrenheit) RESULT (T_Kelvin)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion: F to K
    !>@author
    !> Ian Porter, NRC
    !>@date
    !> 3/14/2016
    REAL(r8k), INTENT(IN) :: T_Fahrenheit
    REAL(r8k) :: T_Kelvin

    T_Kelvin = (T_Fahrenheit + 459.67_r8k) / 1.8_r8k

    END FUNCTION tfk
    !
    !
    !
    PURE ELEMENTAL FUNCTION tcr (T_Celcius) RESULT (T_Rankine)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion function: convert  C  to  R
    REAL(r8k), INTENT(IN) :: T_Celcius
    REAL(r8k) :: T_Rankine

    T_Rankine = ((T_Celcius * 1.8_r8k) + 32.0_r8k) + 459.67_r8k

    END FUNCTION tcr
    !
    !
    !
    PURE ELEMENTAL FUNCTION tfc (T_Fahrenheit) RESULT (T_Celcius)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion function: convert  F  to  C
    REAL(r8k), INTENT(IN) :: T_Fahrenheit
    REAL(r8k) :: T_Celcius

    T_Celcius = (T_Fahrenheit - 32.0_r8k) / 1.8_r8k

    END FUNCTION tfc
    !
    !
    !
    PURE ELEMENTAL FUNCTION tcf (T_Celcius) RESULT (T_Fahrenheit)
    USE Kinds, ONLY : r8k
    IMPLICIT NONE
    !>@brief
    !> Temperature conversion function: convert  C  to  F
    REAL(r8k), INTENT(IN) :: T_Celcius
    REAL(r8k) :: T_Fahrenheit

    T_Fahrenheit = (T_Celcius * 1.8_r8k) + 32.0_r8k

    END FUNCTION tcf
    !
END MODULE Conversions


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FRWFFT
      IMPLICIT NONE
C
C Purpose: Forward fourier transform
C
      INCLUDE 'COMMON.FOR'
C
C Calls   8: COSQT  , DAWRT  , FFT1D , FILL   , GETCHN , GETHDR
C            GETXAX , OPNFIL
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    COSTAB(513),PI,RSIGN,RSTEP
      INTEGER ICLO,JOP,IRC,IFRAME,IHFMAX,IFRMAX,IMEM,NCHANX
      INTEGER KREC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC
      INTEGER NFRAME,NCHAN,ICH1,ICH2,I,J,K
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM,PFNAM,XFNAM
C
C ICLO   : Close file indicator
C JOP    : Open file indicator
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C KREC   : Output file record
C ISPEC  : Frame nos. part of filename
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Modulus output header filename
C PFNAM  : Phase output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NCHANX : Nos. of points in x-axis
C COSTAB : Cosine table
C RSIGN  : Sign of real component of fft
C
      DATA  IMEM/1/ , PI/3.141592654/
C
C-----------------------------------------------------------------------
      WRITE (IPRINT,*) 'X-axis'
      CALL GETXAX (NCHANX,IRC)
      IF (IRC.NE.0) GOTO 999
10    ICLO=0
      JOP=0
      KREC=0
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     1             ILFR,IFINC,IHFMAX,IFRMAX,NCHAN,IRC)
      IF (IRC.NE.0) GOTO 999
C
      IFRAME=IHFMAX+IFRMAX-1
      CALL GETCHN (ITERM,IPRINT,NCHAN,ICH1,ICH2,IRC)
      IF (IRC.NE.0) GOTO 10
      CALL COSQT (11,COSTAB)
      DO 40 I=1,IHFMAX
C
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHAN,NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 30 J=1,IFRMAX
               READ (JUNIT,REC=IFFR) (SP1(K),K=1,NCHAN)
               IFFR=IFFR+IFINC
               KREC=KREC+1
C
               CALL FILL (SP3,2048,0.0)
               CALL FILL (SP4,2048,0.0)
               DO 20 K=ICH1,ICH2
                  SP3(K)=SP1(K)
20             CONTINUE
               CALL FFT1D (SP3,SP4,COSTAB,11,30,-1)
               DO 25 K=1,NCHAN
                  RSIGN=SIGN (1.0,SP3(K))
                  SP1(K)=SQRT(SP3(K)*SP3(K)+SP4(K)*SP4(K))
                  IF (SP3(K).EQ.0) SP3(K)=1.0E-20
                  SP2(K)=ATAN(SP4(K)/SP3(K))
                  IF (RSIGN.LT.0.0) SP2(K)=SP2(K)+PI
25             CONTINUE
C
               IF (IFRAME.EQ.1) CALL APLOT (ITERM,IPRINT,SP1,NCHAN)
               IF (KREC.GE.IFRAME) ICLO=1
               IF (KREC.EQ.1) THEN
                  WRITE (IPRINT,*) 'Modulus output'
                  CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 60
               ENDIF
               XFNAM=OFNAM
               CALL DAWRT (KUNIT,OFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1                     SP1,KREC,JOP,ICLO,IRC)
               IF (IRC.NE.0) GOTO 60
               IF (KREC.EQ.1) THEN
                  JOP=0
                  WRITE (IPRINT,*) 'Phase output'
                  CALL OUTFIL (ITERM,IPRINT,PFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 60
               ENDIF
               CALL DAWRT (KUNIT,PFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1                     SP2,KREC,JOP,ICLO,IRC)
               IF (IRC.NE.0) GOTO 60
30          CONTINUE
            CLOSE (UNIT=JUNIT)
         ENDIF
40    CONTINUE
      RSTEP=1.0/((XAX(2)-XAX(1))*2048.)
      XAX(1)=0.
      DO 50 I=2,NCHAN
        XAX(I)=XAX(I-1)+RSTEP
50    CONTINUE
      JOP=0
      ICLO=1
      IFRAME=1
      KREC=1
      XFNAM(10:10)='X'
      CALL DAWRT (KUNIT,XFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1            XAX,KREC,JOP,ICLO,IRC)
60    CLOSE (UNIT=JUNIT)
      GOTO 10
999   RETURN
      END


subroutine classifier
use fdeclarations

implicit none

!V classification
ucl1=(uvla+uvlb)/2
ucl2=(ulc+uld)/2
ucl3=(umc+umd)/2
ucl4=(uhc+uhd)/2

do i=1,ii
if (dmatrix(i,1)<=ucl1) then
cmatrix(i,1)=1
else if (dmatrix(i,1)>ucl1 .and. dmatrix(i,1)<=ucl2) then
cmatrix(i,1)=2
else if (dmatrix(i,1)>ucl2 .and. dmatrix(i,1)<=ucl3) then
cmatrix(i,1)=3
else if (dmatrix(i,1)>ucl3 .and. dmatrix(i,1)<=ucl4) then
cmatrix(i,1)=4
else if (dmatrix(i,1)>ucl4) then
cmatrix(i,1)=5
end if
end do

!D classification
dcl1=(dvla+dvlb)/2
dcl2=(dlc+dld)/2
dcl3=(dmc+dmd)/2
dcl4=(ddc+ddd)/2
do i=1,ii
if (dmatrix(i,2)<=dcl1) then
cmatrix(i,2)=1
else if (dmatrix(i,2)>dcl1 .and. dmatrix(i,2)<=dcl2) then
cmatrix(i,2)=2
else if (dmatrix(i,2)>dcl2 .and. dmatrix(i,2)<=dcl3) then
cmatrix(i,2)=3
else if (dmatrix(i,2)>dcl3 .and. dmatrix(i,2)<=dcl4) then
cmatrix(i,2)=4
else if (dmatrix(i,2)>dcl4) then
cmatrix(i,2)=5
end if
end do

if (vers==1) then
!Classification of S in 8 categories
do i=1,ii
if (dmatrix(i,3) .eq. 0.020) then
cmatrix(i,3)=1
else if (dmatrix(i,3) .eq. 0.022) then
cmatrix(i,3)=2
else if (dmatrix(i,3) .eq. 0.024) then
cmatrix(i,3)=3
else if (dmatrix(i,3) .eq. 0.026) then
cmatrix(i,3)=4
else if (dmatrix(i,3) .eq. 0.030) then
cmatrix(i,3)=5
else if (dmatrix(i,3) .eq. 0.040) then
cmatrix(i,3)=6
else if (dmatrix(i,3) .eq. 0.050) then
cmatrix(i,3)=7
else if (dmatrix(i,3) .eq. 0.070) then
cmatrix(i,3)=8
end if
end do
else
scl1=(svla+svlb)/2
scl2=(slc+sld)/2
scl3=(smc+smd)/2
scl4=(sdc+sdd)/2
do i=1,ii
if (dmatrix(i,3)<=scl1) then
cmatrix(i,3)=1
else if (dmatrix(i,3)>scl1 .and. dmatrix(i,3)<=scl2) then
cmatrix(i,3)=2
else if (dmatrix(i,3)>scl2 .and. dmatrix(i,3)<=scl3) then
cmatrix(i,3)=3
else if (dmatrix(i,3)>scl3 .and. dmatrix(i,3)<=scl4) then
cmatrix(i,3)=4
else if (dmatrix(i,3)>scl4) then
cmatrix(i,3)=5
end if
end do
end if

!T classification in 5 classes
tcl1=(tvla+tvlb)/2
tcl2=(tlc+tld)/2
tcl3=(tmc+tmd)/2
tcl4=(thc+thd)/2
do i=1,ii
if (dmatrix(i,4)<=tcl1) then
cmatrix(i,4)=1
else if (dmatrix(i,4)>tcl1 .and. dmatrix(i,4)<=tcl2) then
cmatrix(i,4)=2
else if (dmatrix(i,4)>tcl2 .and. dmatrix(i,4)<=tcl3) then
cmatrix(i,4)=3
else if (dmatrix(i,4)>tcl3 .and. dmatrix(i,4)<=tcl4) then
cmatrix(i,4)=4
else if (dmatrix(i,4)>tcl4) then
cmatrix(i,4)=5
end if
end do

!Classification of IHS in 5 classes
do i=1,ii
if (dmatrix(i,5)<=ka) then
cmatrix(i,5)=1
else if (dmatrix(i,5)>ka .and. dmatrix(i,5)<=kb) then
cmatrix(i,5)=2
else if (dmatrix(i,5)>kb .and. dmatrix(i,5)<=kc) then
cmatrix(i,5)=3
else if (dmatrix(i,5)>kc .and. dmatrix(i,5)<=kd) then
cmatrix(i,5)=4
else if (dmatrix(i,5)>kd) then
cmatrix(i,5)=5
end if
end do

end subroutine classifier


!------------------------------------------------------------------------------!
!		>>> 2D Heat Equation tutorial - Hybrid OpenMP/MPI >>>
!------------------------------------------------------------------------------!
!------------------------------------------------------------------------------!
!Parallel Code Implementation with MPI
!To run in Cowboy Cluster (OSU):
!          	module load openmpi-1.4/intel
!          	mpif90 -openmp 2D_Heat_Equation_MP_MPI.f90
!		   	qsub mexp.job (mbatch.job or mlong.job)
!------------------------------------------------------------------------------!
!Schemes: 	2th-order central scheme - space
!         	3rd order TVD-RK for time integration
!------------------------------------------------------------------------------!
!BCs: 		Periodic boundary conditions for top and bottom walls (y direction)
!BCs: 		No-slip (i.e. u=0) for left and right walls (in x direction)
!------------------------------------------------------------------------------!
!Domain: 	Square [x:0,2pi]*[y:0,2pi]
!------------------------------------------------------------------------------!
!Authors:	CFDLab.org, cfdlab.osu@gmail.com, romit.maulik@okstate.edu
!			Oklahoma State University, Stillwater
!------------------------------------------------------------------------------!
!Updated: 	Dec 2, 2017
!------------------------------------------------------------------------------!
program heatmpmpi
implicit none

include 'mpif.h'	!MPI header file

!Physics related variables
integer:: nx,ny,nt,nsnap,snapshot
integer :: i,j,k
real*8 :: dx,dy,dt,lx,ly,cfl,tmax
real*8 :: pi,x0,y0,alpha,t,snap_time,a,b
real*8,allocatable :: u(:,:),x(:),y(:)
real*8,allocatable :: u1(:,:),s(:,:)

!MPI related variables
integer               :: myid
integer               :: np
integer               :: ierr
integer 			  :: jip,nsend,ny1,ny_global,ic
real*8 				  :: y_min

common /heatcoeff/ alpha
common /lengths /lx,ly
common /mpivars/myid,nsend,np

!Reading input file
open(10,file='input.txt')
read(10,*)nx
read(10,*)ny_global
read(10,*)cfl
read(10,*)tmax
read(10,*)alpha
read(10,*)nsnap
close(10)

!----------------------------------------------------------------------!
! MPI initialize
!----------------------------------------------------------------------!
      call MPI_INIT(ierr)

      call MPI_Comm_size(MPI_COMM_WORLD, np, ierr)

      call MPI_Comm_rank(MPI_COMM_WORLD, myid, ierr)

!----------------------------------------------------------------------!
! Domain decomposition
! We only consider to decompose in z-direction (simplify)
!----------------------------------------------------------------------!

! Local array dimensions
  ny1 = int(ny_global/np)
  jip = ny_global - np*ny1 - 1

    !load balancing
	if(myid.le.jip) then
    ny=ny1+1
    else
    ny=ny1
    end if

!----------------------------------------------------------------------!
!Global domain:
!y is the streching domain for channel
!----------------------------------------------------------------------!
	pi = 4.0d0*datan(1.0d0)

	!equidistant grid in x
	lx = 2.0d0*pi
	dx = lx/dfloat(nx)

	!equidistant grid in y
	ly = 2.0d0*pi
	dy = ly/dfloat(ny_global)

x0 = 0.0d0
y0 = 0.0d0

if(myid.le.jip) then
y_min= - 0.5d0*dy  + dfloat(myid)*dy*dfloat(ny)
else
y_min= - 0.5d0*dy  + dfloat(myid)*dy*dfloat(ny) + dfloat(jip+1)*dy
end if

!total send and receive points
nsend = (nx+2)!+- 1 point stencil for simple FTCS

! Local grid
! cell-centered grid points:
allocate(x(0:nx+1))
allocate(y(0:ny+1))

!x coordinate
	do i =0, nx+1
    x(i) = x0 - 0.5d0*dx + dfloat(i)*dx
	end do

!y coordinate
	do j =0, ny+1
    y(j) = y0 + y_min + dfloat(j)*dy
	end do

!----------------------------------------------------------------------!
!Problem definition and initialization
!----------------------------------------------------------------------!
!use 1 ghost cells within the domain (1 points overlap between domains)

!Allocate local arrays
allocate(u(0:nx+1,0:ny+1)) 	!primary array for conservative field variables
allocate(u1(0:nx+1,0:ny+1)) !Time integration substage array
allocate(s(0:nx+1,0:ny+1)) 	!Time integration substage array

do j =1, ny
do i =1, nx
    u(i,j) = 0.0d0
end do
end do

!initial conditions for heat equation
call initialize(nx,ny,x,y,u)

!Calculate timestep
dt = cfl*dx*dx/(alpha)

if (myid.eq.0) then
print*,dt
print*,cfl
print*,dx
print*,alpha
end if

!Time integration
!TVDRK3 coefficient
a = 1.0d0/3.0d0
b = 2.0d0/3.0d0
snap_time = 0.0d0
snapshot = 0
t = 0.0d0

do while (t<tmax)
t = t+dt

if (t>snap_time) then
!----------------------------------------------------------------------!
! Wait until all processors come to this point before writing files
!----------------------------------------------------------------------!
call MPI_Barrier(MPI_COMM_WORLD, ierr)
!First plot output
call output(nx,ny,x,y,u,myid,snapshot)
snap_time = snap_time + tmax/dfloat(nsnap)
snapshot = snapshot + 1
end if

	call rhs(nx,ny,dx,dy,u,s)

    !--------------------!
	!Step 1
    !--------------------!
    do j=1,ny
	do i=1,nx
    u1(i,j) = u(i,j) + dt*s(i,j)
    end do
    end do

    !update boundary conditions only x and y (global)
    call bc_xy(nx,ny,u1)

    !--------------------!
	!Step 2
    !--------------------!
	call rhs(nx,ny,dx,dy,u1,s)

    do j=1,ny
	do i=1,nx
    u1(i,j) = 0.75d0*u(i,j) + 0.25d0*u1(i,j) + 0.25d0*dt*s(i,j)
    end do
    end do

    !update boundary conditions
    call bc_xy(nx,ny,u1)

    !--------------------!
	!Step 3
    !--------------------!

	call rhs(nx,ny,dx,dy,u1,s)

    do j=1,ny
	do i=1,nx
    u(i,j) = a*u(i,j) + b*u1(i,j) + b*dt*s(i,j)
    end do
    end do

    !update boundary conditions
    call bc_xy(nx,ny,u)

end do

!----------------------------------------------------------------------!
! MPI final call
!----------------------------------------------------------------------!
call MPI_Finalize(ierr)

end program

!-----------------------------------------------------------------------------------!
!Initial conditions and problem definition
!-----------------------------------------------------------------------------------!
subroutine initialize(nx,ny,x,y,u)
implicit none
integer::nx,ny,i,j!,numthreads,omp_get_num_threads,myid
real*8 ::u(0:nx+1,0:ny+1),x(0:nx+1),y(0:ny+1)

!$omp parallel private (i,j) shared (x,y,u,nx,ny)
!$omp do
do j = 1,ny
  do i = 1,nx
    u(i,j) = dsin(x(i))+dcos(y(j))
  end do
end do
!$omp end do
!$omp end parallel

!print*,numthreads

call bc_xy(nx,ny,u)

return
end

!-----------------------------------------------------------------------------------!
!Boundary conditions
!Periodic in y and x
!-----------------------------------------------------------------------------------!
subroutine bc_xy(nx,ny,u)
implicit none
include 'mpif.h'	!MPI header file

integer::nx,ny,i,j,ic,myid,nsend,ierr,np
real*8 ::u(0:nx+1,0:ny+1)

integer,dimension(4) :: req = MPI_REQUEST_NULL
integer               :: status(MPI_STATUS_SIZE)
integer               :: status_array(MPI_STATUS_SIZE,4) !total 4 MPI requests
integer, parameter    :: id_top2bottom_1 = 1000 !message tag
integer, parameter    :: id_bottom2top_1 = 1001 !message tag

common /mpivars/myid,nsend,np

!No slip BCs for x direction (no MPI in this direction)

!$omp parallel private (i,j) shared (u,nx,ny)
!$omp do
do j=1,ny
	u(0,j) =-u(1,j)		!left-wall
	u(nx+1,j) =-u(nx,j)		!right-wall
end do
!$omp end do
!$omp end parallel

!SEND/RECEIVE DATA AMONG BOUNDARY PROCESSORS for y direction

        !MPI based BCs for y direction
        ic = 0
     	!send buffer from top part of the global boundary
     	if (myid .eq. np-1) then
        	ic = ic + 1
     		call MPI_Isend(u(0,ny), nsend, MPI_DOUBLE_PRECISION, &
                       0, id_top2bottom_1, MPI_COMM_WORLD, req(ic), ierr)
     	end if

	 	!send buffer from bottom part of the global boundary
     	if (myid .eq. 0) then
        	ic = ic + 1
       		call MPI_Isend(u(0,1), nsend, MPI_DOUBLE_PRECISION, &
                       np-1, id_bottom2top_1, MPI_COMM_WORLD, req(ic), ierr)
     	end if

     	!receive buffer for bottom part of the global boundary
     	if (myid .eq. 0) then
        	ic = ic + 1
        	call MPI_Irecv(u(0,0), nsend, MPI_DOUBLE_PRECISION, &
                       np-1, id_top2bottom_1, MPI_COMM_WORLD, req(ic), ierr)
     	end if

	 	!receive buffer for top part of the global boundary
     	if (myid .eq. np-1) then
        	ic = ic + 1
       		call MPI_Irecv(u(0,ny+1), nsend, MPI_DOUBLE_PRECISION, &
                       0, id_bottom2top_1, MPI_COMM_WORLD, req(ic), ierr)
     	end if

	 	! To wait until Isend and Irecv in the above are completed
     	call MPI_Waitall(ic, req, status_array, ierr)

    !SEND/RECEIVE DATA AMONG PROCESSORS
	ic = 0
    !send buffer from top part of each local zone
    if (myid .ne. np-1) then
        ic = ic + 1
     	call MPI_Isend(u(0,ny), nsend, MPI_DOUBLE_PRECISION, &
                       myid+1, id_top2bottom_1, MPI_COMM_WORLD, req(ic), ierr)
    end if

	!send buffer from bottom part of each local zone
    if (myid .ne. 0) then
        ic = ic + 1
       	call MPI_Isend(u(0,1), nsend, MPI_DOUBLE_PRECISION, &
                       myid-1, id_bottom2top_1, MPI_COMM_WORLD, req(ic), ierr)
    end if

    !receive buffer for bottom part of each local zone
    if (myid .ne. 0) then
        ic = ic + 1
        call MPI_Irecv(u(0,0), nsend, MPI_DOUBLE_PRECISION, &
                       myid-1, id_top2bottom_1, MPI_COMM_WORLD, req(ic), ierr)
    end if

	!receive buffer for top part of each local zone
    if (myid .ne. np-1) then
        ic = ic + 1
       	call MPI_Irecv(u(0,ny+1), nsend, MPI_DOUBLE_PRECISION, &
                       myid+1, id_bottom2top_1, MPI_COMM_WORLD, req(ic), ierr)
    end if

	! To wait until Isend and Irecv in the above are completed
    call MPI_Waitall(ic, req, status_array, ierr)

return
end

!----------------------------------------------------------------------!
! Output files: ASCII - Tecplot format
!----------------------------------------------------------------------!
subroutine output(nx,ny,x,y,u,myid,snapshot)
implicit none
integer::nx,ny,myid,snapshot
real*8 ::u(0:nx+1,0:ny+1)
real*8 ::x(0:nx+1)
real*8 ::y(0:ny+1)
integer:: i,j
character(80):: charID, snapID, filename

write(charID,'(i5)') myid       !index for each processor
write(snapID,'(i5)') snapshot      !index for time snapshot

filename = 'data_'// trim(adjustl(snapID)) //'_' // trim(adjustl(charID)) // '.dat'
! Define the file name (write all conserved variables)
open(unit=19, file=filename)
! Tecplot header
write(19,*) 'title =', '"Zone_'// trim(adjustl(snapID)) //'_'// trim(adjustl(charID))//'"'
write(19,*) 'variables = "x", "y","u"'

! Open the file and start writing the data
do j = 0, ny
do i = 0, nx
  	write(19,*) x(i),y(j),u(i,j)
end do
end do
close(19)

! Write load information
! Define the file name
filename = "load_"// trim(adjustl(charID)) // '.dat'
open(unit=19, file=filename)
write(19,*)myid,ny
close(19)

end

!----------------------------------------------------------------------!
!Subroutine for heat equation RHS
!----------------------------------------------------------------------!
subroutine rhs(nx,ny,dx,dy,u,s)
implicit none

integer :: nx,ny,i,j
real*8 :: dx, dy, alpha, term1, term2
real*8,dimension(0:nx+1,0:ny+1) :: u,s

common /heatcoeff/ alpha

!$omp parallel private (i,j,term1,term2) shared (u,alpha,nx,ny)
!$omp do
do j = 1,ny
  do i = 1,nx
    term1 = (u(i+1,j)+u(i-1,j)-2.0d0*u(i,j))/(dx*dx)
    term2 = (u(i,j+1)+u(i,j-1)-2.0d0*u(i,j))/(dy*dy)
    s(i,j) = alpha*(term1 + term2)
  end do
end do
!$omp end do
!$omp end parallel

return
end


MODULE modutils
use modalgs
use modcommons
implicit none
private
integer,parameter :: FD_SIZE = QTOOLS_FD_EXPANSION_MAX_ORDER
doubleprecision,dimension(0:FD_SIZE,-FD_SIZE:FD_SIZE) :: v_dnFdxn,v_dnFdyn,v_dnFdzn

public :: qtools_fd_template
public :: v_dnFdxn,v_dnFdyn,v_dnFdzn
public :: dnFdxn,dnFdyn,dnFdzn

contains

subroutine read_filed (UnitNum, FileName, NumRows, NumCols, Array )
  integer, intent (in) :: UnitNum
  character (len=*), intent (in) :: FileName
  integer, intent (in) :: NumRows, NumCols
  double precision, dimension (1:NumRows, 1:NumCols), intent (out) :: Array
  integer :: i, j
  open (unit=UnitNum, file=FileName, status='old', action='read' )
  do i=1, NumRows
     read (UnitNum, *) (Array (i, j), j=1,NumCols)
  end do
  close (UnitNum)
  return
end subroutine read_filed

subroutine read_filei (UnitNum, FileName, NumRows, NumCols, Array )
  integer, intent (in) :: UnitNum
  character (len=*), intent (in) :: FileName
  integer, intent (in) :: NumRows, NumCols
  integer, dimension (1:NumRows, 1:NumCols), intent (out) :: Array
  integer :: i, j
  open (unit=UnitNum, file=FileName, status='old', action='read' )
  do i=1, NumRows
     read (UnitNum, *) (Array (i, j), j=1,NumCols)
  end do
  close (UnitNum)
  return
end subroutine read_filei

integer function qtools_factorial(n) result(rval)
    integer :: n,i
    rval = 1
    do i = 1 , n
        rval = rval * i
    enddo
end function qtools_factorial

integer function qtools_Dij(i,j) result(rval)
    integer :: i,j
    rval = 0
    if(i==j) rval = 1
end function qtools_Dij
! ------------------------------------------------------------------- !
!               FINITE DIFFERENCE EXPANSION GENERATOR
! ------------------------------------------------------------------- !
! Calculate convolution vector for approximated finite difference
! derivative of order (deriv) and error order (order). You can use
! provided internal arrays: dnFdxn,dnFdyn,dnFdzn
! d_array(deriv,convolution) is filled for given deriv and values of
!       convolution are stored in range -m:m where
!       m = floor( (deriv + order - 1)/2 )
! ------------------------------------------------------------------- !
subroutine qtools_fd_template(d_array,deriv,order)
    doubleprecision,dimension(0:FD_SIZE,-FD_SIZE:FD_SIZE) :: d_array
    integer :: order,deriv
    integer :: f,i,n,m,p,d
    doubleprecision, allocatable,dimension(:,:) :: Cni

    ! clean values for given derivative

    d = deriv
    p = order

    m = floor( (p + d - 1.0)/2 )
    if(2*m + 1 /= p + d) then
        p = p + 1 ! fix order of derivative
    endif
    m = floor( (p + d - 1.0)/2 )

    if(deriv > FD_SIZE) then
        print*,"QTOOLS::Required derivative order (d) is to big"
        print*,"        Provided value:",deriv," Max. value:",FD_SIZE
        stop
    endif
    if(    m > FD_SIZE) then
        print*,"QTOOLS::Required derivative error order (p) is to big"
        print*,"        Provided value:",order," Max. value:",FD_SIZE
        stop
    endif

    ! Create coeficient matrix
    allocate(Cni(0:p + d - 1,-m:m))
    Cni = 0
    do n =  0 , p + d - 1
    do i = -m , m
        Cni(n,i) = i**n
    enddo
    enddo
    ! invert and get the values for p-th derivative
    call dalg_invmat(Cni)

    Cni = transpose(Cni)
    f = qtools_factorial(d)
    d_array(deriv,:) = 0
    do i = -m , m
         d_array(deriv,i) = f*Cni(deriv,i)
    enddo
    if(QSYS_DEBUG_LEVEL > 0) then
        print"(A,i3,A,i3)"," QTOOLS::Created FD template for d=",d," derivative of order p=",p
        print*,"        Calculated template (convolution vector):"
        print*,"        | ======================== |"
        print*,"        |  F(x +-i e ) |   VALUE   |"
        print*,"        | ======================== |"
        do i = -m , -1
             print"(A,i2,A,f10.6,A)","         | F( x -",-i,"*e ) |",d_array(deriv,i)," |"
        enddo
        print"(A,f10.6,A)","         |    F( x )    |",d_array(deriv,i)," |"
        do i =  1 , m
             print"(A,i2,A,f10.6,A)","         | F( x +",i,"*e ) |",d_array(deriv,i)," |"
        enddo
        print*,"        | ======================== |"
    endif
    deallocate(Cni)
end subroutine qtools_fd_template

doubleprecision function dnFdxn(n,dx,dy,dz) result(rval)
    integer :: n,dx,dy,dz
    rval = v_dnFdxn(n,dx)*qtools_Dij(0,dy)*qtools_Dij(0,dz)
end function dnFdxn

doubleprecision function dnFdyn(n,dx,dy,dz) result(rval)
    integer :: n,dx,dy,dz
    rval = v_dnFdyn(n,dy)*qtools_Dij(0,dx)*qtools_Dij(0,dz)
end function dnFdyn

doubleprecision function dnFdzn(n,dx,dy,dz) result(rval)
    integer :: n,dx,dy,dz
    rval = v_dnFdzn(n,dz)*qtools_Dij(0,dx)*qtools_Dij(0,dy)
end function dnFdzn

END MODULE modutils


subroutine test_arithmetic(var1, var2, var3)

use mydatatypes, only: float64

implicit none

var1 = 100._float64 * var2

if (var2 >= 0.5_float64 + var3) then
  var2 = var3 * (1._float64 - var2)
end if

end subroutine test_arithmetic


module numbers
    use, intrinsic :: iso_c_binding, only : C_FLOAT, C_DOUBLE, C_DOUBLE_COMPLEX, &
                                            C_INT32_T, C_INT64_T

    ! Floating point numbers
    integer, parameter :: sp  = C_FLOAT
    integer, parameter :: dp  = C_DOUBLE
    integer, parameter :: dpc = C_DOUBLE_COMPLEX

    ! Integer numbers
    integer, parameter :: i4 = C_INT32_T
    integer, parameter :: i8 = C_INT64_T

    ! Formats

    ! (sign=1) + (leading=1) + (dot=1) + (eps=8)  + (exp=4) = 15
    character(*), parameter :: sp_f = 'es16.8'
    character(*), parameter :: sp_len = 'A16'
    ! (sign=1) + (leading=1) + (dot=1) + (eps=16)  + (exp=5) = 24
    character(*), parameter :: dp_f = 'es25.16'
    character(*), parameter :: dp_len = 'A25'

    ! (sign=1) + (digits=5) = 6
    character(*), parameter :: i2_f = 'i7'
    character(*), parameter :: i2_len = 'A7'
    ! (sign=1) + (digits=10) = 11
    character(*), parameter :: i4_f = 'i12'
    character(*), parameter :: i4_len = 'A12'
    ! (sign=1) + (digits=19) = 20
    character(*), parameter :: i8_f = 'i21'
    character(*), parameter :: i8_len = 'A21'

    ! Constants
    complex(dpc), parameter :: imag_1 = (0, 1.0_dp)
    real(dp), parameter :: PI = 4.0_dp * ATAN(1.0_dp)

    ! https://numpy.org/doc/stable/reference/generated/numpy.finfo.html
    ! "The difference between 1.0 and the next smallest representable float
    !  larger than 1.0."
    real(dp), parameter :: epsilon = 2.221e-16_dp
    ! "The smallest positive floating point number with full precision."
    real(dp), parameter :: tiny = 2.226e-308_dp

    ! threshold below which floats will be considered as zero
    real(dp), parameter :: small = 1.222e-77_dp

    contains

    logical function are_equal(a,b)
        ! this should not be used if either a or b can be zero!
        real(dp), intent(in) :: a,b
        real(dp) :: reldiff

        are_equal = .false.
        reldiff = abs(a - b) / max(abs(a),abs(b))
        if (reldiff < epsilon) are_equal = .true.

    end function are_equal

end module numbers


program tables
  implicit none
  integer :: i,j
  do i=1,12
    do j=1,12
      write (*,'(i4)',advance='NO') i * j
    end do
    print *
  end do
end program tables


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c ... file helmsph.f
c
c     this file contains a program for solving the Helmholtz
c     equation with constant 1.0 on a ten degree grid on the full sphere
c
c ... required spherepack files
c
c     islapec.f, shaec.f, shsec.f, sphcom.f, hrfft.f
c
c ... description
c
c     let theta be latitude and phi be east longitude in radians.
c     and let
c
c
c       x = cos(theta)*sin(phi)
c       y = cos(theta)*cos(phi)
c       z = sint(theta)
c
c     be the cartesian coordinates corresponding to theta and phi.
c     on the unit sphere.  The exact solution
c
c        ue(theta,phi) = (1.+x*y)*exp(z)
c
c     is used to set the right hand side and compute error.
c
c
c **********************************************************************
C
c OUTPUT FROM EXECUTING THE PROGRAM BELOW
c WITH 32 AND 64 BIT FLOATING POINT ARITHMETIC
c
c Helmholtz approximation on a ten degree grid
c nlat = 19   nlon = 36
c xlmbda =  1.00   pertrb =  0.000E+00
c maximum error =  0.715E-06 *** (32 BIT)
c maximum error =  0.114E-12 *** (64 BIT)
c
c ***********************************************
c ***********************************************
      program helmsph
c
c     set grid size with parameter statements
c
      implicit none
      integer nnlat,nnlon,nn15,llsave,llwork,lldwork
      parameter (nnlat=19,nnlon=36)
c
c     set saved and unsaved work space lengths in terms of nnlat,nnlon
c     (see documentation for shaec,shsec,islapec)
c
      parameter (nn15=nnlon+15)
      parameter (llsave=nnlat*(nnlat+1)+3*((nnlat-2)*(nnlat-1)+nn15))
      parameter (llwork=nnlat*(2*nnlon+3*(nnlat+1)+2*nnlat+1))
c
c     set double precision work space length for initializations
c
      parameter (lldwork = nnlat+1)
c
c     dimension arrays
c
      real u(nnlat,nnlon),r(nnlat,nnlon)
      real sint(nnlat),cost(nnlat),sinp(nnlon),cosp(nnlon)
      real work(llwork),wshaec(llsave),wshsec(llsave)
      double precision dwork(lldwork)
      real a(nnlat,nnlat),b(nnlat,nnlat)
      integer nlat,nlon,i,j,lshaec,lshsec,lwork,ierror,isym,nt
      integer ldwork
      real pi,x,y,z,dlat,dlon,theta,phi,xlmbda,pertrb,ez,ue,errm
      pi = 4.0*atan(1.0)
c
c     set helmholtz constant
c
      xlmbda = 1.0
c
c     set work space length arguments
c
      lwork = llwork
      ldwork = lldwork
      lshaec = llsave
      lshsec = llsave
c
c     set grid size arguments
c
      nlat = nnlat
      nlon = nnlon
c
c     set sine and cosine vectors
c
      dlat = pi/(nlat-1)
      dlon = (pi+pi)/nlon
      do i=1,nlat
       theta = -0.5*pi+(i-1)*dlat
       sint(i) = sin(theta)
       cost(i) = cos(theta)
      end do
      do j=1,nlon
       phi = (j-1)*dlon
       sinp(j) = sin(phi)
       cosp(j) = cos(phi)
      end do
c
c     set right hand side as helmholtz operator
c     applied to ue = (1.+x*y)*exp(z)
c
      do j=1,nlon
       do i=1,nlat
	x = cost(i)*cosp(j)
	y = cost(i)*sinp(j)
	z = sint(i)
	r(i,j) = -(x*y*(z*z+6.*(z+1.))+z*(z+2.))*exp(z)
       end do
      end do
c
c     initialize saved work space arrays for scalar harmonic
c     analysis and Helmholtz inversion of r
c
      CALL SHAECI(NLAT,NLON,WSHAEC,LSHAEC,DWORK,LDWORK,IERROR)
      if (ierror .gt. 0) then
      write (6,200) ierror
  200 format(' shaeci, ierror = ',i2)
      call exit(0)
      end if
      CALL SHSECI(NLAT,NLON,WSHSEC,LSHSEC,DWORK,LDWORK,IERROR)
      if (ierror .gt. 0) then
      write (6,201) ierror
  201 format(' shseci, ierror = ',i2)
      call exit(0)
      end if
c
c     set no symmetry and one array
c
      isym = 0
      nt = 1
c
c     compute coefficients of r for input to islapec
c
      call shaec(nlat,nlon,isym,nt,r,nlat,nlon,a,b,nlat,nlat,
     +           wshaec,lshaec,work,lwork,ierror)
      if (ierror .gt. 0) then
      write(*,202) ierror
  202 format(' shaec , ierror = ',i2)
      call exit(0)
      end if
c
c     solve Helmholtz equation on the sphere in u
c
      write (6,100) nlat,nlon
  100 format(' helmholtz approximation on a ten degree grid'
     +       /' nlat = ',i3,2x,' nlon = ', i3)
      call islapec(nlat,nlon,isym,nt,xlmbda,u,nlat,nlon,a,b,nlat,nlat,
     +             wshsec,lshsec,work,lwork,pertrb,ierror)
      if (ierror .ne. 0) then
      write (6,103) ierror
  103 format(' islapec, ierror = ',i2)
      if (ierror .gt. 0) call exit(0)
      end if
c
c     compute and print maximum error in u
c
      errm = 0.0
      do j=1,nlon
       do i=1,nlat
	x = cost(i)*cosp(j)
	y = cost(i)*sinp(j)
	z = sint(i)
	ez = exp(z)
	ue = (1.+x*y)*ez
	errm = amax1(errm,abs(u(i,j)-ue))
       end do
      end do
      write(*,204) xlmbda,pertrb,errm
  204 format(' xlmbda = ',f5.2,2x, ' pertrb = ' ,e10.3,
     +      /' maximum error = ',e10.3)
      end


program test
      real(kind = 8), parameter :: val1 = 3.14845624E4
      real(kind = 8), parameter :: val2 = 3.14845624E+4
      real(kind = 8), parameter :: val3 = 3.14845624E-4
      print *, val1
      print *, val2
      print *, val3
end program test


      program example5
      implicit none

      integer i, imax, x
      parameter (imax = 3, x = (1+1)*imax-2*(1+1))
      real a(0:imax)

      do i = 0, imax
            a(i) = a(i) + a(i+x)
      end do

      end


MODULE mympi
  !
  ! Description:
  !   Module for mpi to help associating data to multiple processors
  !
  ! Current Code Owner: [Name of person responsible for this code]
  !
  ! History:
  !
  ! Version   Date     Comment
  ! -------   ----     -------
  ! 1.0       11-11-08 Original code. Thomas Hauser
  !
  ! Code Description:
  !   Language:           Fortran 90.
  !   Software Standards: "European Standards for Writing and
  !     Documenting Exchangeable Fortran 90 Code".
  !

  IMPLICIT NONE

CONTAINS

  INTEGER FUNCTION block_owner(j,p,n)
    INTEGER, INTENT(in) :: j,p,n
    block_owner = ((p*(j+1)-1)/n)
    RETURN
  END FUNCTION block_owner

  INTEGER FUNCTION block_low(id,p,n)
    INTEGER, INTENT(in) :: id,p,n
    block_low =  (id*n)/p
    RETURN
  END FUNCTION block_low

  INTEGER FUNCTION block_high(id,p,n)
    INTEGER, INTENT(in) :: id,p,n
    block_high = ((id+1)*n)/p-1
    RETURN
  END FUNCTION block_high

  INTEGER FUNCTION block_size(id,p,n)
    INTEGER, INTENT(in) :: id,p,n
    block_size = (block_low(id+1,p,n)-block_low(id,p,n))
    RETURN
  END FUNCTION block_size

END MODULE mympi


SUBROUTINE erp_igu (filename,mjd_t , erp, igu_flag)

! ----------------------------------------------------------------------
! Subroutine:  erp_igu.f90
! ----------------------------------------------------------------------
! Purpose:
!  Read ERP (Earth Rotation Parameters) data from the ultra rapid products
!  provided by the IGS (International GNSS Service)
! ----------------------------------------------------------------------
! Input arguments:
! - filename:		IGS ultra-rapid ERP data file name  e.g. igu18861_00.erp
! - mjd_t:			Modified Julian Day number at the required epoch
!					(including fraction of the day)
! - igu_flag:       Logical value for reporting if the input epoch is in/out
!					of the time range covered by the ERP file
!   .TRUE.			Input epoch is within the range
!   .FALSE.			Input epoch is out of the range
!
! Output arguments:
! - erp:			Array of the ERP data obtained from the .erp file
!					ERP data are provided for two epochs every 6 hours
!   				erp 2x5 matrix
!   				erp (i,1:5) = [MJD xp yp UT1_UTC LOD]
!   				MJD:     	MJD epoch referred in the .erp file
!   				x,y:     	Polar motion coordinates (arcsec)
!   				UT1_UTC: 	Difference between UT1 and UTC (sec)
!   				LOD: 		Length Of Day (sec)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia               March 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: mjd_t
      CHARACTER (LEN=512), INTENT(IN) :: filename
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: erp(2,5)
      LOGICAL :: igu_flag
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int2) :: UNIT_IN, ios, ios_line, ios_data
      INTEGER (KIND = prec_int8) :: i, erp_i
      CHARACTER (LEN=100) :: Format_eop
      CHARACTER (LEN=170) :: line_ith
      CHARACTER (LEN=20) :: char1, char2
      INTEGER (KIND = prec_int8) :: mjd_day
      REAL (KIND = prec_d) :: mjd_ith, Xpole,Ypole, UT1_UTC,LOD, Xsig,Ysig, UTsig,LODsig, Nr,Nf,Nt, Xrt,Yrt, Xrtsig,Yrtsig
      REAL (KIND = prec_d) :: igu_erp(2,5)
! ----------------------------------------------------------------------

      igu_flag = .TRUE.

! ----------------------------------------------------------------------
      UNIT_IN = 9
      Format_eop = '(F8.2,2X, I6,  2(F12.7),2(F11.6),2(F11.6),2(F11.7),2F12.6)'
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Open data file
      OPEN (UNIT = UNIT_IN, FILE = TRIM (filename), IOSTAT = ios)
      IF (ios /= 0) THEN
         PRINT *, "Error in opening file:", filename
         PRINT *, "OPEN IOSTAT=", ios
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Read data file
! ----------------------------------------------------------------------
      i = 0
      !data_i = 0
      DO
	     READ (UNIT=UNIT_IN,FMT='(A)',IOSTAT=ios_line) line_ith
	     i = i + 1
! ----------------------------------------------------------------------
! End of file
         IF (ios_line < 0) THEN
!            PRINT *, "End of file, i=", i
            EXIT
         END IF
! ----------------------------------------------------------------------
! Data
  	     READ (line_ith, * , IOSTAT=ios_data) char1  ! 1st word
         if (char1 == 'MJD') then
	        READ (UNIT=UNIT_IN,FMT='(A)',IOSTAT=ios_line) line_ith
            do erp_i = 1 , 2
	           READ (UNIT=UNIT_IN,FMT=*,IOSTAT=ios_line) mjd_ith, Xpole, Ypole, UT1_UTC, LOD, &
                                                         Xsig,Ysig, UTsig,LODsig, Nr,Nf,Nt, Xrt,Yrt, Xrtsig,Yrtsig
               ! ERP matrix for the two epochs provided in the *.erp file
               igu_erp (erp_i,1) = mjd_ith
               igu_erp (erp_i,2) = Xpole * 1.0D-6    ! Conversion to arcsec
               igu_erp (erp_i,3) = Ypole * 1.0D-6    ! Conversion to arcsec
               igu_erp (erp_i,4) = UT1_UTC * 1.0D-7  ! Conversion to seconds
               igu_erp (erp_i,5) = LOD * 1.0D-7      ! Conversion to seconds
            end do
         end if
! ----------------------------------------------------------------------
      END DO
      CLOSE (UNIT=UNIT_IN)
! ----------------------------------------------------------------------

! Earth Rotation Parameters of .erp file
         erp = igu_erp

! ----------------------------------------------------------------------
! Test the time coverage
      if ( mjd_t >= igu_erp(1,1) .and. mjd_t <= igu_erp(2,1) ) then
         !erp = igu_erp
         igu_flag = .TRUE.
      else
	     igu_flag = .FALSE.
         !PRINT *,"d_mjd:", mjd_t-igu_erp(1,1), mjd_t-igu_erp(2,1)
         !PRINT *,"igu_erp:", igu_erp
      end if
! ----------------------------------------------------------------------

END


c     program DRSSORT
c>>   1994-10-19 DRSSORT  Krogh  Changes to use M77CON
c>>   1989-06-13 DRSSORT  CLL Changed "sranua (r" to "sranua (d"
c>>   1988-11-20 DRSSORT  Snyder  Initial code.
c--S replaces "?": DR?SORT, ?SORT, ?SORTP, ?RANUA
c
c     Test driver for SSORT and SSORTP.
c
c     Construct an array of 1000 random numbers using SRANUA.
c     Sort it using SSORTP.
c     Check whether it is in order.
c     Sort it using SSORT.
c     Check whether it is in order.
c
      logical OK
      integer I, P(1:1000)
      real             X(1:1000)
c
c     Generate 1000 random numbers
      call sranua (x, 1000)
c     Sort them using SSORTP.  Assume the sort will work.
      ok=.TRUE.
      call ssortp (x,1,1000,p)
c     Check the order.
      do 10 i = 2, 1000
         if (x(p(i)).lt.x(p(i-1))) ok=.FALSE.
   10 continue
c     Print the results.
      if(ok)then
         print *,'SSORTP succeeded'
      else
         print *,'SSORTP failed'
      end if
c     Sort them using SSORT.  Assume the sort will work.
      ok=.TRUE.
      call ssort (x,1,1000)
c     Check the order.
      do 20 i = 2, 1000
         if (x(i).lt.x(i-1)) ok=.FALSE.
   20 continue
c     Print the results.
      if(ok)then
         print *,'SSORT succeeded'
      else
         print *,'SSORT failed'
      end if
c
      end


      SUBROUTINE trncst(x,y,iorder, ncity,n,de)
      INTEGER ncity,iorder(ncity),n(6)
      REAL de,x(ncity),y(ncity)
      INTEGER ii,j
      REAL xx(6),yy(6),alen,x1,x2,y1,y2
      alen(x1,x2,y1,y2)=sqrt((x2-x1)**2+(y2-y1)**2)
      n(4)=1+mod(n(3),ncity)
      n(5)=1+mod((n(1)+ncity-2),ncity)
      n(6)=1+mod(n(2),ncity)
      do 11 j=1,6
        ii=iorder(n(j))
        xx(j)=x(ii)
        yy(j)=y(ii)
11    continue
      de=-alen(xx(2),xx(6),yy(2),yy(6))-alen(xx(1),xx(5),yy(1),
     *yy(5))-alen(xx(3),xx(4),yy(3),yy(4))+alen(xx(1),xx(3),yy(1),
     *yy(3))+alen(xx(2),xx(4),yy(2),yy(4))+alen(xx(5),xx(6),yy(5),yy(6))
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/trncst.for


************************************************************************
*                          RANMAT.FOR                                  *
*                                                                      *
*  PROGRAM: SIMRAND I                                                  *
*  MODULE:  1.5.3.2                                                    *
*  DATE:    01/29/85                                                   *
*                                                                      *
*  THIS IS THE SUBROUTINE RANMAT.  IT CALCULATES THE RANDOM NUMBER     *
*  MATRIX FOR A SINGLE MONTE CARLO TRIAL.                              *
*                                                                      *
*----------------------------------------------------------------------*
*                   CONFIGURATION CHANGES                              *
*                                                                      *
*    DATE                CHANGE                                        *
*                                                                      *
*  01/18/85  * ORIGINAL.                                               *
*  01/29/85  * MODULE  1: JDIAG .EQ. 2.                                *
*            * MODULE  8: JDIAG .EQ. 2.                                *
*                                                                      *
************************************************************************

$TITLE:'RANMAT.LST'
$DEBUG
$NOFLOATCALLS
$STORAGE:2

************************************************************************

      SUBROUTINE RANMAT

************************************************************************

***** INITIALIZE.  {MODULE 1}

      DOUBLE PRECISION RANA,RANC,RANM,RANX,RANDIV,RANT,RANSUB
      LOGICAL          RANCAL

$INCLUDE:'INITIAL.FOR'

      IF (JDIAG .EQ. 2) THEN
         WRITE (*,100)
100      FORMAT (/1X,4X,'ENTER SUBROUTINE RANMAT')
      ENDIF

*     PARAMETERS FOR RANDOM NUMBER GENERATOR.
*     MODULO EQUATION: RANDOM = (RANA*RANDOM + RANC) MODULO RANM.

      RANA   =   671093.0
      RANC   =  7090885.0
      RANM   = 33554432.0

***   {END MODULE 1}

***** START DO LOOPS FOR RANDOM NUMBER MATRIX RANMTX(IA,IX).  {MODULE 2}

      NIXX = NIX - 1
      DO 140 IA=1,NIA
         DO 140 IX=1,NIXX

*****       CALCULATE OR COPY A SINGLE RANDOM NUMBER RANMTX(IA,IX).
*****       {MODULE 3}

            IF (ITASK(IA,IX) .EQ. 0) THEN

*****          NO TASK VARIABLE TO CONSIDER.  {MODULE 4}

               RANMTX(IA,IX) = 0.0

***            {END MODULE 4}

*****       {CONTINUE MODULE 3}

            ELSE

*****          TASK VARIABLE PRESENT.  {MODULE 5}

*              CALCULATE A NEW RANDOM NUMBER IF RANCAL = .TRUE..

               IF (IA .EQ. 1) THEN

*                 ALWAYS CALCULATE A NEW RANDOM NUMBER FOR IA .EQ. 1.

                  RANCAL = .TRUE.

               ELSE

*                 WILL NEED TO CALCULATE A NEW RANDOM NUMBER IF THE TASK
*                 VARIBLE NOT USED BY PRIOR ALTERNATIVE.  OTHERWISE COPY
*                 THE RANDOM NUMBER.

                  NIAA = IA - 1
                  DO 110 IAA=1,NIAA

                     IF (ITASK(IA,IX) .EQ. ITASK(IAA,IX)) THEN

                        RANMTX(IA,IX) = RANMTX(IAA,IX)
                        RANCAL = .FALSE.
                        GO TO 120

                     ELSE

                        RANCAL = .TRUE.

                     ENDIF

110               CONTINUE

120               CONTINUE

               ENDIF

***            END TASK VARIABLE PRESENT.  {END MODULE 5}

*****          CALCULATE A SINGLE RANDOM NUMBER.  {MODULE 6}

               IF (RANCAL) THEN

*                 FOR ACCURACY, DO MODULO ARITHMETIC W/O MODULO FUNCTION.
                  RANX          = RANA*RANDOM + RANC
                  RANDIV        = RANX/RANM
                  RANT          = DINT(RANDIV)
                  RANSUB        = RANT*RANM
                  RANDOM        = RANX - RANSUB
                  RANMTX(IA,IX) = SNGL(RANDOM/RANM)

               ENDIF

***            {END MODULE 6}

            ENDIF

***         END CALCULATE A SINGLE RANDOM NUMBER.  {END MODULE 3}

140   CONTINUE

***   END DO LOOPS FOR IA AND IX.  {END MODULE 2}

***** WRITE RANMTX(IA,IX).  {MODULE 7}

      IF (JDIAG .EQ. 2) THEN

         NIXX = NIX - 1
         DO 170 IA=1,NIA

            IF (NIXX .LE. 5) THEN
               WRITE  (*,150) IA,(RANMTX(IA,IX),IX=1,NIXX)
            ELSE
               WRITE  (*,150) IA,(RANMTX(IA,IX),IX=1,5)
               WRITE  (*,160)    (RANMTX(IA,IX),IX=6,NIXX)
            ENDIF

150         FORMAT (1X,I5,3X,5F14.4)
160         FORMAT (1X,   8X,5F14.4)

170      CONTINUE

      ENDIF

***   {END MODULE 7}

***** EXIT FROM SUBROUTINE RANMAT.  {MODULE 8}

      IF (JDIAG .EQ. 2) THEN
         WRITE (*,999)
999      FORMAT (1X,4X,'EXIT  SUBROUTINE RANMAT')
      ENDIF

      RETURN

      END

***   {END MODULE 8}

***************************** RANMAT.FOR *******************************


      SUBROUTINE DT_MYTRAN(Imode,Xo,Yo,Zo,Cde,Sde,Cfe,Sfe,X,Y,Z)

C***********************************************************************
C This subroutine rotates the coordinate frame                         *
C    a) theta  around y                                                *
C    b) phi    around z      if IMODE = 1                              *
C                                                                      *
C     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
C     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
C     z'          0       0        1     -sin(th)  0  cos(th)   z      *
C                                                                      *
C and vice versa if IMODE = 0.                                         *
C This version dated 5.4.94 is based on the original version DTRAN     *
C by J. Ranft and is written by S. Roesler.                            *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION Cde , Cfe , Sde , Sfe , X , Xo , Y , Yo , Z , Zo
      INTEGER Imode
      SAVE

      INCLUDE 'inc/dtflka'

      IF ( Imode.EQ.1 ) THEN
         X = Cde*Cfe*Xo - Sfe*Yo + Sde*Cfe*Zo
         Y = Cde*Sfe*Xo + Cfe*Yo + Sde*Sfe*Zo
         Z = -Sde*Xo + Cde*Zo
      ELSE
         X = Cde*Cfe*Xo + Cde*Sfe*Yo - Sde*Zo
         Y = -Sfe*Xo + Cfe*Yo
         Z = Sde*Cfe*Xo + Sde*Sfe*Yo + Cde*Zo
      END IF
      END SUBROUTINE


cvk original Noah code
cvk      SUBROUTINE DEVAP (EDIR1,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP,
cvk     &                DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP)

      SUBROUTINE DEVAP (EDIR1,ETP1,SH2O,SHDFAC,SMCMAX,SMCDRY,
     &                  SMCREF,SMCWLT,FXEXP,uztwh,uztwm,bareadj)

      IMPLICIT NONE

C ----------------------------------------------------------------------
C SUBROUTINE DEVAP
C ----------------------------------------------------------------------
C CALCULATE DIRECT SOIL EVAPORATION
C ----------------------------------------------------------------------

cvk  Direct evaporation option: if FXEXP=-1, Chen option; other value, Ek
cvk  Chen option: Mahfouf and Noilhan (1991) method, (S-Swlt)/(Sfld-Swlt)
cvk  M. Ek option: non-linear ((S-Swlt)/(smax-Swlt))**FXEXP
cvk                                     FXEXP usually = 2.0

cfews  excluded options: just Ek-Chen switch
cfews      real xfact,uztwh,uztwm,bareadj,bareadjx,fxexpx
      real uztwh,uztwm,bareadj

C      REAL DEVAP
      REAL EDIR1
      REAL ETP1
      REAL FX
      REAL FXEXP
      REAL SHDFAC
      REAL SH2O
      REAL SMCDRY
      REAL SMCMAX
      REAL SMCREF
      REAL SMCWLT
      REAL SRATIO

cvk 5/2010  added option to switch Chen-Ek option duo to greenness
cvk
cfews      if(bareadj .lt. 0.0) then
cvk  selected switch option
cfews       bareadjx=-bareadj
cfews       if(shdfac .gt. bareadjx) then

       if(shdfac .gt. bareadj) then
cvk  switch to Chen option
cfews        if(FXEXP .le. 0.0) then
cfews         fxexpx=fxexp
cfews        else
cfews         fxexpx=0.0
cfews        endif
cvk 3/10  new Chen option (VK extention)
        SRATIO = (SH2O - SMCDRY) / (SMCREF - SMCDRY)
cfews        if(sratio .lt. 1.0) then
cfews         sratio=sratio*((SMCREF - SMCDRY)/(SMCMAX - SMCDRY))**(-FXEXPX)
cfews        else
cfews         sratio= ((SH2O - SMCDRY)/(SMCMAX - SMCDRY))**(-FXEXPX)
cfews        endif
        if(sratio .gt. 1.0) sratio = 1.0
        EDIR1 = sratio * ( 1.0 - SHDFAC ) * ETP1

       else
cvk  switch to Ek option
cfews        if(FXEXP .le. 0.0) then
cfews         fxexpx=2.0
cfews        else
cfews         fxexpx=fxexp
cfews        endif
        SRATIO = (SH2O - SMCDRY) / (SMCMAX - SMCDRY)
        IF (SRATIO .GT. 0.) THEN
cfews          FX = SRATIO**FXEXPX
          FX = SRATIO**FXEXP
          FX = MAX ( MIN ( FX, 1. ) ,0. )
        ELSE
          FX = 0.
        ENDIF
        EDIR1 = FX * ( 1.0 - SHDFAC ) * ETP1
       endif
cfews      else

c  not switch option; use one defined in input card option
cfews       if(fxexp .le. 0.0) then
c  Chen option only
cfews        SRATIO = (SH2O - SMCDRY) / (SMCREF - SMCDRY)
cfews        if(sratio .lt. 1.0) then
cfews         sratio=sratio*((SMCREF - SMCDRY)/(SMCMAX - SMCDRY))**(-FXEXP)
cfews        else
cfews         sratio= ((SH2O - SMCDRY)/(SMCMAX - SMCDRY))**(-FXEXP)
cfews        endif
cfews        if(sratio .gt. 1.0) sratio = 1.0
cfews        EDIR1 = sratio * ( 1.0 - SHDFAC ) * ETP1
cfews       else
cfews        if(fxexp .ge. 10.) then
c  SAC option only
cfews         sratio=uztwh/uztwm
cfews         EDIR1 = sratio * ( 1.0 - SHDFAC ) * ETP1
cfews         if(edir1 .gt. uztwh) edir1=uztwh
cfews        else
c  Ek option only
C ----------------------------------------------------------------------
C DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR
C WHEN FXEXP=1.
C FX > 1 REPRESENTS DEMAND CONTROL
C FX < 1 REPRESENTS FLUX CONTROL
C ----------------------------------------------------------------------
cfews         SRATIO = (SH2O - SMCDRY) / (SMCMAX - SMCDRY)
cfews         IF (SRATIO .GT. 0.) THEN
cfews           FX = SRATIO**FXEXP
cfews           FX = MAX ( MIN ( FX, 1. ) ,0. )
cfews         ELSE
cfews           FX = 0.
cfews         ENDIF

C ----------------------------------------------------------------------
C ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE
C ----------------------------------------------------------------------
cfews         EDIR1 = FX * ( 1.0 - SHDFAC ) * ETP1
cfews        endif
cfews       endif
cfews      endif
C ----------------------------------------------------------------------
C END SUBROUTINE DEVAP
C ----------------------------------------------------------------------
      RETURN
      END


program test_petsc
use types, only: dp
use constants, only: i_
use petsc_, only: petsc_init, petsc_finalize, solve
implicit none

integer, parameter :: n = 10
complex(dp) :: A(n, n), b(n), x(n)
integer :: i, ierr

A = 0
A(1, 1:2) = [2, -1]
forall(i = 2:n-1) A(i, i-1:i+1) = [-1, 2, -1]
A(n, n-1:n) = [-1, 2]

x = 1+2*i_
b = matmul(A, x)

ierr = petsc_init()
ierr = solve(n, A, b, x)
print *, x
ierr = petsc_finalize()
end


module EVTS_COWELL
! Description:
!    Contains event functions for the Cowell formulation in double- and
!    quad-precision.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: ik,dk,qk
implicit none

contains

subroutine QCOWELL_EVT(neq,t,y,ng,roots)
! Description:
!    Finds roots to stop the integration for the Cowell formulation.
!    Quad precision.
!
! ==============================================================================

! MODULES
use AUXILIARIES, only: RSwitch,inSoI
use CONSTANTS,   only: DU,TU,wEarth,smaEarth

! VARIABLES
implicit none
! Arguments IN
integer(ik),intent(in)   ::  neq
integer(ik),intent(in)   ::  ng
real(qk),intent(in)      ::  t
real(qk),intent(in)      ::  y(1:neq)
! Arguments OUT
real(qk),intent(out)     ::  roots(1:ng)

! Locals
real(qk)  ::  r_geo(1:3)        ! Geocentric position vector [-]
real(qk)  ::  r_Earth(1:3)      ! Heliocentric Earth position vector [-]
real(qk)  ::  lon_Earth         ! Heliocentric Earth longitude [rad]
real(qk)  ::  rMag              ! Geocentric distance [-]

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

! ==============================================================================
! 01. Reaching of switch distance
! ==============================================================================
if (inSoI) then
    r_geo = y(1:3)
else
    lon_Earth = (wEarth/TU)*t
    r_Earth = (smaEarth/DU)*[cos(lon_Earth),sin(lon_Earth),0._qk]
    r_geo = y(1:3) - r_Earth
end if
rMag = sqrt(dot_product(r_geo,r_geo))

roots(1) = rMag - RSwitch/DU

end subroutine QCOWELL_EVT

subroutine DCOWELL_EVT(neq,t,y,ng,roots)
! Description:
!    Finds roots to stop the integration for the Cowell formulation.
!    Quad precision.
!
! ==============================================================================

! MODULES
use AUXILIARIES, only: JD_next,JD_stop
use CONSTANTS,   only: TU,secsPerDay

! VARIABLES
implicit none
! Arguments IN
integer(ik),intent(in)   ::  neq
integer(ik),intent(in)   ::  ng
real(dk),intent(in)      ::  t
real(dk),intent(in)      ::  y(1:neq)
! Arguments OUT
real(dk),intent(out)     ::  roots(1:ng)

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

! ==============================================================================
! 01. Next timestep
! ==============================================================================

roots(1) = t - JD_next*secsPerDay*TU

! ==============================================================================
! 02. Stop integration
! ==============================================================================

roots(2) = t - JD_stop*secsPerDay*TU

end subroutine DCOWELL_EVT

end module EVTS_COWELL


!*****  WIENER  Wiener-Levinson Algorithm         MATH ADVANTAGE REL 3.0
!
!    ** COPYRIGHT 1984-1985 QUANTITATIVE TECHNOLOGY CORPORATION **
!
!  CALL FORMAT
!
!       CALL WIENER (LR,R,G,F,A,IFLG,IERR)
!
!       where,
!
!       LR      Integer input filter length.
!
!       R       Real input vector,
!               auto-correlation coefficients.
!
!       G       Real input vector, right-hand side
!               coefficients.  Not used if IFLG=0.
!
!       F       Real output vector, filter coefficients if IFLG=1;
!                                   stability indicators if IFLG=0.
!
!       A       Real output vector, prediction error operator.
!
!       IFLG    Integer input processing option flag:
!                   =0 for spike deconvolution.
!                   =1 for general deconvolution.
!
!       IERR    Integer output completion code:
!                  =0 if the routine terminated normally.
!                  >0 if a failure occurred. The value of IERR
!                     is the pass number where failure occurred.
!
!
!  DESCRIPTION
!
!       This routine solves a system of single-channel normal
!       equations which arise in least-squares filtering and
!       prediction problems for single-channel time series.
!       It uses a recursive method of solving simultaneous
!       equations.
!
!       It solves:
!
!            1.  The following set of equations for F:
!                      SUM[F(s)*R(1+ABS(t-s))] = G(t)
!                      for s=1,LR  and  t=1,LR
!
!            2.  The following set of equations for A:
!                      SUM[A(s)*R(1+ABS(t-s))] = V*D
!                      for s=1,LR  and  t=1,LR
!
!                where,
!
!                      A(1) = 1.0,
!
!                      D = 1.0 when t=1,
!
!                      (D = 0.0 otherwise),
!
!                      V = A(1)*R(1)+....+A(LR)*R(LR),
!
!       All arrays are LR long.
!
!
!  REFERENCE
!
!       E. A. Robinson.  Multichannel Time Series Analysis with
!       Digital Computer Programming.
!
!       N. Levinson.  1947.  The Wiener RMS (root-mean-square)
!       Error Criterion in Filter Design and Prediction.
!       J. Math. Phys., Vol. 25,  pp. 261-278.
!
!       A. Jurkevics & R. Wiggins.  Dec 1984.  A Critique of
!       Siesmic Deconvolution Methods.  Geophysics, Vol. 49, No. 12.
!       pp. 2109-2116.
!
!
!  EXAMPLE
!
!       For General Deconvolution:
!
!       CALL WIENER (2,R,G,F,A,1,IERR)
!
!       Input Operands:
!
!       R =  10.000
!             4.000
!
!       G =   2.000
!             0.000
!
!
!       Output Operands:
!
!       F =  0.238
!           -0.095
!
!       A =  1.000
!           -0.400
!
!       IERR = 0
!
!
!       For Spike Deconvolution:
!
!       CALL WIENER (2,R,G,F,A,0,IERR)
!
!       Input Operands:
!
!       R =  10.000
!             4.000
!
!       G =   2.000
!             0.000
!
!
!       Output Operands:
!
!       F =  0.200
!           10.000
!
!       A =  1.000
!           -0.400
!
!       IERR = 0
!
!  HISTORY
!         1) May 85     D. Cooper       Original.
!
      SUBROUTINE WIENER(LR,R,G,F,A,IFLG,IERR)
!
      INTEGER LR,IFLG,IERR,ID,L2,IB,IC,LH
      REAL R(*),G(*),F(*),A(*),V,D,Q,AL,AJOLD,FL
      IF (LR.LE.0 .OR. IFLG.LT.0 .OR. IFLG.GT.1) GOTO 9000
      IERR = 0
      V = R(1)
      D = R(2)
      A(1) = 1.0
      F(1) = G(1) / V
      Q = F(1) * R(2)
      IF (LR.EQ.1) GOTO 9000
!
      DO 999 ID = 2, LR
        AL   = - D / V
        A(ID) = AL
        IF (V.GT.0.0) GOTO 100
          IERR = ID
          GOTO 9000
100     CONTINUE
        IF (IFLG.EQ.0) F(ID) = V
        V = V + AL * D
        IF (ID.EQ.2) GOTO 410
          L2 = ID/2
          IF (L2 .LT. 2) GOTO 350
            DO 299 IB=2, L2
! .......     Do pairs of elements of A:
              IC = ID - IB + 1
              AJOLD = A(IB)
              A(IB) = AJOLD + AL * A(IC)
              A(IC) = A(IC)  + AL * AJOLD
299         CONTINUE
350       CONTINUE
          IF (L2+L2.EQ.ID) GOTO 400
! .......   IF ID is Odd, cover the unpaired element:
            LH = L2 + 1
            A(LH) = A(LH) + AL * A(LH)
400       CONTINUE
410     CONTINUE
        IF (IFLG.EQ.0) GOTO 750
! ....... IF General Deconvolution:
          FL   = (G(ID) - Q) / V
          F(ID) = FL
          DO 699 IB = 1, ID-1
            IC = ID - IB + 1
            F(IB) = F(IB) + FL * A(IC)
699       CONTINUE
750     CONTINUE
        IF (ID.EQ.LR) GOTO 9000
! ....... Compute D and Q for next loop iteration.
! ....... Q is used for General Deconvolution, D for both.
        D = 0.0
        Q = 0.0
        DO 899 IB = 1, ID
          IC = ID - IB + 2
          D = D + A(IB)*R(IC)
          Q = Q + F(IB) * R(IC)
899     CONTINUE
999   CONTINUE
!
9000  RETURN
      END


module sphere_mod

    use material_mod
    use vec3_class

    implicit none

    type, extends(hittable) :: sphere
        real       :: radius
        type(vec3) :: centre
        class(material), pointer :: mat_ptr => null()
        contains
        procedure :: hit => hit_sphere
    end type sphere

    interface sphere
        module procedure init_sphere
    end interface sphere

    contains

    type(sphere) function init_sphere(centre, radius, mat)

        implicit none

        type(vec3), intent(IN) :: centre
        real,       intent(IN) :: radius
        class(material), target :: mat

        init_sphere%centre = centre
        init_sphere%radius = radius
        init_sphere%mat_ptr => mat

    end function init_sphere

    logical function hit_sphere(this, ray, t_min, t_max, rec)

        use vec3_class
        use ray_mod

        implicit none

        class(sphere) :: this

        real,             intent(IN)  :: t_min, t_max
        type(ray_t),      intent(IN)  :: ray
        type(hit_record), intent(OUT) :: rec

        type(vec3) :: oc, a_tmp, outward_normal
        real       :: a, c, discrim, half_b, root, sqrtd

        oc = ray%orig - this%centre
        a_tmp = ray%dir
        a = a_tmp%length_squared()
        half_b = oc .dot. ray%dir
        c = oc%length_squared() - this%radius**2
        discrim = half_b**2 - a*c

        if(discrim < 0.)then
            hit_sphere = .false.
            return
        end if

        sqrtd = sqrt(discrim)
        root = (-half_b - sqrtd) / a
        if(root < t_min .or. t_max < root)then
            root = (-half_b + sqrtd) / a
            if(root < t_min .or. t_max < root)then
                hit_sphere = .false.
                return
            end if
        end if

        rec%t = root
        rec%p = ray%at(rec%t)
        outward_normal = (rec%p - this%centre) / this%radius
        call rec%set_face_normal(ray, outward_normal)
        rec%mat_ptr => this%mat_ptr

        hit_sphere = .true.

    end function hit_sphere
end module sphere_mod


!   DGGES3 Example Program Text
!   Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!   For licence see
!     https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

    Module dgges3_example_mod

!     DGGES3 Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public :: selctg
!     .. Parameters ..
      Integer, Parameter, Public :: nb = 64, nin = 5, nout = 6
    Contains
      Function selctg(ar, ai, b)

!       Logical function selctg for use with DGGES3 (DGGES3)
!       Returns the value .TRUE. if the eigenvalue is real and positive

!       .. Function Return Value ..
        Logical :: selctg
!       .. Scalar Arguments ..
        Real (Kind=dp), Intent (In) :: ai, ar, b
!       .. Executable Statements ..
        selctg = (ar>0._dp .And. ai==0._dp .And. b/=0._dp)
        Return
      End Function
    End Module
    Program dgges3_example

!     DGGES3 Example Main Program

!     .. Use Statements ..
      Use blas_interfaces, Only: dgemm
      Use dgges3_example_mod, Only: nb, nin, nout, selctg
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgges3, dlange
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=dp) :: alph, bet, normd, norme
      Integer :: i, ifail, info, lda, ldb, ldc, ldd, lde, ldvsl, ldvsr, lwork, &
        n, sdim
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), alphai(:), alphar(:), b(:, :), &
        beta(:), c(:, :), d(:, :), e(:, :), vsl(:, :), vsr(:, :), work(:)
      Real (Kind=dp) :: dummy(1)
      Logical, Allocatable :: bwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DGGES3 Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldc = n
      ldd = n
      lde = n
      ldvsl = n
      ldvsr = n
      Allocate (a(lda,n), alphai(n), alphar(n), b(ldb,n), beta(n), &
        vsl(ldvsl,n), vsr(ldvsr,n), bwork(n), c(ldc,n), d(ldd,n), e(lde,n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dgges3('Vectors (left)', 'Vectors (right)', 'Sort', selctg, n, a, &
        lda, b, ldb, sdim, alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, &
        dummy, lwork, bwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max(8*n+16+n*nb, nint(dummy(1)))
      Allocate (work(lwork))

!     Read in the matrices A and B
      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Copy A and B into D and E respectively
      d(1:n, 1:n) = a(1:n, 1:n)
      e(1:n, 1:n) = b(1:n, 1:n)

!     Print matrices A and B
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Matrix A', ifail)
      Write (nout, *)
      Flush (nout)

      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, b, ldb, &
        'Matrix B', ifail)
      Write (nout, *)
      Flush (nout)

!     Find the generalized Schur form
      Call dgges3('Vectors (left)', 'Vectors (right)', 'Sort', selctg, n, a, &
        lda, b, ldb, sdim, alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, work, &
        lwork, bwork, info)

      If (info==0 .Or. info==(n+2)) Then

!       Compute A - Q*S*Z^T from the factorization of (A,B) and store in
!       matrix D
        alph = 1.0_dp
        bet = 0.0_dp
        Call dgemm('N', 'N', n, n, n, alph, vsl, ldvsl, a, lda, bet, c, ldc)
        alph = -1.0_dp
        bet = 1.0_dp
        Call dgemm('N', 'T', n, n, n, alph, c, ldc, vsr, ldvsr, bet, d, ldd)

!       Compute B - Q*T*Z^T from the factorization of (A,B) and store in
!       matrix E
        alph = 1.0_dp
        bet = 0.0_dp
        Call dgemm('N', 'N', n, n, n, alph, vsl, ldvsl, b, ldb, bet, c, ldc)
        alph = -1.0_dp
        bet = 1.0_dp
        Call dgemm('N', 'T', n, n, n, alph, c, ldc, vsr, ldvsr, bet, e, lde)

!       Find norms of matrices D and E and warn if either is too large
        normd = dlange('O', ldd, n, d, ldd, work)
        norme = dlange('O', lde, n, e, lde, work)
        If (normd>epsilon(1.0E0_dp)**0.8_dp .Or. norme>epsilon(1.0E0_dp)** &
          0.8_dp) Then
          Write (nout, *) 'Norm of A-(Q*S*Z^T) or norm of B-(Q*T*Z^T) &
            &is much greater than 0.'
          Write (nout, *) 'Schur factorization has failed.'
        Else

!         Print solution
          Write (nout, 100) &
            'Number of eigenvalues for which SELCTG is true = ', sdim, &
            '(dimension of deflating subspaces)'

          Write (nout, *)
!         Print generalized eigenvalues
          Write (nout, *) 'Selected generalized eigenvalues'

          Do i = 1, sdim
            If (beta(i)/=0.0_dp) Then
              Write (nout, 120) i, '(', alphar(i)/beta(i), ',', &
                alphai(i)/beta(i), ')'
            Else
              Write (nout, 130) i
            End If
          End Do
          Write (nout, *)

          If (info==(n+2)) Then
            Write (nout, 140) '***Note that rounding errors mean ', &
              'that leading eigenvalues in the generalized', &
              'Schur form no longer satisfy SELCTG = .TRUE.'
            Write (nout, *)
          End If

        End If

      Else
        Write (nout, 110) 'Failure in DGGES3. INFO =', info
      End If

100   Format (1X, A, I4, /, 1X, A)
110   Format (1X, A, I4)
120   Format (1X, I4, 5X, A, F7.3, A, F7.3, A)
130   Format (1X, I4, 'Eigenvalue is infinite')
140   Format (1X, 2A, /, 1X, A)
    End Program


!!
!! Simple program to generate panels for a quarter sphere
!! The sphere is also stored in a VTK file for Paraview
!! 100212, lb
!!
!!
PROGRAM fourth    ! Every Fortran program starts with a program statement

  !! modules are program units that themselves contain variable
  !! declarations and subroutines and functions.
  !! The contents of the module is made availbe in other program units
  !! with the USE statement

  use precise, only : defaultp
  USE fourthconst  ! incorporates everything from the module
  !USE thirdconst, ONLY : pi ! would only incorporate pi and ignore the rest
  USE sphere ! a second module
  use vtkxmlmod

!! variable declarations

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  integer, parameter :: WP=defaultp

  INTEGER :: narg      ! Integer variables
  INTEGER :: i, j, n
  INTEGER :: ipt, ipn
  INTEGER :: nl, ng   ! controls for panel distribution
  INTEGER :: iounit

  INTEGER :: npoints, npanels

  ! An allocatable array. Its actual size will be defined during
  ! execution of the program.
  ! The array has two dimensions (:,:), i.e. number of comma separated
  ! colons determines dimensions.
  INTEGER, ALLOCATABLE, DIMENSION(:,:) :: panels

  CHARACTER(len=24) :: outputfile  ! file name can be max. 24 char. long
  CHARACTER(len=24) :: datafile1  ! file name can be max. 24 char. long
  CHARACTER(len=24) :: datafile2  ! file name can be max. 24 char. long
  ! if you need longer file names increase the value of len, e.g. len=35
  CHARACTER(len=16) :: argstr  ! string for command line argument

  REAL(WP) :: diameter
  REAL(WP) :: theta, phi
  ! An allocatable array for real values
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: points

  ! an array for data we make up
  REAL(wp), ALLOCATABLE, DIMENSION(:) :: celldata1

  ! Variable declarations go before any executable statement

!! the actual program starts here

  ! Simple start up message
  ! The character A is used for formating character constants and
  ! variables
  WRITE(6,'(A)') 'fourth, v 1.0, 100212, lb'

  ! Count the number command line arguments (actually Fortran 2003)
  ! If your compiler does not support this Fortran 2003 feature look
  ! for the common extension iargc()
  ! narg = iargc()
  narg = command_argument_count()

  IF ( narg > 3 ) THEN
     ! If there are 2 (or more) arguments we will retrieve them
     ! We use the first argument as name for the output file to
     ! the program
     CALL get_command_argument(1, outputfile)

     ! The second argument is used as the name of the output file
     ! name
     CALL get_command_argument(2, argstr)
     ! Convert argstr into a REAL number (USE of internal files)
     READ(argstr,*) diameter
     WRITE(6,*) argstr

     ! thrid argument is the number of panels lengthwise
     CALL get_command_argument(3, argstr)
     ! Convert argstr into an INTEGER number (USE of internal files)
     READ(argstr,*) nl

     ! thrid argument is the number of panels girthwise
     CALL get_command_argument(4, argstr)
     ! Convert argstr into an INTEGER number (USE of internal files)
     READ(argstr,*) ng

  ELSE
     ! Only 1 or no arguments have been provided on the command
     ! line. Report the error and print a simple help.
     WRITE(6,'(A)') ' Output file name and/or sphere diameter missing!'
     WRITE(6,'(A)') ' Usage:>  third <outputfile> <diameter> <nl> <ng>'
     ! Of course <inputfile> and <outputfile> have to be replaced
     ! with file names and not typed literally
     STOP ! abort program
  ENDIF

  WRITE(6,*) outputfile
  WRITE(6,*) diameter
  WRITE(6,*) nl
  WRITE(6,*) ng
  WRITE(6,'(G20.14)') pi

  ! We first determine a set of points on the sphere. The points
  ! are organized in ng+1 rows with n+1 points each.

  ! Allocate memory to store point x,y,z coordinates
  npoints = (nl+1)*(ng+1)  ! number of points (points per WL x number
                           ! of WLs)
  ! this statement reserves memery space (if available) for the two
  ! -dimensional  array points. First dimension is 3 (for x,y,z) and
  ! second dimension counts number of points
  ALLOCATE( points(3,npoints) )

  ! We define a loop over the waterlines (starting at the South pole
  ! of the sphere)
  DO j = 1, ng+1
     ! the angle of latidude (-pi/2 up to 0 (WL))
     !MODIFIED********************************************************
      !theta = 0.5*pi*((j-1)/(0.5*REAL(ng)) -1.)!Whole sphere
      theta = 0.5*pi*((j-1)/REAL(ng) -1.)  ! original

     ! The loop over stations (points on waterline)
     DO i = 1, nl+1
        ! the angle og longitude (0 (bow) up to pi (stern))
        !Modified*****************************************************
        ! phi = 2.0*(i-1)*pi / REAL(nl)   ! whole sphere
         phi = 1.0*(i-1)*pi / REAL(nl) !1/4 sphere (original)

        ! the index of the point
        ipt = i + (j-1)*(nl+1)
        ! point coordinates. Note that the function spherept (module
        ! sphere) returns an array!
        points(:,ipt) = spherept( 0.5*diameter, theta, phi )

        WRITE(6,*) ipt, points(:,ipt)
     END DO ! end of loop over stations
  END DO ! end of loop over waterlines

  ! We now organize the points into panels. Panels are small
  ! quadrilateral elements of the body surface. Each panel is
  ! defined by its four corner points. We will only store the
  ! number of the corner points for each panel. The actual coordinates
  ! of the points are stored in points. Such a table is also
  ! known as an incidence table.

  ! Allocate memory for the incidence table
  npanels = nl*ng    ! number of panels
  ALLOCATE( panels(4,npanels) ) ! 4 corners per panel

  ! Loop over waterlines
  DO j = 1, ng
     ! loop over stations
     DO i = 1, nl
        ! panel number
        ipn = i + (j-1)*nl

        ! point numbers are stored in clockwise sequence if the
        ! panel is looked at from the flow region (from outside of
        ! the body). This ensures that the normal vector computed
        ! later will point out of the flow (inside the body).
        panels(1,ipn) = i + (j-1)*(nl+1)
        panels(2,ipn) = i + (j)*(nl+1)
        panels(3,ipn) = i + 1 + (j)*(nl+1)
        panels(4,ipn) = i + 1 + (j-1)*(nl+1)
        WRITE(6,'(4I6)') panels(:,ipn)
     END DO
  END DO

  ! Finally we save the sphere discretization in the output file.
  ! The ampersand & can be used to continue a line.
  CALL savesphere( outputfile, 'A sphere discretization', (/1,1/), &
                   npanels, npoints, panels, points )

  ! Store data in a VTK files

  ! First we store data valid for a panel (cell in VTK jargon)

  ! Create a file name with the appropriate extension
  i = INDEX(outputfile, ".", BACK=.TRUE.)
  IF (i == 0) THEN
     WRITE(datafile1, '(A,A)')  TRIM(outputfile), '.vtp'
  ELSE
     IF (i > 20) i = 20 ! To make sure the filename does not exceed 24 char
     WRITE(datafile1, '(A,A)')  outputfile(1:i-1), '.vtp'
  ENDIF
  PRINT*, datafile1

  ! In lieu of real data we create an array which we
  ! fill with the average x component of the panel corners
  ALLOCATE(celldata1(npanels))

  DO i = 1, npanels
     celldata1(i) = 0.25*( points(1,panels(1,i)) &
                             + points(1,panels(2,i)) &
                               + points(1,panels(3,i)) &
                                 + points(1,panels(4,i)) )
  END DO
  !
  ! Note that we have to reduce the point numbers by 1 (panels-1)
  ! as VTK starts counting from zero.
  !
  iounit = 10
  CALL VtkXmlPolyDataCellScalar( iounit, datafile1, npoints, &
        0, 0, 0, npanels, &
        RESHAPE(points, (/3*npoints/)), &
        RESHAPE((panels-1), (/4*npanels/)), &
        scalar1=celldata1, &
        namescalar1='Average x')

  ! Now we store data valid for each corner point of the panels

  ! Create a file name with the appropriate extension
  i = INDEX(outputfile, ".", BACK=.TRUE.)
  IF (i == 0) THEN
     WRITE(datafile2, '(A,A,A)')  TRIM(outputfile), 'pt', '.vtp'
  ELSE
     IF (i > 18) i = 18 ! To make sure the filename does not exceed 24 char
     WRITE(datafile2, '(A,A,A)')  outputfile(1:i-1), 'pt', '.vtp'
  ENDIF
  PRINT*, datafile2

  ! In lieu of real data we just store the z-component of the
  ! point coordinates
  !
  ! Note that we have to reduce the point numbers by 1 (panels-1)
  ! as VTK starts counting from zero.
  !
  iounit = 10
  CALL VtkXmlPolyDataPtScalar( iounit, datafile2, npoints, &
        0, 0, 0, npanels, &
        RESHAPE(points, (/3*npoints/)), &
        RESHAPE((panels-1), (/4*npanels/)), &
        scalar1=points(3,:), &
        namescalar1='z')

  ! It is good practice to deallocate arrays before the program ends
  ! or when you do not need them anymore
  IF (ALLOCATED(celldata1)) DEALLOCATE(celldata1)
  IF (ALLOCATED(points)) DEALLOCATE(points)
  IF (ALLOCATED(panels)) DEALLOCATE(panels)

  ! Every program ends with end program
END PROGRAM fourth
! end of file