!
! SA_MR
!
! Module containing forward, tangent-linear and adjoint subroutines
! for specific amount to/from mixing ratio units conversion.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 06-Aug-2009
!                       paul.vandelst@noaa.gov
!

MODULE SA_MR

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Modules used
  USE Type_Kinds, ONLY: fp
  USE Message_Handler
  USE Profile_Utility_Parameters, ONLY: ZERO, ONE, &
                                        MAX_N_MOLECULAR_SPECIES, &
                                        MW_DRYAIR, MOLECULAR_WEIGHT, &
                                        G_TO_KG
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: SA_to_MR, SA_to_MR_TL, SA_to_MR_AD
  PUBLIC :: MR_to_SA, MR_to_SA_TL, MR_to_SA_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       SA_to_MR
!
! PURPOSE:
!       Elemental subroutine to convert gas concentrations from specific amount
!       in g/kg to mass mixing ratio in g/kg.
!
! CALLING SEQUENCE:
!       CALL SA_to_MR( Specific_Amount          , &  ! Input
!                      Mixing_Ratio             , &  ! Output
!                      Water_Vapor = Water_Vapor  )  ! Optional input
!
! INPUTS:
!       Specific_Amount:   Specific amount of gas.
!                          Must be > or = 0.0
!                          UNITS:      g/kg
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or any rank
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Mixing_Ratio:      Mass mixing ratio of gas.
!                          Set to 0.0 if input < 0.0
!                          UNITS:      g/kg
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Specific_Amount argument
!                          ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT:
!       Water_Vapor:       Water vapor mass mixing ratio. If this argument is
!                          not supplied, the input SPECIFIC_AMOUNT argument is
!                          assumed to be water vapor.
!                          Output set to 0.0 if < 0.0
!                          UNITS:      g/kg
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Specific_Amount argument
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! PROCEDURE:
!       The specific amount is defined as the ratio of the mass of gas
!       to the total mass of air and water vapor in a given volume:
!
!                  Mg
!         SA = ---------   .......(1)
!               Md + Mw
!
!       where Mg = mass of gas
!             Mw = mass of water vapor
!             Md = mass of dry air (including Mg).
!
!       The gas mass mixing ratio is defined as the ratio of the mass
!       of the gas to the mass of dry air in a given volume:
!
!                Mg
!         MRg = ----    .......(2)
!                Md
!
!       Rearranging (1) and substituting in (2) gives,
!
!          1      Md + Mw
!         ---- = ---------
!          SA       Mg
!
!                 Md     Mw
!              = ---- + ----
!                 Mg     Mg
!
!                 Md     Mw   Md                                      Md
!              = ---- + ----.----    ( multiplying the second term by ---- )
!                 Mg     Md   Mg                                      Md
!
!                  1
!              = ----- ( 1 + MRw )
!                 MRg
!
!       therefore,
!
!         MRg = SA ( 1 + MRw )
!
!       for input units of g/g or kg/kg. For input units of g/kg then,
!
!         MRg = SA ( 1 + 0.001*MRw )   .......(3)
!
!       If the input specific amount is for water vapor (specific humidity)
!       then (3) becomes,
!
!         MRw = SA ( 1 + 0.001*MRw )
!
!       i.e.
!
!         MRw = SA + 0.001*MRw*SA
!
!       i.e.
!
!         MRw( 1 - 0.001*SA ) = SA
!
!       therefore,
!
!                      SA
!         MRw = ------------------   .......(4)
!                ( 1 - 0.001*SA )
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 05-Dec-2003
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE SA_to_MR( &
    Specific_Amount, &  ! Input
    Mixing_Ratio   , &  ! Output
    Water_Vapor      )  ! Optional Input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: Specific_Amount
    REAL(fp),           INTENT(OUT) :: Mixing_Ratio
    REAL(fp), OPTIONAL, INTENT(IN)  :: Water_Vapor

    ! Error checks
    ! ...Zero output for -ve input
    IF ( Specific_Amount < ZERO ) THEN
      Mixing_Ratio = ZERO
      RETURN
    ENDIF

    ! Calculate mixing ratio in g/kg
    IF ( PRESENT( Water_Vapor ) ) THEN
      ! ...Zero output for -ve input
      IF ( Water_Vapor < ZERO ) THEN
        Mixing_Ratio = ZERO
        RETURN
      ENDIF
      ! ...Gas other than water vapour
      Mixing_Ratio = Specific_Amount * ( ONE + ( G_TO_KG * Water_Vapor ) )
    ELSE
      ! ...Water vapour
      Mixing_Ratio = Specific_Amount / ( ONE - ( G_TO_KG * Specific_Amount ) )
    END IF

  END SUBROUTINE SA_to_MR

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       SA_to_MR_TL
!
! PURPOSE:
!       Tangent-linear form of elemental subroutine to convert gas
!       concentrations from specific amount in g/kg to mass mixing
!       ratio in g/kg.
!
! CALLING SEQUENCE:
!       CALL SA_to_MR_TL( Specific_Amount   , &  ! FWD Input
!                         Specific_Amount_TL, &  ! TL  Input
!                         Mixing_Ratio_TL   , &  ! TL  Output
!                         Water_Vapor       , &  ! Optional FWD Input
!                         Water_Vapor_TL      )  ! Optional TL  Input
!
! INPUTS:
!       Specific_Amount:     Specific amount of gas.
!                            Must be > or = 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Scalar or any rank
!                            ATTRIBUTES: INTENT(IN)
!
!       Specific_Amount_TL:  Tangent-linear specific amount of gas.
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Mixing_Ratio_TL:     Tangent-linear mass mixing ratio of gas.
!                            Set to 0.0 if input Specific_Amount < 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT:
!       Water_Vapor:         Water vapor mass mixing ratio. If this argument is
!                            not supplied, the input SPECIFIC_AMOUNT argument is
!                            assumed to be water vapor.
!                            Output set to 0.0 if < 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Water_Vapor_TL:      Tangent-linear water vapor mass mixing ratio. This
!                            argument is ignored if the optional Water_Vapor
!                            argument is not supplied also.
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 14-Aug-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE SA_to_MR_TL( &
    Specific_Amount   , &  ! FWD Input
    Specific_Amount_TL, &  ! TL  Input
    Mixing_Ratio_TL   , &  ! TL  Output
    Water_Vapor       , &  ! Optional FWD Input
    Water_Vapor_TL      )  ! Optional TL  Input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: Specific_Amount
    REAL(fp),           INTENT(IN)  :: Specific_Amount_TL
    REAL(fp),           INTENT(OUT) :: Mixing_Ratio_TL
    REAL(fp), OPTIONAL, INTENT(IN)  :: Water_Vapor
    REAL(fp), OPTIONAL, INTENT(IN)  :: Water_Vapor_TL

    ! Error checks
    ! ...Zero output for -ve input
    IF ( Specific_Amount < ZERO ) THEN
      Mixing_Ratio_TL = ZERO
      RETURN
    ENDIF

    ! Tangent-linear conversion
    IF ( PRESENT(Water_Vapor) ) THEN
      ! ...Zero output for -ve input
      IF ( Water_Vapor < ZERO ) THEN
        Mixing_Ratio_TL = ZERO
        RETURN
      ENDIF
      ! ...Gas other than water vapour
      Mixing_Ratio_TL = ((ONE + (G_TO_KG * Water_Vapor)) * Specific_Amount_TL)
      IF ( PRESENT(Water_Vapor_TL) ) THEN
        Mixing_Ratio_TL = Mixing_Ratio_TL + (G_TO_KG * Specific_Amount * Water_Vapor_TL)
      END IF
    ELSE
      ! ...Water vapour
      Mixing_Ratio_TL = Specific_Amount_TL / (ONE - (G_TO_KG * Specific_Amount))**2
    END IF

  END SUBROUTINE SA_to_MR_TL

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       SA_to_MR_AD
!
! PURPOSE:
!       Adjoint form of elemental subroutine to convert gas concentrations
!       from specific amount in g/kg to mass mixing ratio in g/kg.
!
! CALLING SEQUENCE:
!       CALL SA_to_MR_AD( Specific_Amount                , &  ! FWD Input
!                         Mixing_Ratio_AD                , &  ! AD  Input
!                         Specific_Amount_AD             , &  ! AD  Output
!                         Water_Vapor    = Water_Vapor   , &  ! Optional FWD Input
!                         Water_Vapor_AD = Water_Vapor_AD  )  ! Optional AD  Output
!
! INPUTS:
!       Specific_Amount:     Specific amount of gas.
!                            Must be > or = 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Scalar or any rank
!                            ATTRIBUTES: INTENT(IN)
!
!       Mixing_Ratio_AD:     Adjoint mass mixing ratio of gas.
!                            *** SET TO ZERO ON EXIT ***
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       Specific_Amount_AD:  Adjoint specific amount of gas.
!                            *** MUST HAVE VALUE ON ENTRY ***
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: INTENT(IN OUT)
!
!
! OPTIONAL INPUT:
!       Water_Vapor:         Water vapor mass mixing ratio. If this argument is
!                            not supplied, the input SPECIFIC_AMOUNT argument is
!                            assumed to be water vapor.
!                            Output set to 0.0 if < 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OPTIONAL OUTPUT:
!       Water_Vapor_AD:      Adjoint water vapor mass mixing ratio. This
!                            argument is ignored if the optional Water_Vapor
!                            argument is not supplied also.
!                            *** MUST HAVE VALUE ON ENTRY ***
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Specific_Amount argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN OUT)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 14-Aug-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE SA_to_MR_AD( &
    Specific_Amount   , &  ! FWD Input
    Mixing_Ratio_AD   , &  ! AD  Input
    Specific_Amount_AD, &  ! AD  Output
    Water_Vapor       , &  ! Optional FWD Input
    Water_Vapor_AD      )  ! Optional AD  Output
    ! Arguments
    REAL(fp),           INTENT(IN)     :: Specific_Amount
    REAL(fp),           INTENT(IN OUT) :: Mixing_Ratio_AD
    REAL(fp),           INTENT(IN OUT) :: Specific_Amount_AD
    REAL(fp), OPTIONAL, INTENT(IN)     :: Water_Vapor
    REAL(fp), OPTIONAL, INTENT(IN OUT) :: Water_Vapor_AD

    ! Error checks
    ! ...Zero output for -ve input
    IF ( Specific_Amount < ZERO ) THEN
      Mixing_Ratio_AD    = ZERO
      Specific_Amount_AD = ZERO
      RETURN
    ENDIF

    ! Adjoint conversion
    IF ( PRESENT(Water_Vapor) ) THEN
      ! ...Zero output for -ve input
      IF ( Water_Vapor < ZERO ) THEN
        Mixing_Ratio_AD    = ZERO
        Specific_Amount_AD = ZERO
        RETURN
      ENDIF
      ! ...Gas other than water vapour
      IF ( PRESENT(Water_Vapor_AD) ) THEN
        Water_Vapor_AD = Water_Vapor_AD + (G_TO_KG * Specific_Amount * Mixing_Ratio_AD)
      END IF
      Specific_Amount_AD = Specific_Amount_AD + ((ONE + (G_TO_KG * Water_Vapor)) * Mixing_Ratio_AD)
    ELSE
      ! ...Water vapour
      Specific_Amount_AD = Specific_Amount_AD + (Mixing_Ratio_AD / (ONE - (G_TO_KG * Specific_Amount))**2)
    END IF
    Mixing_Ratio_AD = ZERO

  END SUBROUTINE SA_to_MR_AD

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       MR_to_SA
!
! PURPOSE:
!       Elemental subroutine to convert gas concentrations from mass mixing
!       ratio in g/kg to specific amount in g/kg.
!
! CALLING SEQUENCE:
!       CALL MR_to_SA( Mixing_Ratio             , &  ! Input
!                      Specific_Amount          , &  ! Output
!                      Water_Vapor = Water_Vapor  )  ! Optional input
!
! INPUTS:
!       Mixing_Ratio:      Mass mixing ratio of gas.
!                          Must be > or = 0.0
!                          UNITS:      g/kg
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or any rank
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Specific_Amount:   Specific amount of gas.
!                          Set to 0.0 if input < 0.0
!                          UNITS:      g/kg
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Mixing_Ratio argument
!                          ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT:
!       Water_Vapor:       Water vapor specific humidity. If this argument is
!                          not supplied, the input MIXING_RATIO argument is
!                          assumed to be water vapor.
!                          Output set to 0.0 if < 0.0
!                          UNITS:      g/kg
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Mixing_Ratio argument
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! PROCEDURE:
!       From the SA_to_MR conversion, we know that for input units of
!       g/kg that,
!
!         MRg = SAg ( 1 + 0.001*MRw )   .......(1)
!
!       and
!                      SAw
!         MRw = -------------------   .......(2)
!                ( 1 - 0.001*SAw )
!
!       where MRg = mass mixing ratio of gas
!             MRw = mass mixing ratio of water vapor
!             SAg = specific amount of gas
!             SAw = specific amount of water vapor (specific humidity)
!
!       Rearranging (1) and (2) gives,
!
!         SAg = MRg ( 1 - 0.001*SAw )
!
!       and for water vapor only,
!
!                       MRw
!         SAw = -------------------
!                ( 1 + 0.001*MRw )
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 05-Dec-2003
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE MR_to_SA( &
    Mixing_Ratio   , &  ! Input
    Specific_Amount, &  ! Output
    Water_Vapor      )  ! Optional Input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: Mixing_Ratio
    REAL(fp),           INTENT(OUT) :: Specific_Amount
    REAL(fp), OPTIONAL, INTENT(IN)  :: Water_Vapor

    ! Error checks
    ! ...Zero output for -ve input
    IF ( Mixing_Ratio < ZERO ) THEN
      Specific_Amount = ZERO
      RETURN
    ENDIF

    ! Calculate specific amount in g/kg
    IF ( PRESENT(Water_Vapor) ) THEN
      ! ...Zero output for -ve input
      IF ( Water_Vapor < ZERO ) THEN
        Specific_Amount = ZERO
        RETURN
      ENDIF
      ! ...Gas other than water vapour
      Specific_Amount = Mixing_Ratio * ( ONE - ( G_TO_KG * Water_Vapor ) )
    ELSE
      ! ...Water vapour
      Specific_Amount = Mixing_Ratio / ( ONE + ( G_TO_KG * Mixing_Ratio ) )
    END IF

  END SUBROUTINE MR_to_SA

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       MR_to_SA_TL
!
! PURPOSE:
!       Tangent-linear form of elemental subroutine to convert gas
!       concentrations from mass mixing ratio in g/kg to specific
!       amount in g/kg.
!
! CALLING SEQUENCE:
!       CALL MR_to_SA_TL( Mixing_Ratio                   , &  ! FWD Input
!                         Mixing_Ratio_TL                , &  ! TL  Input
!                         Specific_Amount_TL             , &  ! TL  Output
!                         Water_Vapor    = Water_Vapor   , &  ! Optional FWD input
!                         Water_Vapor_TL = Water_Vapor_TL  )  ! Optional TL input
!
! INPUTS:
!       Mixing_Ratio:        Mass mixing ratio of gas.
!                            Must be > or = 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Scalar or any rank
!                            ATTRIBUTES: INTENT(IN)
!
!       Mixing_Ratio_TL:     Tangent-linear mass mixing ratio of gas.
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument.
!                            ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Specific_Amount_TL:  Tangent-linear specific amount of gas.
!                            Set to 0.0 if input mixing ratio < 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument
!                            ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUT:
!       Water_Vapor:         Water vapor specific humidity. If this argument is
!                            not supplied, the input MIXING_RATIO argument is
!                            assumed to be water vapor.
!                            Output set to 0.0 if < 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN)
!
!       Water_Vapor_TL:      Tangent-linear specific humidty. This argument is
!                            ignored if the optional Water_Vapor argument is
!                            not supplied also.
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 14-Aug-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE MR_to_SA_TL( &
    Mixing_Ratio      , &  ! FWD Input
    Mixing_Ratio_TL   , &  ! TL Input
    Specific_Amount_TL, &  ! TL Output
    Water_Vapor       , &  ! Optional FWD Input
    Water_Vapor_TL      )  ! Optional TL  Input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: Mixing_Ratio
    REAL(fp),           INTENT(IN)  :: Mixing_Ratio_TL
    REAL(fp),           INTENT(OUT) :: Specific_Amount_TL
    REAL(fp), OPTIONAL, INTENT(IN)  :: Water_Vapor
    REAL(fp), OPTIONAL, INTENT(IN)  :: Water_Vapor_TL

    ! Error checks
    ! ...Zero output for -ve input
    IF ( Mixing_Ratio < ZERO ) THEN
      Specific_Amount_TL = ZERO
      RETURN
    ENDIF

    ! Tangent-linear conversion
    IF ( PRESENT(Water_Vapor) ) THEN
      ! ...Zero output for -ve input
      IF ( Water_Vapor < ZERO ) THEN
        Specific_Amount_TL = ZERO
        RETURN
      ENDIF
      ! ...Gas other than water vapour
      Specific_Amount_TL = ((ONE - (G_TO_KG * Water_Vapor)) * Mixing_Ratio_TL)
      IF ( PRESENT(Water_Vapor_TL) ) THEN
        Specific_Amount_TL = Specific_Amount_TL - (G_TO_KG * Mixing_Ratio * Water_Vapor_TL)
      END IF
    ELSE
      ! ...Water vapour
      Specific_Amount_TL = Mixing_Ratio_TL / (ONE + (G_TO_KG * Mixing_Ratio))**2
    END IF

  END SUBROUTINE MR_to_SA_TL

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       MR_to_SA_AD
!
! PURPOSE:
!       Adjoint form of elemental subroutine to convert gas concentrations
!       from mass mixing ratio in g/kg to specific amount in g/kg.
!
! CALLING SEQUENCE:
!       CALL MR_to_SA_AD( Mixing_Ratio                   , &  ! FWD Input
!                         Specific_Amount_AD             , &  ! AD  Input
!                         Mixing_Ratio_AD                , &  ! AD  Output
!                         Water_Vapor    = Water_Vapor   , &  ! Optional FWD input
!                         Water_Vapor_AD = Water_Vapor_AD  )  ! Optional AD  output
!
! INPUTS:
!       Mixing_Ratio:        Mass mixing ratio of gas.
!                            Must be > or = 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Scalar or any rank
!                            ATTRIBUTES: INTENT(IN)
!
!       Specific_Amount_AD:  Adjoint specific amount of gas.
!                            *** SET TO ZERO ON EXIT ***
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument
!                            ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       Mixing_Ratio_AD:     Adjoint mass mixing ratio of gas.
!                            *** MUST HAVE VALUE ON ENTRY ***
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument.
!                            ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUT:
!       Water_Vapor:         Water vapor specific humidity. If this argument is
!                            not supplied, the input MIXING_RATIO argument is
!                            assumed to be water vapor.
!                            Output set to 0.0 if < 0.0
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OPTIONAL OUTPUT:
!       Water_Vapor_AD:      Adjoint specific humidty. This argument is
!                            ignored if the optional Water_Vapor argument is
!                            not supplied also.
!                            *** MUST HAVE VALUE ON ENTRY ***
!                            UNITS:      g/kg
!                            TYPE:       REAL(fp)
!                            DIMENSION:  Same as Mixing_Ratio argument
!                            ATTRIBUTES: OPTIONAL, INTENT(IN OUT)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 14-Aug-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE MR_to_SA_AD( &
    Mixing_Ratio      , &  ! FWD Input
    Specific_Amount_AD, &  ! AD Input
    Mixing_Ratio_AD   , &  ! AD Output
    Water_Vapor       , &  ! Optional FWD Input
    Water_Vapor_AD      )  ! Optional AD  Output
    ! Arguments
    REAL(fp),           INTENT(IN)     :: Mixing_Ratio
    REAL(fp),           INTENT(IN OUT) :: Specific_Amount_AD
    REAL(fp),           INTENT(IN OUT) :: Mixing_Ratio_AD
    REAL(fp), OPTIONAL, INTENT(IN)     :: Water_Vapor
    REAL(fp), OPTIONAL, INTENT(IN OUT) :: Water_Vapor_AD

    ! Error checks
    ! ...Zero output for -ve input
    IF ( Mixing_Ratio < ZERO ) THEN
      Specific_Amount_AD = ZERO
      Mixing_Ratio_AD    = ZERO
      RETURN
    ENDIF

    ! Tangent-linear conversion
    IF ( PRESENT(Water_Vapor) .AND. PRESENT(Water_Vapor_AD) ) THEN
      ! ...Zero output for -ve input
      IF ( Water_Vapor < ZERO ) THEN
        Specific_Amount_AD = ZERO
        Mixing_Ratio_AD    = ZERO
        Water_Vapor_AD     = ZERO
        RETURN
      ENDIF
      ! ...Gas other than water vapour
      Water_Vapor_AD  = Water_Vapor_AD - (G_TO_KG * Mixing_Ratio * Specific_Amount_AD)
      Mixing_Ratio_AD = Mixing_Ratio_AD + ((ONE - (G_TO_KG * Water_Vapor)) * Specific_Amount_AD)
    ELSE
      ! ...Water vapour
      Mixing_Ratio_AD = Mixing_Ratio_AD + (Specific_Amount_AD / (ONE + (G_TO_KG * Mixing_Ratio))**2)
    END IF
    Specific_Amount_AD = ZERO

  END SUBROUTINE MR_to_SA_AD

END MODULE SA_MR


      SUBROUTINE FTRNDI (DT, F1, F2, F5, F6, DCOEF)
C
C THIS ROUTINE PERFORMS A FORWARD TRANSFORM PROCEDURE USED
C TO EVALUATE THE EXPLICIT PART OF THE RIGHT HAND SIDE
C FOR THE DIVERGENCE PROGNOSTIC EQUATION, USING SEMI-IMPLICIT
C TIMESTEPPING. (THE TERM M OF EQ. (8) IN RITCHIE'S PAPER)
C THE COMPLEX COEFFICIENT VECTOR RETURNED BY THIS ROUTINE
C IS NOT ZEROED AT THE START OF THE FORWARD TRANSFORM PROCEDURE
C (I.E., THE USER MUST SPECIFY INITIAL STATE).  THE ROUTINE MAKES
C USE OF INFORMATION CONTAINED IN COMMON BLOCK TRNSFM (GAUSSIAN
C WEIGHTS, ASSOCIATED LEGENDRE POLYNOMIALS AND DERIVATIVES, ETC.)
C
C CALLED BY: FTRNIM
C CALLS:
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C TRANSFORM ARRAYS
      INCLUDE 'trnsfm.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C TIME STEP
      REAL DT
C ARRAY OF FOURIER COEFFICIENTS (UCOS*ZETA)^M
      COMPLEX F1(NFC,NLAT)
C ARRAY OF FOURIER COEFFICIENTS (VCOS*ZETA)^M
      COMPLEX F2(NFC,NLAT)
C ARRAY OF FOURIER COEFFICIENTS (UCOS**2+VCOS**2)/FAC
      COMPLEX F5(NFC,NLAT)
C ARRAY OF FOURIER COEFFICIENTS (DIV^(TAU-1))^M
      COMPLEX F6(NFC,NLAT)
C
C     Ouput
C
C COMPUTED DIVERGENCE AT NEW TIMELEVEL
      COMPLEX DCOEF(NALP)
C
C------ Local Variables ------------------------------------------------
C
      COMPLEX CTMP1(MM+1), CTMP2(MM+1), CTMP3(MM+1),
     $        CTMP5(MM+1), CTMP6(MM+1), CTMP7(MM+1)
C
C     TEMPORARIES
C
      REAL FAC,FAD
      INTEGER M,N,JM,JN,NL,IS,SL
C
C----- Executable Statements -------------------------------------------
C
C     VARY M AND N SO THAT PROCEDURE MOVES ALONG DIAGONALS DENOTED
C     BY INDEX JN.  M IS GIVEN BY (JM-1); N IS GIVEN BY (JN+M).
C     TAKE ADVANTAGE OF SYMMETRIC CHARACTER OF LEGENDRE POLYNOMIALS
C     PROCEDURE ASSUMES EVEN NUMBER OF GAUSSIAN LATITUDES ...
C
      DO 150 NL=1,NLAT/2
         SL = NLAT-NL+1
         FAC = WTS(NL)*WTACSJ(NL)*DT
         FAD = WTS(NL)*DT
C
         DO 105 M=0,MM
            JM = M+1
C EVEN TERMS
            CTMP1(JM) = (F2(JM,NL) + F2(JM,SL))
     $                * CMPLX(0.0,REAL(M)*FAC)
            CTMP1(JM) = CTMP1(JM) + (F6(JM,NL)+F6(JM,SL))*WTS(NL)
            CTMP2(JM) = (F5(JM,NL) + F5(JM,SL))*FAD
            CTMP3(JM) = (F1(JM,NL) - F1(JM,SL))*FAC
C ODD TERMS
            CTMP5(JM) = (F2(JM,NL) - F2(JM,SL))
     $                * CMPLX(0.0,REAL(M)*FAC)
            CTMP5(JM) = CTMP5(JM) + (F6(JM,NL)-F6(JM,SL))*WTS(NL)
            CTMP6(JM) = (F5(JM,NL) - F5(JM,SL))*FAD
            CTMP7(JM) = (F1(JM,NL) + F1(JM,SL))*FAC
  105    CONTINUE
C
         DO 120 JN=0,NN,2
            IS = LDIAG(JN,2)
C
            DO 110 JM=1,LDIAG(JN,1)
               N = JM + JN - 1
               DCOEF(IS+JM) = DCOEF(IS+JM)
     $          + ALP(IS+JM,NL)*(CTMP1(JM) + CTMP2(JM)*A2NNP1(N))
     $          + DALP(IS+JM,NL)*CTMP3(JM)
  110       CONTINUE
  120    CONTINUE
C
         DO 140 JN=1,NN,2
            IS = LDIAG(JN,2)
C
            DO 130 JM=1,LDIAG(JN,1)
               N = JM + JN - 1
               DCOEF(IS+JM) = DCOEF(IS+JM)
     $         + ALP(IS+JM,NL)*(CTMP5(JM) + CTMP6(JM)*A2NNP1(N))
     $         + DALP(IS+JM,NL)*CTMP7(JM)
  130       CONTINUE
  140    CONTINUE
C
  150 CONTINUE
C
      RETURN
C
      END


program main

  call learning_objs()

end program main

subroutine learning_objs

  use iso_fortran_env

  use learning_fortran_objs

  implicit none

  real(real64) :: r, m, q, x
  type(Particle) :: p
  type(Electron) :: e

  r = 2.4e-10
  m = 9.109e-31
  q = 1.602e-19

  x = 4

  p = Particle(r, m)
  e = Electron(r, m, q)

  ! print *, p%radius, p%mass
  ! print *, e%radius, e%mass, e%charge

  ! call p%cross_area()
  ! call e%cross_area()

  ! print *, p%electric_potential(x)

end subroutine learning_objs


module helpers_mod
  implicit none

  save

  ! flags for obstacle/boundary and fluid cells
  integer, parameter :: C_B = 0, C_F = 16
  ! obstacle with fluid cell to the _X
  integer, parameter :: B_N = 1, B_S = 2, B_W = 4, B_E = 8
  integer, parameter :: B_NW = ior(B_N, B_W), B_SW = ior(B_S, B_W),            &
                        B_NE = ior(B_N, B_E), B_SE = ior(B_S, B_E)
  integer, parameter :: B_NSEW = ior(B_N, ior(B_S, ior(B_E, B_W)))

  real, parameter ::  tau = 0.5

  real, parameter :: t_end = 40
  real, parameter :: eps = 0.001, omega = 1.7, gamma = 0.9
  real, parameter :: Re = 150.0, ui = 1.0, vi = 0.0

  integer, parameter :: imax = 660, jmax = 120, outputFlag = 1,                &
                        output_freq = 10, itermax = 10
  real, parameter :: output_freqt = 0.05
  real, parameter :: xlength = 22.0, ylength = 4.1
  real, parameter :: delx = xlength/imax, dely = ylength/jmax

  contains

  logical function toLogical(x)
    integer, intent(in) :: x
    if (x .eq. 0) then
       toLogical = .false.
    else
       toLogical = .true.
    end if
  end function

  integer function fromLogical(x)
    logical, intent(in) :: x
    if (x) then
       fromLogical = 0
    else
       fromLogical = 1
    end if
  end function

  integer function toMask(x)
    integer, intent(in) :: x
    if (x == 0) then
       toMask = 0
    else
       toMask = 1
    end if
  end function

end module helpers_mod


program vectorization_test
    use, intrinsic :: iso_fortran_env, only : sp => REAL32, &
                                              dp => REAL64, &
                                              ip => INT64
    implicit none
    integer, parameter :: rp = dp
    integer(kind=ip), parameter :: nr_ops = 10000000000_ip
    real(kind=sp) :: t_start, t_end
    real(kind=rp), parameter :: x_delta = 1.0e-09_rp, &
                                x_min   = 1.0e-14_rp, &
                                x_max   = 1.0_rp
    real(kind=rp) :: x, y, total

    integer(kind=ip) :: i
    print "(A)", "# x + y"
    x = x_min
    y = x_max
    total = 0.0_rp
    call cpu_time(t_start)
    do i = 1, nr_ops
        total = total + x + y
        x = x + x_delta
        y = y - x_delta
    end do
    call cpu_time(t_end)
    print "(A, F10.3)", "time = ", t_end - t_start
    print "(A, E18.7)", "total value = ", total

    print "(A)", "# x*y + x"
    x = x_min
    y = x_max
    total = 0.0_rp
    call cpu_time(t_start)
    do i = 1, nr_ops
        total = total + x*y + x
        x = x + x_delta
        y = y - x_delta
    end do
    call cpu_time(t_end)
    print "(A, F10.3)", "time = ", t_end - t_start
    print "(A, E18.7)", "total value = ", total

    print "(A)", "# 2.13/x"
    x = x_min
    total = 0.0_rp
    call cpu_time(t_start)
    do i = 1, nr_ops
        total = total + 2.13_rp/x
        x = x + x_delta
    end do
    call cpu_time(t_end)
    print "(A, F10.3)", "time = ", t_end - t_start
    print "(A, E18.7)", "total value = ", total

    print "(A)", "# x**2.1"
    x = x_min
    total = 0.0_rp
    call cpu_time(t_start)
    do i = 1, nr_ops
        total = total + x**2.1_rp
        x = x + x_delta
    end do
    call cpu_time(t_end)
    print "(A, F10.3)", "time = ", t_end - t_start
    print "(A, E18.7)", "total value = ", total

    print "(A)", "# sqrt(x)"
    x = x_min
    total = 0.0_rp
    call cpu_time(t_start)
    do i = 1, nr_ops
        total = total + sqrt(x)
        x = x + x_delta
    end do
    call cpu_time(t_end)
    print "(A, F10.3)", "time = ", t_end - t_start
    print "(A, E18.7)", "total value = ", total

    print "(A)", "# exp(x)"
    x = x_min
    total = 0.0_rp
    call cpu_time(t_start)
    do i = 1, nr_ops
        total = total + exp(x)
        x = x + x_delta
    end do
    call cpu_time(t_end)
    print "(A, F10.3)", "time = ", t_end - t_start
    print "(A, E18.7)", "total value = ", total

    print "(A)", "# erf(x)"
    x = x_min
    total = 0.0_rp
    call cpu_time(t_start)
    do i = 1, nr_ops
        total = total + erf(x)
        x = x + x_delta
    end do
    call cpu_time(t_end)
    print "(A, F10.3)", "time = ", t_end - t_start
    print "(A, E18.7)", "total value = ", total

end program vectorization_test


module ad_operator

    use ad_kinds, only: rk
    use ad_types, only: tree_t, assignment(=)
    implicit none
    private

    public :: operator(+), operator(-), operator(*), operator(/), operator(**)

    interface operator(+)
        module procedure :: add_tt
        module procedure :: add_tr
        module procedure :: add_rt
    end interface operator(+)

    interface operator(-)
        module procedure :: sub_tt
        module procedure :: sub_tr
        module procedure :: sub_rt
    end interface operator(-)

    interface operator(*)
        module procedure :: mul_tt
        module procedure :: mul_tr
        module procedure :: mul_rt
    end interface operator(*)

    interface operator(/)
        module procedure :: div_tt
        module procedure :: div_tr
        module procedure :: div_rt
    end interface operator(/)

    interface operator(**)
        module procedure :: pow_tt
        module procedure :: pow_tr
        module procedure :: pow_rt
        module procedure :: pow_ti
    end interface operator(**)

contains

    impure elemental function add_tt(t1, t2) result(t)
        type(tree_t), intent(in) :: t1, t2
        type(tree_t) :: t

        t = t1%node%value + t2%node%value

        t%node%left => t1%node
        t%node%right => t2%node

        t%node%left_grad = 1.0_rk
        t%node%right_grad = 1.0_rk

    end function add_tt

    impure elemental function add_tr(t1, r) result(t)
        type(tree_t), intent(in) :: t1
        real(rk), intent(in) :: r
        type(tree_t) :: t

        t = add_rt(r, t1)

    end function add_tr

    impure elemental function add_rt(r, t1) result(t)
        real(rk), intent(in) :: r
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = t1%node%value + r

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk

    end function add_rt

    impure elemental function sub_tt(t1, t2) result(t)
        type(tree_t), intent(in) :: t1, t2
        type(tree_t) :: t

        t = add_tt(t1, mul_rt(-1.0_rk, t2))

    end function sub_tt

    impure elemental function sub_tr(t1, r) result(t)
        type(tree_t), intent(in) :: t1
        real(rk), intent(in) :: r
        type(tree_t) :: t

        t = add_tr(t1, -r)

    end function sub_tr

    impure elemental function sub_rt(r, t1) result(t)
        real(rk), intent(in) :: r
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = add_rt(r, mul_rt(-1.0_rk, t1))

    end function sub_rt

    impure elemental function mul_tt(t1, t2) result(t)
        type(tree_t), intent(in) :: t1, t2
        type(tree_t) :: t

        t = t1%node%value*t2%node%value

        t%node%left => t1%node
        t%node%right => t2%node

        t%node%left_grad = t2%node%value
        t%node%right_grad = t1%node%value

    end function mul_tt

    impure elemental function mul_tr(t1, r) result(t)
        type(tree_t), intent(in) :: t1
        real(rk), intent(in) :: r
        type(tree_t) :: t

        t = mul_rt(r, t1)

    end function mul_tr

    impure elemental function mul_rt(r, t1) result(t)
        real(rk), intent(in) :: r
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = t1%node%value*r

        t%node%left => t1%node
        t%node%left_grad = r

    end function mul_rt

    impure elemental function div_tt(t1, t2) result(t)
        type(tree_t), intent(in) :: t1, t2
        type(tree_t) :: t

        t = mul_tt(t1, div_rt(1.0_rk, t2))

    end function div_tt

    impure elemental function div_tr(t1, r) result(t)
        type(tree_t), intent(in) :: t1
        real(rk), intent(in) :: r
        type(tree_t) :: t

        t = mul_tr(t1, 1.0_rk/r)

    end function div_tr

    impure elemental function div_rt(r, t1) result(t)
        real(rk), intent(in) :: r
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = r/t1%node%value

        t%node%left => t1%node
        t%node%left_grad = -r/t1%node%value**2

    end function div_rt

    impure elemental function pow_tt(t1, t2) result(t)
        type(tree_t), intent(in) :: t1, t2
        type(tree_t) :: t

        t = t1%node%value**t2%node%value

        t%node%left => t1%node
        t%node%right => t2%node

        ! t%node%left_grad = t2%node%value*t1%node%value**(t2%node%value-1.0_rk)
        ! t%node%right_grad = t1%node%value**t2%node%value*log(t1%node%value)
        t%node%left_grad = t%node%value*(log(t1%node%value) + t2%node%value/t1%node%value)
        t%node%right_grad = t%node%value*(log(t1%node%value) + t2%node%value/t1%node%value)

    end function pow_tt

    impure elemental function pow_tr(t1, r) result(t)
        type(tree_t), intent(in) :: t1
        real(rk), intent(in) :: r
        type(tree_t) :: t

        t = t1%node%value**r

        t%node%left => t1%node
        t%node%left_grad = r*t%node%value**(r - 1.0_rk)

    end function pow_tr

    impure elemental function pow_ti(t1, i) result(t)
        type(tree_t), intent(in) :: t1
        integer, intent(in) :: i
        type(tree_t) :: t

        t = t1%node%value**i

        t%node%left => t1%node
        t%node%left_grad = i*t%node%value**(i - 1)

    end function pow_ti

    impure elemental function pow_rt(r, t1) result(t)
        real(rk), intent(in) :: r
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = r**t1%node%value

        t%node%left => t1%node
        t%node%left_grad = r**t1%node%value*log(r)

    end function pow_rt

end module ad_operator


module hash_m
implicit none

integer,parameter,private::nullkey = -1

type::hash_t
  integer::key = nullkey
  integer::val = 0
end type
contains

subroutine hash_initialise(hash,n)
  type(hash_t) ,dimension(:) ,allocatable::hash
  integer::n
  integer::m,i

  call hash_finalise(hash)

  m=(n*3)/2
  allocate(hash(m))
end subroutine

subroutine hash_finalise(hash)
  type(hash_t) ,dimension(:) ,allocatable::hash

  if(allocated(hash))deallocate(hash)
end subroutine

function hash_index(key,n) result(indx)
  integer::key
  integer::n
  integer::indx

  indx = mod(key,n)
  indx = max(indx,1)
end function

subroutine hash_uniquekey_insert(hash,key,val)
  type(hash_t) ,dimension(:)::hash
  integer::key
  integer::val
  integer::val_dupl

  call hash_insert(hash,key,val)
  call hash_get_value(hash,key,val_dupl)

  select case(abs(val-val_dupl))
  case(1:)
    call hash_delete(hash,key,val)
  end select
end subroutine

subroutine hash_insert(hash,key,val)
  type(hash_t) ,dimension(:)::hash
  integer::key
  integer::val
  integer::indx,n

  n = size(hash)
  indx = hash_index(key,n)
  do
    select case(hash(indx)%key-nullkey)
    case(0)
      exit
    end select
    indx=indx+1
    indx=hash_index(indx,n)
  end do
  hash(indx)%key = key
  hash(indx)%val = val
end subroutine

subroutine hash_get_value(hash,key,val)
  type(hash_t) ,dimension(:)::hash
  integer::key
  integer::val
  integer::indx,n

  n = size(hash)
  indx = hash_index(key,n)
  do
    select case(hash(indx)%key-key)
    case(0)
      exit
    end select
    indx=indx+1
    indx=hash_index(indx,n)
  end do
  val = hash(indx)%val
end subroutine

subroutine hash_delete_key(hash,key)
  type(hash_t) ,dimension(:)::hash
  integer::key
  integer::indx,n

  n = size(hash)
  indx = hash_index(key,n)
  do
    select case(hash(indx)%key-key)
    case(0)
      exit
    end select
    indx=indx+1
    indx=hash_index(indx,n)
  end do
  hash(indx)%key = nullkey
  hash(indx)%val = 0
end subroutine

subroutine hash_delete(hash,key,val)
  type(hash_t) ,dimension(:)::hash
  integer::key
  integer::val
  integer::indx,n

  n = size(hash)
  indx = hash_index(key,n)
  do
    select case(hash(indx)%key-key)
    case(0)
      select case(hash(indx)%val-val)
      case(0)
        exit
      end select
    end select
    indx=indx+1
    indx=hash_index(indx,n)
  end do
  hash(indx)%key = nullkey
  hash(indx)%val = 0
end subroutine

subroutine test_hash
  type(hash_t) ,dimension(:) ,allocatable::hash
!   integer,dimension(7)::elem_indx=(/23,18,41,76,54,12,98/)
  integer,dimension(7)::elem_indx=(/23,18,23,76,54,23,98/)
  integer::key,val,i

  print*,"test_hash begin"
  ! initialise table larger than required size
  call hash_initialise(hash,size(elem_indx))

  print*,"populate table ",size(elem_indx)
  do i=1,size(elem_indx)
    key = elem_indx(i)
    val = i
    call hash_uniquekey_insert(hash,key,val)
  end do

  print*,"print table ",size(hash)
  do i=1,size(hash)
    print*,i,hash(i)%key,hash(i)%val
  end do

  key = 54
  print*,"find value ",key
  call hash_get_value(hash,key,val)
  print*,key,val

  print*,"delete entry ",key
  call hash_delete_key(hash,key)

  print*,"print table"
  do i=1,size(hash)
    print*,i,hash(i)%key,hash(i)%val
  end do

  call hash_finalise(hash)
  print*,"test_hash end"
end subroutine
end module


      subroutine sq_snom

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine predicts daily snom melt when the average air
!!    temperature exceeds 0 degrees Celcius

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name         |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ihru         |none          |HRU number
!!    snocov1      |none          |1st shape parameter for snow cover equation
!!                                |This parameter is determined by solving the
!!                                |equation for 50% snow cover
!!    snocov2      |none          |2nd shape parameter for snow cover equation
!!                                |This parameter is determined by solving the
!!                                |equation for 95% snow cover
!!    snotmp(:)    |deg C         |temperature of snow pack in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name         |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    wst(:)%weat%ts(:)  |mm H2O        |precipitation for the time step during day
!!    snofall      |mm H2O        |amount of precipitation falling as freezing
!!                                |rain/snow on day in HRU
!!    snomlt       |mm H2O        |amount of water in snow melt for the day in
!!                                |HRU
!!    snotmp(:)    |deg C         |temperature of snow pack in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Real, Sin, Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use time_module
      use hydrograph_module
      use hru_module, only : hru, snotmp, tmpav, tmx, ihru, precip_eff, snocov1, snocov2,  &
         snofall, snomlt
      use hydrology_data_module
      use climate_module, only: wst

      implicit none

      integer :: ib      !none          |counter
      integer :: j       !none          |HRU number
      real :: sum        !mm H2O        |snow water content in HRU on current day
      real :: smp        !mm H2O        |precipitation on current day for HRU
      real :: smfac      !              |
      real :: smleb      !mm H2O        |amount of snow melt in elevation band on
                         !              |current day
      real :: xx         !none          |ratio of amount of current day"s snow water
                         !              |content to the minimum amount needed to
                         !              |cover ground completely
      real :: snocov     !none          |fraction of HRU area covered with snow
      integer :: isno    !none          |counter
      integer :: ii      !none          |counter

      j = ihru
      sum = 0.
      smp = 0.
      isno = hru(j)%dbs%snow

        !! estimate snow pack temperature
        snotmp(j)=snotmp(j) * (1. - snodb(isno)%timp) + tmpav(j) * snodb(isno)%timp

        if (tmpav(j) <= snodb(isno)%falltmp) then
          !! calculate snow fall
          hru(j)%sno_mm = hru(j)%sno_mm + precip_eff
          snofall = precip_eff
          precip_eff = 0.
          if (time%step > 0) wst(iwst)%weat%ts = 0.
        endif

        if (tmx(j) > snodb(isno)%melttmp .and. hru(j)%sno_mm > 0.) then
          !! adjust melt factor for time of year
          smfac = (snodb(isno)%meltmx + snodb(isno)%meltmn) / 2. +      &
             Sin((time%day - 81) / 58.09) *                                 &
             (snodb(isno)%meltmx - snodb(isno)%meltmn) / 2.             !! 365/2pi = 58.09
          snomlt = smfac * (((snotmp(j)+tmx(j))/2.)-snodb(isno)%melttmp)

          !! adjust for areal extent of snow cover
          if (hru(j)%sno_mm < snodb(isno)%covmx) then
            xx = hru(j)%sno_mm / snodb(isno)%covmx
            snocov = xx / (xx + Exp(snocov1 - snocov2 * xx))
          else
            snocov = 1.
          endif
          snomlt = snomlt * snocov
          if (snomlt < 0.) snomlt = 0.
          if (snomlt > hru(j)%sno_mm) snomlt = hru(j)%sno_mm
          hru(j)%sno_mm = hru(j)%sno_mm - snomlt
          precip_eff = precip_eff + snomlt
          if (time%step > 0) then
            do ii = 1, time%step
             wst(iwst)%weat%ts(ii+1) = wst(iwst)%weat%ts(ii+1) + snomlt / time%step
            end do
          end if
          if (precip_eff < 0.) precip_eff = 0.
        else
          snomlt = 0.
        end if

      return
      end subroutine sq_snom


      subroutine a6treemass(k1,k2,k3,k4,k5,k6,mq,
     & a6treemm,a6treemp,a6treepm,a6treepp)
c--- Routine to compute the tree level amplitude A6tree for the Wbb
c--- process, where the mass of the b-quark is kept non-zero.
c--- The labels on this routine refer to the momenta in "mom" (passed
c--- via common block), in which the massive momenta have been made massless
c--- a la Rodrigo and appear in positions 2 and 3
c---
c---     0 -> q(k1) + qb(k4) + W(->e(k6)+nubar(k5)) + Q(k3) + Qbar(k2)
      implicit none
      include 'constants.f'
c      include 'momwbbm.f'
      include 'sprods_com.f'
      include 'zprods_com.f'
      integer k1,k2,k3,k4,k5,k6
      double complex a6treemm,a6treemp,a6treepm,a6treepp,
     & zba5243,zba5342,zab6123,zab6132
      double precision s123,s234,mq
c      zab2(k1,k2,k3,k4)=za(k1,k2)*zb(k2,k4)+za(k1,k3)*zb(k3,k4)
c      zba2(k1,k2,k3,k4)=zb(k1,k2)*za(k2,k4)+zb(k1,k3)*za(k3,k4)
      zba5243=zb(k5,k2)*za(k2,k3)+zb(k5,k4)*za(k4,k3)
      zba5342=zb(k5,k3)*za(k3,k2)+zb(k5,k4)*za(k4,k2)
      zab6132=za(k6,k1)*zb(k1,k2)+za(k6,k3)*zb(k3,k2)
      zab6123=za(k6,k1)*zb(k1,k3)+za(k6,k2)*zb(k2,k3)
      s123=s(k1,k2)+s(k2,k3)+s(k3,k1)
      s234=s(k2,k3)+s(k3,k4)+s(k4,k2)

c      propagators s(k2,k3) and s(k5,k6) removed
      a6treemp=za(k1,k3)*zb(k4,k5)*zab6132/s123
     &        -zb(k4,k2)*za(k1,k6)*zba5243/s234
      a6treepm=za(k1,k2)*zb(k4,k5)*zab6123/s123
     &        -zb(k4,k3)*za(k1,k6)*zba5342/s234

c -original expression
c      a6tree(1,1)=mq/zb(k2,k3)*(
c     &  zb(k4,k5)*(zab6123*za(k3,k1)-zab6132*za(k2,k1))/s123
c     & +za(k1,k6)*(zba5342*zb(k2,k4)-zba5243*zb(k3,k4))/s234)

      a6treemm=2d0*mq/zb(k2,k3)*(
     &  zb(k4,k5)*zab6123*za(k3,k1)/s123
     & -za(k1,k6)*zba5243*zb(k3,k4)/s234)

      a6treepp=a6treemm*zb(k3,k2)/za(k3,k2)

c      add propagators s(k2,k3) and s(k5,k6)
      a6treemm=a6treemm/(s(k2,k3)*s(k5,k6))
      a6treemp=a6treemp/(s(k2,k3)*s(k5,k6))
      a6treepm=a6treepm/(s(k2,k3)*s(k5,k6))
      a6treepp=a6treepp/(s(k2,k3)*s(k5,k6))

      return
      end


C ==============================================================
C ==============================================================
C ==============================================================
C
C    MANDEL: Lightcurve generator file.
C
C ==============================================================
C === MODULE MANDEL ===

      MODULE mandelmod
      implicit none
      CONTAINS
C ==============================================================
C === SUBROUTINE: OCCULTQUAD ===

      SUBROUTINE occultquad(z0,u1,u2,p0,muo1,mu0,nz)
C  This routine computes the lightcurve for occultation
C  of a quadratically limb-darkened source without microlensing.
C  Please cite Mandel & Agol (2002) if you make use of this routine
C  in your research.  Please report errors or bugs to agol@tapir.caltech.edu
      implicit none
      integer i,nz
      double precision z0(nz),u1,u2,p,muo1(nz),mu0(nz),
     &       lambdad(nz),etad(nz),lambdae(nz),
     &       pi,x1,x2,x3,z,p0,omega,kap0,kap1,q,Kk,Ek,n,
     &       ellpic_bulirsch,tol,
     &       mpp1,pm1,pp1,abs1mp,abspm5p5

C
C Input:
C
C rs   radius of the source (set to unity)
C z0   impact parameter in units of rs
C p    occulting star size in units of rs
C u1   linear    limb-darkening coefficient (gamma_1 in paper)
C u2   quadratic limb-darkening coefficient (gamma_2 in paper)
C
C Output:
C
C muo1 fraction of flux at each z0 for a limb-darkened source
C mu0  fraction of flux at each z0 for a uniform source
C
C Limb darkening has the form:
C  I(r)=[1-u1*(1-sqrt(1-(r/rs)^2))-u2*(1-sqrt(1-(r/rs)^2))^2]/(1-u1/3-u2/6)/pi
C
C To use this routine
C
C Now, compute pure occultation curve:
      omega=1.d0-u1/3.d0-u2/6.d0
      pi=dacos(-1.d0)
      tol = 1d-14

C to mesh with fitting routines
      p = dabs(p0)

C For equalities (mpp1 != 1.d0-p)
      mpp1 = 1.d0-p
      pm1 = p-1.d0
      pp1 = 1.d0+p
      abs1mp = dabs(1.d0-p)
      abspm5p5 = 0.5d0+dabs(p-0.5d0)

C Loop over each impact parameter:
      do i=1,nz

C substitute z=z0(i) to shorten expressions
        z=z0(i)
        x1=(p-z)*(p-z)
        x2=(p+z)*(p+z)
        x3=p*p-z*z

C tolerance for double precision equalities
C special case integrations
        if(dabs(p-z).lt.tol) z = p
        if(dabs((p-1)-z).lt.tol) z = p-1.d0
        if(dabs((1-p)-z).lt.tol) z = 1.d0-p
        if(z.lt.tol) z = 0.d0

C Case 1 - the star is unocculted
        if((z.ge.pp1).or.(p.le.0.d0)) then
          lambdad(i)=0.d0
          etad(i)=0.d0
          lambdae(i)=0.d0
          goto 10
        endif

C Case 11 - the  source is completely occulted:
        if(p.ge.1.d0.and.z.le.pm1) then
           lambdad(i)=0.d0
           etad(i)=0.5d0
           lambdae(i)=1.d0
           goto 10
        endif

C Case 2, 7, 8 - ingress/egress (uniform disk only)
        if(z.ge.abs1mp.and.z.lt.pp1) then
           kap1=dacos(max(min((1.d0-p*p+z*z)/2.d0/z,1.d0),-1.d0))
           kap0=dacos(max(min((p*p+z*z-1.d0)/2.d0/p/z,1.d0),-1.d0))
           lambdae(i)=(p*p*kap0+kap1-0.5d0*dsqrt(max(4.d0*z*z-
     &          (1.d0+z*z-p*p)**2,0.d0)))/pi
           etad(i) = 1.d0/2.d0/pi*(kap1+p*p*(p*p+2.d0*z*z)*
     &          kap0-(1.d0+5.d0*p*p+z*z)/4.d0*
     &          dsqrt((1.d0-x1)*(x2-1.d0)))
        endif

C Case 5, 6, 7 - the edge of planet lies at origin of star
        if(z.eq.p) then
           if(p.lt.0.5d0) then
C             Case 5
              q=2.d0*p
              Call ellke(q,Ek,Kk)
              lambdad(i)=1.d0/3.d0+2.d0/9.d0/pi*(4.d0*(2.d0*p*p-1.d0)*
     &             Ek+(1.d0-4.d0*p*p)*Kk)
              etad(i)=p*p/2.d0*(p*p+2.d0*z*z)
              lambdae(i) = p*p
           else if(p.gt.0.5d0) then
C             Case 7
              q=0.5d0/p
              Call ellke(q,Ek,Kk)
              lambdad(i)=1.d0/3.d0+16.d0*p/9.d0/pi*(2.d0*p*p-1.d0)*
     &             Ek-(32.d0*p**4-20.d0*p*p+3.d0)/9.d0/pi/p*Kk
           else
C             Case 6
              lambdad(i)=1.d0/3.d0-4.d0/pi/9.d0
              etad(i)=3.d0/32.d0
           endif
           goto 10
        endif

C Case 2, Case 8 - ingress/egress (with limb darkening)
        if(((z.gt.abspm5p5).and.(z.lt.pp1)).or.((p.gt.0.5d0).
     &       and.(z.gt.abs1mp).and.(z.lt.p))) then

           q=dsqrt((1.d0-x1)/(x2-x1))
           Call ellke(q,Ek,Kk)
           n=1.d0/x1-1.d0

           lambdad(i)=2.d0/9.d0/pi/dsqrt(x2-x1)*
     &         (((1.d0-x2)*(2.d0*x2+x1-3.d0)-3.d0*
     &            x3*(x2-2.d0))*Kk+(x2-x1)*
     &           (z*z+7.d0*p*p-4.d0)*Ek-3.d0*x3/x1*
     &            ellpic_bulirsch(n,q))

           goto 10
        endif

C     Case 3, 4, 9, 10 - planet completely inside star
        if(p.le.1.d0.and.z.le.mpp1) then
           etad(i) = p*p/2.d0*(p*p+2.d0*z*z)
           lambdae(i) = p*p

C     Case 4 - edge of planet hits edge of star
           if(z.eq.mpp1) then
              lambdad(i) = 2.d0/3.d0/pi*dacos(1.d0-2.d0*p)-
     &             4.d0/9.d0/pi*dsqrt(p*(1.d0-p))*
     &             (3.d0+2.d0*p-8.d0*p*p)

              if(p.gt.0.5d0) lambdad(i) = lambdad(i)-2.d0/3.d0
              goto 10
           endif

C     Case 10 - origin of planet hits origin of star
           if(z.eq.0) then
              lambdad(i) = -2.d0/3.d0*(1.d0-p*p)**1.5d0
              goto 10
           endif

C     Case 3, Case 9 - anywhere in between
           q=dsqrt((x2-x1)/(1.d0-x1))
           Call ellke(q,Ek,Kk)
           n=x2/x1-1.d0
           lambdad(i)=2.d0/9.d0/pi/dsqrt(1.d0-x1)*((1.d0-5.d0*z*z+p*p+
     &          x3*x3)*Kk+(1.d0-x1)*(z*z+7.d0*p*p-4.d0)*
     &          Ek-3.d0*x3/x1*ellpic_bulirsch(n,q))
        endif

 10     continue

C limb darkened flux
        if(p.gt.z) then
           muo1(i)=1.d0-((1.d0-u1-2.d0*u2)*lambdae(i)+(u1+2.d0*u2)*
     &          (lambdad(i)+2.d0/3.d0)+u2*etad(i))/omega
        else
           muo1(i)=1.d0-((1.d0-u1-2.d0*u2)*lambdae(i)+(u1+2.d0*u2)*
     &          lambdad(i)+u2*etad(i))/omega
        endif

C uniform disk
        mu0(i)=1.d0-lambdae(i)
      enddo

      return
      END SUBROUTINE occultquad
      END MODULE mandelmod

C ==============================================================
C === FUNCTION: ELLPIC_BULIRSCH ===
C
      function ellpic_bulirsch(n,k)
      implicit none
      double precision n,k,kc,p,m0,c,d,e,f,g,pi,ellpic_bulirsch
c Computes the complete elliptical integral of the third kind using
c the algorithm of Bulirsch (1965):
      pi=dacos(-1.d0); kc=dsqrt(1d0-k*k); p=n+1d0
      if (p.lt.0d0) print *, "Negative p"
      m0=1d0; c=1d0; p=dsqrt(p); d=1d0/p; e=kc
 10   continue
      f = c; c = d/p+c; g = e/p; d= 2d0*(f*g+d)
      p = g + p; g = m0; m0 = kc + m0;
      if (dabs(1d0-kc/g).gt.1.d-8) then
         kc = 2d0*dsqrt(e); e=kc*m0
         goto 10
      endif
      ellpic_bulirsch = 0.5d0*pi*(c*m0+d)/(m0*(m0+p))
      return
      end

C ==============================================================
C === SUBROUTINE: ELLKE ===
C
      subroutine ellke(k,ek,kk)
      implicit none
      double precision k,m1,a0,a1,a2,a3,a4,b0,b1,b2,b3,b4,
     &       ee1,ee2,ek1,ek2,logm1,ek,kk
C Computes Hasting's polynomial approximation for the complete
C elliptic integral of the first (ek) and second (kk) kind

      m1=1.d0-k*k
      logm1=dlog(m1)

      a1=0.44325141463d0
      a2=0.06260601220d0
      a3=0.04757383546d0
      a4=0.01736506451d0
      b1=0.24998368310d0
      b2=0.09200180037d0
      b3=0.04069697526d0
      b4=0.00526449639d0
      ee1=1.d0+m1*(a1+m1*(a2+m1*(a3+m1*a4)))
      ee2=m1*(b1+m1*(b2+m1*(b3+m1*b4)))*(-logm1)
      ek=ee1+ee2

      a0=1.38629436112d0
      a1=0.09666344259d0
      a2=0.03590092383d0
      a3=0.03742563713d0
      a4=0.01451196212d0
      b0=0.5d0
      b1=0.12498593597d0
      b2=0.06880248576d0
      b3=0.03328355346d0
      b4=0.00441787012d0
      ek1=a0+m1*(a1+m1*(a2+m1*(a3+m1*a4)))
      ek2=(b0+m1*(b1+m1*(b2+m1*(b3+m1*b4))))*logm1
      kk=ek1-ek2

      return
      end

C ==============================================================
C === SUBROUTINE: OCCULTUNIFORM ===
C
      SUBROUTINE occultuniform(b0,w,muo1,nb)
      implicit none
      INTEGER :: i,nb
      REAL(8) :: muo1(nb),w,b0(nb),z,lambdae,kap0,kap1
      REAL(8), PARAMETER :: pi = 3.14159265358979323846D0
      IF(ABS(w-0.5D0).LT.1.0D-3) w=0.5D0
C  This routine computes the lightcurve for occultation
C  of a uniform source without microlensing  (Mandel & Agol 2002).
C Input:
C
C  rs   radius of the source (set to unity)
C  b0   impact parameter in units of rs
C  w    occulting star size in units of rs
C
C Output:
C  muo1 fraction of flux at each b0 for a uniform source
C
C  Now, compute pure occultation curve:
      DO i=1,nb
C  substitute z=b0(i) to shorten expressions
        z=b0(i)
C  the source is unocculted:
C  Table 3, I.
        IF(z.GE.1.d0+w) THEN
          muo1(i)=1.0D0
          GOTO 1
        ENDIF
C  the  source is completely occulted:
C  Table 3, II.
        IF(w.GE.1.d0.AND.z.LE.w-1.0D0) THEN
          muo1(i)=0.0D0
          GOTO 1
        ENDIF
C  the source is partly occulted and the occulting object crosses the limb:
C  Equation (26):
        IF(z.GE.ABS(1.D0-w).AND.z.LE.1.d0+w) THEN
          kap1=ACOS(MIN((1.D0-w*w+z*z)/2.D0/z,1.D0))
          kap0=ACOS(MIN((w*w+z*z-1.D0)/2.D0/w/z,1.D0))
          lambdae=w*w*kap0+kap1
          lambdae=(lambdae-0.5D0*SQRT(MAX(4.D0*z*z-(1.D0+z*z-w*w)**2,
     &            0.D0)))/pi
          muo1(i)=1.0D0-lambdae
        ENDIF
C  the occulting object transits the source star (but doesn't
C  completely cover it):
        IF(z.LE.1.d0-w) muo1(i)=1.0D0-w*w
 1      CONTINUE
      ENDDO
C muo1=1.d0-lambdae
      return
      END

C ==============================================================


!
!     -----------------------------------------------------------------
!      G R A C A H 1
!     -----------------------------------------------------------------
!
      SUBROUTINE GRACAH1(I, J, K, L, M, N, RAC)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE FACT_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:07:18  11/16/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: I
      INTEGER , INTENT(IN) :: J
      INTEGER , INTENT(IN) :: K
      INTEGER , INTENT(IN) :: L
      INTEGER , INTENT(IN) :: M
      INTEGER , INTENT(IN) :: N
      REAL(DOUBLE) , INTENT(OUT) :: RAC
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J1, J2, J3, J4, J5, J6, J7, NUMIN, NUMAX, ICOUNT, KK, KI
      REAL(DOUBLE) :: ZERO, ONE, TWO
!-----------------------------------------------
!
!      SUBROUTINE TO CALCULATE RACAH COEFFICIENTS.
!      THE ARGUMENTS I,J,K,L,M,N SHOULD BE TWICE THEIR ACTUAL VALUE.
!      WRITTEN BY N. S. SCOTT
!      Modified by C. Froese Fischer, March 11, 1988 to use
!         table look-up
!      and
!                  G. Gaigalas, September 14, 1997
!
      DATA ZERO, ONE, TWO/ 0.D0, 1.D0, 2.D0/
!
      J1 = I + J + M
      J2 = K + L + M
      J3 = I + K + N
      J4 = J + L + N
      IF (MOD(J1,2)==0 .AND. MOD(J2,2)==0 .AND. MOD(J3,2)==0 .AND. MOD(J4,2)==0&
         ) THEN
         J1 = J1/2
         J2 = J2/2
         J3 = J3/2
         J4 = J4/2
         IF (MAX(MAX(I,J),M)<=J1 .AND. MAX(MAX(K,L),M)<=J2 .AND. MAX(MAX(I,K),N&
            )<=J3 .AND. MAX(MAX(J,L),N)<=J4) THEN
            J5 = (I + J + K + L)/2
            J6 = (I + L + M + N)/2
            J7 = (J + K + M + N)/2
            NUMIN = MAX(MAX(MAX(J1,J2),J3),J4) + 1
            NUMAX = MIN(MIN(J5,J6),J7) + 1
            RAC = ONE
            ICOUNT = 0
            DO KK = NUMIN + 1, NUMAX
               KI = NUMAX - ICOUNT
               RAC = ONE - (RAC*(KI*(J5 - KI + 2)*(J6 - KI + 2)*(J7 - KI + 2)))&
                  /((KI - 1 - J1)*(KI - 1 - J2)*(KI - 1 - J3)*(KI - 1 - J4))
               ICOUNT = ICOUNT + 1
            END DO
            RAC = RAC*EXP((GAM(NUMIN+1)-GAM(NUMIN-J1)-GAM(NUMIN-J2)-GAM(NUMIN-&
               J3)-GAM(NUMIN-J4)-GAM(J5+2-NUMIN)-GAM(J6+2-NUMIN)-GAM(J7+2-NUMIN&
               ))+(GAM(J1+1-I)+GAM(J1+1-J)+GAM(J1+1-M)-GAM(J1+2)+GAM(J2+1-K)+&
               GAM(J2+1-L)+GAM(J2+1-M)-GAM(J2+2)+GAM(J3+1-I)+GAM(J3+1-K)+GAM(J3&
               +1-N)-GAM(J3+2)+GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N)-GAM(J4+2))/&
               TWO)
            IF (MOD(J5 + NUMIN,2) == 0) RAC = -RAC
         ELSE
            RAC = ZERO
         ENDIF
      ELSE
         RAC = ZERO
      ENDIF
      RETURN
      END SUBROUTINE GRACAH1


! RUN: %S/test_folding.sh %s %t %flang_fc1
! Tests folding of SHAPE(TRANSFER(...))

module m
  logical, parameter :: test_size_1 = size(shape(transfer(123456789,0_1,size=4))) == 1
  logical, parameter :: test_size_2 = all(shape(transfer(123456789,0_1,size=4)) == [4])
  logical, parameter :: test_scalar_1 = size(shape(transfer(123456789, 0_1))) == 0
  logical, parameter :: test_vector_1 = size(shape(transfer(123456789, [0_1]))) == 1
  logical, parameter :: test_vector_2 = all(shape(transfer(123456789, [0_1])) == [4])
  logical, parameter :: test_array_1 = size(shape(transfer(123456789, reshape([0_1],[1,1])))) == 1
  logical, parameter :: test_array_2 = all(shape(transfer(123456789, reshape([0_1],[1,1]))) == [4])
  logical, parameter :: test_array_3 = all(shape(transfer([1.,2.,3.], [(0.,0.)])) == [2])
end module


    program AOC07
    use ifport
    implicit none

    integer :: vals(2000), nvals, fuel, fuel1, fuel2, i, pos1, pos2, goal, median, dist
    real :: mean

    open (unit=1,file='input.txt', form='formatted', status='old')
    vals = -1
    read (1,*,iostat=i) vals
    nvals = findloc(vals,-1,1) - 1
    call qsort(vals, nvals, 4, compar)
    !print *, vals(1:nvals)
    mean = real(sum(vals(1:nvals)))/real(nvals)
    pos1 = floor(mean)
    pos2 = ceiling(mean)
    print *, pos1, pos2
    print *
    !print *, vals(pos1), vals(pos2)

    fuel1 = 0
    do i=1,nvals
        dist = abs(vals(i) - pos1)
        if (dist < 2) then
            fuel = dist
        else if (mod(dist,2) == 0) then
            fuel = (dist+1)*(dist/2)
        else
            fuel = (dist * (1+(dist/2)))
        end if
        fuel1 = fuel1 + fuel
       ! print *, vals(i), dist, fuel
    end do
    print *
     fuel2 = 0
    do i=1,nvals
        dist = abs(vals(i) - pos2)
        if (dist < 2) then
            fuel = dist
        else if (mod(dist,2) == 0) then
            fuel = (dist+1)*(dist/2)
        else
            fuel = (dist * (1+(dist/2)))
        end if
        fuel2 = fuel2 + fuel
        !print *, vals(i), dist, fuel
    end do
    print *, fuel1, fuel2

    contains

    function compar (arg1, arg2)
    integer(2) :: compar
    integer(4) :: arg1,arg2
    if (arg1 < arg2) then
        compar = -1
    else if (arg1 > arg2) then
        compar = 1
    else
        compar = 0
    end if
    end function compar

    end program AOC07


c-----------------------------------------------------------------------
c
c  R : A Computer Language for Statistical Data Analysis
c  Copyright (C) 1996, 1997  Robert Gentleman and Ross Ihaka
c  Copyright (C) 2003-5      The R Foundation
c
c  This program is free software; you can redistribute it and/or modify
c  it under the terms of the GNU General Public License as published by
c  the Free Software Foundation; either version 2 of the License, or
c  (at your option) any later version.
c
c  This program is distributed in the hope that it will be useful,
c  but WITHOUT ANY WARRANTY; without even the implied warranty of
c  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c  GNU General Public License for more details.
c
c  You should have received a copy of the GNU General Public License
c  along with this program; if not, a copy is available at
c  https://www.R-project.org/Licenses/
c
c-----------------------------------------------------------------------
c
c   lminfl computes basic quantities useful for computing
c   regression diagnostics.
c
c   on entry
c
c       x       double precision(ldx,k)
c               the qr decomposition as computed by dqrdc or dqrdc2.
c
c       ldx     integer
c               the leading dimension of the array x.
c
c       n       integer
c               the number of rows of the matrix x.
c
c       k       integer
c               the number of columns in the matrix k.
c
c       docoef  integer (logical) indicating if  coef(*,*) should be computed
c               Computation of coef(.) is O(n^2 * k) which may be too much.
c
c       qraux   double precision(k)
c               auxiliary information about the qr decomposition.
c
c       resid   double precision(k)
c               the residuals from the regression.
c
c   on return
c
c       hat     double precision(n)
c               the diagonal of the hat matrix.
c
c       coef    double precision(n,p)
c               a matrix which has as i-th row the estimated
c               regression coefficients when the i-th case is omitted
c               from the regression.
c
c       sigma   double precision(n)
c               the i-th element of sigma contains an estimate
c               of the residual standard deviation for the model with
c               the i-th case omitted.
c
c   This version dated Aug 24, 1996.
c   Ross Ihaka, University of Auckland.
c   `docoef' option added Feb 17, 2003;  Martin Maechler ETH Zurich.
c   Handle hat == 1 case, Nov 2005.
c   Argument 'tol' was real not double precision, Aug 2007

      subroutine lminfl(x, ldx, n, k, docoef, qraux, resid,
     +     hat, coef, sigma, tol)
      integer ldx, n, k, docoef
      double precision x(ldx,k), qraux(k), resid(n),
     +     hat(n), coef(n,k), sigma(n), tol
c   coef(.,.) can be dummy(1) when docoef is 0(false)

      integer i, j, info
      double precision sum, denom, dummy
c
c     hat matrix diagonal
c
      do 10 i = 1,n
        hat(i) = 0.0d0
   10 continue

      do 40 j = 1,k
        do 20 i = 1,n
          sigma(i) = 0.0d0
   20   continue
        sigma(j) = 1.0d0
        call dqrsl(x, ldx, n, k, qraux, sigma, sigma, dummy,
     .       dummy, dummy, dummy, 10000, info)
        do 30 i = 1, n
          hat(i) = hat(i)+sigma(i)*sigma(i)
   30   continue
   40 continue
      do 45 i = 1, n
        if(hat(i) .ge. 1.0d0 - tol) hat(i) = 1.0d0
   45 continue
c
c     changes in the estimated coefficients
c
      if(docoef .ne. 0) then
         do 70 i = 1,n
            do 50 j = 1,n
               sigma(j) = 0.0d0
   50       continue
c           if hat is effectively 1, change is zero
            if(hat(i) .lt. 1.0d0) then
               sigma(i) = resid(i)/(1.0d0 - hat(i))
               call dqrsl(x, ldx, n, k, qraux, sigma, dummy, sigma,
     .                    dummy, dummy, dummy, 1000, info)
               call dtrsl(x, ldx, k, sigma, 1, info)
            endif
            do 60 j = 1,k
               coef(i,j) = sigma(j)
   60       continue
   70    continue
      endif
c
c     estimated residual standard deviation
c
      denom = (n - k - 1)
      sum = 0.0d0
      do 80 i = 1,n
        sum = sum + resid(i)*resid(i)
   80 continue
      do 90 i = 1,n
        if(hat(i) .lt. 1.0d0) then
           sigma(i) = sqrt((sum-resid(i)*resid(i)/(1.0d0-hat(i)))/denom)
        else
           sigma(i) = sqrt(sum/denom)
        endif
   90 continue
      return
      end


        SUBROUTINE FVANDER(N,X,Y,F,EPS,IPAR)
C --- RIGHT-HAND SIDE OF VANDERPOL EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        F(1)=Y(2)
        PROD=1.D0-Y(1)*Y(1)
        F(2)=(PROD*Y(2)-Y(1))/EPS
        RETURN
        END
C
        SUBROUTINE JVANDER(N,X,Y,DFY,LDFY,EPS,IPAR)
C --- JACOBIAN OF VANDERPOL EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
        DFY(1,1)=0.D0
        DFY(1,2)=1.D0
        DFY(2,1)=(-2.0D0*Y(1)*Y(2)-1.0D0)/EPS
        DFY(2,2)=(1.0D0-Y(1)**2)/EPS
        RETURN
        END