!====================================================================
!-----------------------------------------------------------------------
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOI
! !MODULE: m_temperature -- Temperature conversion routines
!
! !DESCRIPTION:
!     This module contains routines that convert temperature values.
!
! !REFERENCES:
!     Rogers, R. R., 1979: A Short Course in Cloud Physics, 2nd. Ed.,
!          Pergamon Press, Oxford. 235pp.
!
! !INTERFACE:
!
      module      m_temperature
      implicit    NONE
      private	! except

      public ::           ! Routines to convert from air temp (AT) to ...
     .   ATtoPT, AT2PT,   ! ... potential temperature (PT)
     .   ATtoVT, AT2VT    ! ... virtual temperature (VT)

      public ::           ! Routines to convert from ...
     .   PTtoAT, PT2AT,   ! ... potential temperature (PT)
     .   VTtoAT, VT2AT    ! ... virtual temperature (VT)
      public ::           ! Equation code for determining the VT
     .   VT_Exact,        ! ... using the exact equations
     .   VT_NCEP          ! ... NCEPS's approximation
!
      interface ATtoVT
         module procedure ! Convert from air temperature and ..
     .      ATtoVT_vp,    ! ... vapor pressure or
     .      ATtoVT_mr     ! ... mixing ratio to virtual temperature
      end interface

      interface AT2VT
         module procedure ! Convert from air temperature and ..
     .      AT2VT_vp,     ! ... vapor pressure or
     .      AT2VT_mr      ! ... mixing ratio to virtual temperature
      end interface
!
      interface VTtoAT
         module procedure ! Convert from virtual temperature and ..
     .      VTtoAT_vp,    ! ... vapor pressure or
     .      VTtoAT_mr     ! ... mixing ratio to air temperature
      end interface
!
      interface VT2AT
         module procedure ! Convert from virtual temperature and ..
     .      VT2AT_vp,     ! ... vapor pressure or
     .      VT2AT_mr      ! ... mixing ratio to air temperature
      end interface
!
!     Note: Routine names of the form xxtoxx and xx2xx implies a
!           subroutine and function, respectively.
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder  Original code
!EOI
!-----------------------------------------------------------------
      real, parameter ::
     .   Ra     =  287.0,   ! The individual gas constant for dry air and ...
     .   Rv     =  461.0,   ! ... water vapor (j/(kg-deg K, from Rogers,
     .   RaRv   =  Ra / Rv  !   1979)
      real, parameter ::
     .   Cp     =  1004.0,  ! Specific heat at constant pressure
     .   Cv     =   717.0,  ! ... at constant volume for dry air
     .                      ! (j/(kg-deg K, from Rogers, 1979)
     .   k      =  ( Cp - Cv ) / Cp,
     .   PS_Def =  1000.0   ! Default value for the final pressure for
                            !   the potential temperature (mb).

      integer, parameter ::
     .   VT_Exact =  0,       ! Exact equation
     .   VT_NCEP  =  1        ! ... NCEP's approximation

      contains
!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: ATtoPT () --- Air temperature to potential temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from air temperature
!     to potential temperature
!
! !INTERFACE:
      pure subroutine ATtoPT ( AT, P, PT, PS )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,      intent (in)  ::
     .   AT (:), ! air temperature (deg K)
     .   P  (:)  ! air pressure (mb or hPa)
      real,      intent (in), optional ::
     .   PS      ! reference pressure (mb or hPa).  Default: PS = 1000.0 mb
! !OUTPUT PARAMETERS:
      real,      intent (out) ::
     .   PT (:)  ! potential temperature (deg K)
!
!     Note: The minimum size of the arrays AT and PT determines the number
!           of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!
! EOP
!-------------------------------------------------------------------------

      real    ::  T, PP, PSS
      integer :: iT, NT, NP

      PSS  = PS_Def
      if ( present ( PS )) PSS = PS

      NP   = size ( P )
      NT   = min  ( size ( AT ), size ( PT ))
      if ( NP .eq. 0 ) NT = 0
      do iT = 1, NT
         T  = AT ( iT )
         PP = PSS / P  ( min ( iT, NP ))
         PT ( iT ) = T * PP ** k
      end do

      return
      end subroutine ATtoPT

!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: PTtoAT () --- Potential temperature to air temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from potential
!     temperature to air temperature
!
! !INTERFACE:
      pure subroutine PTtoAT ( PT, P, AT, PS )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,      intent (in)  ::
     .   PT (:), ! potential temperature (deg K)
     .   P  (:)  ! air pressure (mb or hPa)
      real,      intent (in), optional ::
     .   PS      ! reference pressure (mb or hPa).  Default: PS = 1000.0 mb
! !OUTPUT PARAMETERS:
      real,      intent (out) ::
     .   AT (:)  ! air temperature (deg K)
!
!     Note: The minimum size of the arrays PT and AT determines the number
!           of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!
! EOP
!-------------------------------------------------------------------------

      real    ::  T, PP, PSS
      integer :: iT, NT, NP

      PSS  = PS_Def
      if ( present ( PS )) PSS = PS

      NP   = size ( P )
      NT   = min  ( size ( AT ), size ( PT ))
      if ( NP .eq. 0 ) NT = 0
      do iT = 1, NT
         T  = PT ( iT )
         PP = PSS / P  ( min ( iT, NP ))
         AT ( iT ) = T * PP ** (-k)
      end do

      return
      end subroutine PTtoAT

!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: AT2PT () --- Air temperature to potential temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from air
!     temperature to potential temperature
!
! !INTERFACE:
      pure function AT2PT ( AT, P, PS )
      implicit NONE
!
! !INPUT PARAMETERS:
      real, intent (in)           :: AT    ! air temperature (deg K)
      real, intent (in)           :: P     ! air pressure (mb or hPa)
      real, intent (in), optional :: PS    ! reference pressure (mb or hPa).
                                           !   Default: PS = 1000.0 mb
! !OUTPUT PARAMETERS:
      real                        :: AT2PT ! potential temperature (deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!
! EOP
!-------------------------------------------------------------------------

      real :: PT (1)

      call ATtoPT ( (/AT/), (/P/), PT, PS )
      AT2PT = PT (1)

      return
      end function AT2PT

!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: PT2AT () --- Potential temperature to air temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from potential
!     temperature to air temperature
!
! !INTERFACE:
      pure function PT2AT ( PT, P, PS )
      implicit NONE
!
! !INPUT PARAMETERS:
      real, intent (in)           :: PT    ! potential temperature (deg K)
      real, intent (in)           :: P     ! air pressure (mb or hPa)
      real, intent (in), optional :: PS    ! reference pressure (mb or hPa).
                                           !   Default: PS = 1000.0 mb
! !OUTPUT PARAMETERS:
      real                        :: PT2AT ! air temperature (deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!
! EOP
!-------------------------------------------------------------------------

      real :: AT (1)

      call PTtoAT ( (/PT/), (/P/), AT, PS )
      PT2AT = AT (1)

      return
      end function PT2AT
!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: ATtoVT_vp () --- Air temperature and vapor pressure to virtual temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from air temperature
!     and vapor pressure to virtual temperature.
!
! !INTERFACE:
      pure subroutine ATtoVT_vp ( AT, P, VP, VT, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,      intent (in)  ::
     .   AT (:), ! air temperature (deg K)
     .   P  (:), ! air pressure   (mb or hPa)
     .   VP (:)  ! vapor pressure (mb or hPa)
      integer,   intent (in), optional ::
     .   Eqtn    ! equation code (default: 0)
!
! !OUTPUT PARAMETERS:
      real,      intent (out) ::
     .   VT (:)  ! virtual temperature (deg K)
!
!     Note: The minimum size of the arrays AT, VP and VT determines the
!           number of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real    ::  T, W,  PP
      integer :: iT, NT, NP, Code_

      Code_ = VT_Exact
      if ( present ( Eqtn )) Code_ = Eqtn

      NP   = size ( P )
      NT   = min  ( size ( AT ), size ( VP ), size ( VT ))
      if ( NP .eq. 0 ) NT = 0

      if ( Code_ .eq. VT_NCEP ) then
         do iT = 1, NT
            T  = AT ( iT )
            PP = P  ( min ( iT, NP ))
            W  = RaRv * VP ( iT ) / ( PP - VP ( iT ))
            VT ( iT ) = T * ( 1.0 + 0.61 * W )
         end do

      else
         do iT = 1, NT
            T  = AT ( iT )
            PP = P  ( min ( iT, NP ))
            W  = RaRv * VP ( iT ) / ( PP - VP ( iT ))
            VT ( iT ) = T * ( 1.0 + W / RaRv )
     .                    / ( 1.0 + W )
         end do

      end if

      return
      end subroutine ATtoVT_vp
!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: ATtoVT_mr () --- Air temperature and mixing ratio to virtual temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from air temperature
!     and mixing ratio to virtual temperature
!
! !INTERFACE:
      pure subroutine ATtoVT_mr ( AT, MR, VT, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,      intent (in)  ::
     .   AT (:), ! air temperature (deg K)
     .   MR (:)  ! mixing ratio (g/kg)
      integer,   intent (in), optional ::
     .   Eqtn    ! equation code (default: 0)
! !OUTPUT PARAMETERS:
      real,      intent (out) ::
     .   VT (:)  ! virtual temperature (deg K)
!
!     Note: The minimum size of the arrays AT, MR and VT determines the
!           number of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real    ::  T, MRR
      integer :: iT, NT, Code_

      Code_ = VT_Exact
      if ( present ( Eqtn )) Code_ = Eqtn

      NT = min  ( size ( AT ), size ( MR ), size ( VT ))

      if ( Code_ .eq. VT_NCEP ) then
         do iT = 1, NT
            T   = AT ( iT )
            MRR = 0.001 * MR ( iT )
            VT ( iT ) = T * ( 1.0 + 0.61 * MRR )
         end do

      else
         do iT = 1, NT
            T   = AT ( iT )
            MRR = 0.001 * MR ( iT )
            VT ( iT ) = T * ( 1.0 + MRR / RaRv )
     .                    / ( 1.0 + MRR )
         end do

      end if

      return
      end subroutine ATtoVT_mr
!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: VTtoAT_vp () --- Virtual temperature and vapor pressure to airtemperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from virtual
!     temperature and vapor pressure to air temperature.
!
! !INTERFACE:
      pure subroutine VTtoAT_vp ( VT, P, VP, AT, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,      intent (in)  ::
     .   VT (:), ! virtual temperature (deg K)
     .   P  (:), ! air pressure   (mb or hPa)
     .   VP (:)  ! vapor pressure (mb or hPa)
      integer,   intent (in), optional ::
     .   Eqtn    ! equation code (default: 0)
! !OUTPUT PARAMETERS:
      real,      intent (out) ::
     .   AT (:)  ! air temperature (deg K)
!
!     Note: The minimum size of the arrays VT, VP and AT determines the
!           number of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real    ::  T, W,  PP
      integer :: iT, NT, NP, Code_

      Code_ = VT_Exact
      if ( present ( Eqtn )) Code_ = Eqtn

      NP   = size ( P )
      NT   = min  ( size ( VT ), size ( VP ), size ( AT ))
      if ( NP .eq. 0 ) NT = 0

      if ( Code_ .eq. VT_NCEP ) then
         do iT = 1, NT
            T  = VT ( iT )
            PP = P  ( min ( iT, NP ))
            W  = RaRv * VP ( iT ) / ( PP - VP ( iT ))
            AT ( iT ) = T / ( 1.0 + 0.61 * W )

         end do

      else
         do iT = 1, NT
            T  = VT ( iT )
            PP = P  ( min ( iT, NP ))
            W  = RaRv * VP ( iT ) / ( PP - VP ( iT ))
            AT ( iT ) = T * ( 1.0 + W )
     .                    / ( 1.0 + W / RaRv )
         end do

      end if

      return
      end subroutine VTtoAT_vp
!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: VTtoAT_mr () --- Virtual temperature and mixing ratio to air temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from virtural
!     temperature and mixing ratio to air temperature
!
! !INTERFACE:
      pure subroutine VTtoAT_mr ( VT, MR, AT, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,      intent (in)  ::
     .   VT (:), ! virtual temperature (deg K)
     .   MR (:)  ! mixing ratio (g/kg)
      integer,   intent (in), optional ::
     .   Eqtn    ! equation code (default: 0)
! !OUTPUT PARAMETERS:
      real,      intent (out) ::
     .   AT (:)  ! air temperature (deg K)
!
!     Note: The minimum size of the arrays AT, MR and VT determines the
!           number of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real    ::  T, MRR
      integer :: iT, NT, Code_

      Code_ = VT_Exact
      if ( present ( Eqtn )) Code_ = Eqtn

      NT   = min  ( size ( VT ), size ( MR ), size ( AT ))

      if ( Code_ .eq. VT_NCEP ) then
         do iT = 1, NT
            T   = VT ( iT )
            MRR = 0.001 * MR ( iT )
            AT ( iT ) = T / ( 1.0 + 0.61 * MRR )
         end do
      else
         do iT = 1, NT
            T   = VT ( iT )
            MRR = 0.001 * MR ( iT )
            AT ( iT ) = T * ( 1.0 + MRR )
     .                    / ( 1.0 + MRR / RaRv )
         end do

      end if

      return
      end subroutine VTtoAT_mr
!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: AT2VT_vp () --- Air temperature and vapor pressure to virtual temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from air
!     temperature and vapor pressure to virtual temperature
!
! !INTERFACE:
      pure function AT2VT_vp ( AT, P, VP, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,    intent (in) :: AT       ! air temperature (deg K)
      real,    intent (in) :: P        ! air pressure (mb or hPa)
      real,    intent (in) :: VP       ! vapor pressure (mb or hPa)
      integer, intent (in),   optional ::
     .                        Eqtn     ! equation code (default: 0)
!
! !OUTPUT PARAMETERS:
      real                 :: AT2VT_vp ! virtual temperature (deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real :: VT (1)

      call ATtoVT_vp ( (/AT/), (/P/), (/VP/), VT, Eqtn )
      AT2VT_vp = VT (1)

      return
      end function AT2VT_vp

!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: AT2VT_mr () --- Air temperature and mixing ratio to virtual temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from air
!     temperature and mixing ratio to virtual temperature
!
! !INTERFACE:
      pure function AT2VT_mr ( AT, MR, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,    intent (in) :: AT       ! air temperature (deg K)
      real,    intent (in) :: MR       ! vapor pressure  (mb or hPa)
      integer, intent (in),   optional ::
     .                        Eqtn     ! equation code (default: 0)
!
! !OUTPUT PARAMETERS:
      real                 :: AT2VT_mr ! virtual temperature (deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real :: VT (1)

      call ATtoVT_mr ( (/AT/), (/MR/), VT, Eqtn )
      AT2VT_mr = VT (1)

      return
      end function AT2VT_mr

!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: VT2AT_vp () --- Virtual temperature and vapor pressure to air temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from virtual
!     temperature and vapor pressure to air temperature
!
! !INTERFACE:
      pure function VT2AT_vp ( VT, P, VP, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,    intent (in) :: VT       ! virtual temperature (deg K)
      real,    intent (in) :: P        ! air pressure (mb or hPa)
      real,    intent (in) :: VP       ! vapor pressure (mb or hPa)
      integer, intent (in),   optional ::
     .                        Eqtn     ! equation code (default: 0)
!
! !OUTPUT PARAMETERS:
      real                 :: VT2AT_vp ! air temperature (deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real :: AT (1)

      call VTtoAT_vp ( (/VT/), (/P/), (/VP/), AT, Eqtn )
      VT2AT_vp = AT (1)

      return
      end function VT2AT_vp

!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: VT2AT_mr () --- Virtual temperature and mixing ratio to air temperature
!
! !DESCRIPTION:
!     This routine converts a set of temperature values from virtual
!     temperature and mixing ratio to air temperature
!
! !INTERFACE:
      pure function VT2AT_mr ( VT, MR, Eqtn )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,    intent (in) :: VT       ! virtual temperature (deg K)
      real,    intent (in) :: MR       ! vapor pressure  (mb or hPa)
      integer, intent (in),   optional ::
     .                        Eqtn     ! equation code (default: 0)
!
! !OUTPUT PARAMETERS:
      real                 :: VT2AT_mr ! air temperature (deg K)
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     23Jul2002  C. Redder   Original code.
!     20Apr2004  C. Redder   Added the optional argument, Eqtn.
!
! EOP
!-------------------------------------------------------------------------

      real :: AT (1)

      call VTtoAT_mr ( (/VT/), (/MR/), AT, Eqtn )
      VT2AT_mr = AT (1)

      return
      end function VT2AT_mr
!......................................................................
      end module m_temperature
!====================================================================


      SUBROUTINE SHSTTS (TAB,UAB,VAB)
C
C     TO CREATE STRESS TENSOR TRANSFORMATION MATRICES FROM AN ORTHOGONAL
C     TRANSFORMATION FOR SHELL ELEMENTS.
C
C     INPUT :
C           TAB    - ORTHOGONAL INPLANE ROTATION TRANSFORMATION
C     OUTPUT:
C           UAB    - TENSOR TRANSFORMATION FOR NORMAL AND INPLANE SHEAR
C                    COMPONENTS
C           VAB    - TENSOR TRANSFORMATION FOR OUT-OF-PLANE SHEAR
C
C     USAGE:
C           THE INPUT IS ASSUMED TO BE ROW-LOADED.
C           OUTPUTS ARE CREATED ROW-LOADED.
C           DEFINING:
C           [S]      AS A 2-D STRESS VECTOR;
C           [E]      AS A 2-D STRAIN VECTOR;
C           [Q]      AS A 2-D SHEAR FORCE VECTOR;
C           [G]      AS A 2-D STRESS/FORCE-STRAIN RELATION; AND
C           [ALPHA]  AS A VECTOR OF THERMAL EXPANSION COEFFICIENTS,
C
C           THEN THE FOLLOWING RELATIONSHIPS ARE TRUE:
C
C                       T                        T
C           [S]  = [UAB] [S]         [G]  = [UAB] [G] [UAB]
C              A            B           A            B
C
C                       T
C           [Q]  = [VAB] [Q]
C              A            B
C
C           IF [TBA] IS INPUT, THE OUTPUT WILL BE:
C
C                -1                      -1       T
C           [UAB]  = [UBA],   AND   [VAB]  = [VAB] = [VBA]
C
C           WHICH MAY BE USED IN THE FOLLOWING:
C
C           [E]  = [UBA] [E]         [ALPHA]  = [UBA] [ALPHA]
C              A            B               A                B
C
C           [Q]  = [VBA][Q]
C              A           B
C
C
      REAL     TAB(9),UAB(9),VAB(4)
C
      UAB(1) = TAB(1)*TAB(1)
      UAB(2) = TAB(4)*TAB(4)
      UAB(3) = TAB(1)*TAB(4)
      UAB(4) = TAB(2)*TAB(2)
      UAB(5) = TAB(5)*TAB(5)
      UAB(6) = TAB(2)*TAB(5)
      UAB(7) = TAB(1)*TAB(2)*2.0
      UAB(8) = TAB(4)*TAB(5)*2.0
      UAB(9) = TAB(1)*TAB(5) + TAB(2)*TAB(4)
C
      VAB(1) = TAB(5)*TAB(9)
      VAB(2) = TAB(2)*TAB(9)
      VAB(3) = TAB(4)*TAB(9)
      VAB(4) = TAB(1)*TAB(9)
C
      RETURN
      END


C-----------------------------------------------------------------------------
C
      double precision function massfrun(mf,scale,asmz,nloop)
C
C-----------------------------------------------------------------------------
C
C       This function returns the 'nloop' value of a MSbar fermion mass
C       at a given scale.
C
C       INPUT: mf    = MSbar mass of fermion at MSbar fermion mass scale
C              scale = scale at which the running mass is evaluated
C              asmz  = AS(MZ) : this is passed to alphas(scale,asmz,2)
C              nloop = # of loops in the evolutionC
C
C       COMMON BLOCKS: COMMON/QMASS/CMASS,BMASS,TMASS
C                      contains the MS-bar masses of the heavy quarks.
C
C       EXTERNAL:      double precision alphas(scale,asmz,2)
C
C-----------------------------------------------------------------------------
C
      implicit none
      include 'masses.f'
C
C     ARGUMENTS
C
      double precision  mf,scale,asmz
      integer           nloop
C
C     LOCAL
C
      double precision  beta0, beta1,gamma0,gamma1
      double precision  A1,as,asmf,l2
      integer  nf
C
C     EXTERNAL
C
      double precision  alphas
      external          alphas
C
C     COMMON
C
c      real *8      cmass,bmass,tmass
c      COMMON/QMASS/CMASS,BMASS,TMASS
c
c     CONSTANTS
c
      double precision  One, Two, Three, Pi
      parameter( One = 1d0, Two = 2d0, Three = 3d0 )
      parameter( Pi = 3.14159265358979323846d0)
cc
C
C

      if ( mf.gt.mt ) then
         nf = 6
      else
         nf = 5
      end if

      beta0 = ( 11d0 - Two/Three *nf )/4d0
      beta1 = ( 102d0  - 38d0/Three*nf )/16d0
      gamma0= one
      gamma1= ( 202d0/3d0  - 20d0/9d0*nf )/16d0
      A1    = -beta1*gamma0/beta0**2+gamma1/beta0
      as    = alphas(scale,asmz,nloop)
      asmf  = alphas(mf   ,asmz,nloop)
      l2    = (one+A1*as/Pi)/(one+A1*asmf/Pi)

      massfrun = mf * (as/asmf)**(gamma0/beta0)

      if(nloop.eq.2) massfrun=massfrun*l2
ccc
      return
      end


      MODULE m_gtest
      use m_juDFT
!*********************************************************************
!     test the gaussian integration mesh for this l
!     1) integrate each ylm, 2) get normalization of each ylm,
!     3) (ylm(lmax,m=lmax | ylm) for all lm
!*********************************************************************
      CONTAINS
      SUBROUTINE gtest(lmax,ngpts,vgauss,wt)

      USE m_constants
      USE m_ylm
      IMPLICIT NONE
!
      INTEGER, INTENT (IN) :: lmax,ngpts
      REAL,    INTENT (IN) :: vgauss(3,*),wt(*) !   gaussian integration points

      INTEGER :: lm,lmmax,nn
      LOGICAL :: lerr
      COMPLEX :: temp
      REAL    :: v(3)
      COMPLEX, DIMENSION((lmax+1)**2) :: ylm,s1,s2,s3

      REAL, PARAMETER :: del = 1.e-10

      lmmax = (lmax+1)**2
      DO lm = 1, lmmax
         s1(lm)=cmplx(0.0,0.0)
         s2(lm)=cmplx(0.0,0.0)
         s3(lm)=cmplx(0.0,0.0)
      ENDDO

!---> loop over points
      DO nn = 1, ngpts
         v(:) = vgauss(:,nn)
         CALL ylm4(
     >             lmax,v,
     <             ylm)
         DO lm = 1, lmmax
            s1(lm) = s1(lm) + wt(nn)*ylm(lm)
            s2(lm) = s2(lm) + wt(nn)*conjg(ylm(lm))*ylm(lm)
            s3(lm) = s3(lm) + wt(nn)*conjg(ylm(lmmax))*ylm(lm)
         ENDDO
      ENDDO

!---> check for non-zero elements
      lerr = .false.
      DO lm=1,lmmax
         IF ((abs(s1(lm)).GT.del).AND.(lm.GT.1)) THEN
            WRITE (oUnit,1000) lm,s1(lm)
            lerr = .true.
         ENDIF
 1000    FORMAT (20x,' integration of s.h. lm=',i3,1p,2e14.6)

         temp = s2(lm) - cmplx(1.0,0.0)
         IF (abs(temp).GT.del) THEN
            WRITE (oUnit,1001) lm,temp
            lerr = .true.
         ENDIF
 1001    FORMAT (20x,' normalization error lm=',i3,1p,2e14.6)

         IF (abs(s3(lm)).GT.del) THEN
            IF(lm.ne.lmmax) THEN
              WRITE (oUnit,1002) lm,s3(lm)
              lerr = .true.
            ELSEIF( abs(abs(s3(lm))-1.0).GT.del ) THEN
              WRITE (oUnit,1002) lm,s3(lm)
              lerr = .true.
            ENDIF
         ENDIF
 1002    FORMAT (20x,' (ylm(lmax,lmax) | ylm)    lm=',i3,1p,2e14.6)
      ENDDO

      IF (lerr) THEN
        WRITE (oUnit,'(/,'' error in gaussian points'')')
         CALL juDFT_error("Error in gaussian points",calledby="gtest")
      ENDIF

      RETURN
      END SUBROUTINE gtest
      END MODULE m_gtest


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.

module mod_spectral_shapes

use mod_precision,only:ik => intkind,rk => realkind
use mod_const,only:twopi
use mod_nondimensional,only:nondimensionalFetch,nondimensionalFrequency

implicit none

private

public :: donelanHamiltonHui
public :: donelanHamiltonHuiDirectionalSpreading
public :: donelanHamiltonHuiDirectionalSpectrum
public :: jonswap
public :: jonswapPeakFrequency
public :: piersonMoskowitz
public :: piersonMoskowitzPeakFrequency
public :: phillips

!===============================================================================
contains

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function donelanHamiltonHui(f,fpeak,wspd,grav)&
  result(spec)

  !! The omnidirectional spectrum function based on the laboratory and field
  !! measurements by Donelan, Hamilton, and Hui (1985).
  !!
  !! References:
  !!
  !! Donelan, M. A., J. Hamilton, and W. H. Hui, 1985. Directional
  !! spectra of wind-generated waves. Phil. Trans. Royal Soc. London A.,
  !! 315, 509-562.

  real(kind=rk),intent(in) :: f !! Frequency [Hz]
  real(kind=rk),intent(in) :: fpeak !! Peak frequency [Hz]
  real(kind=rk),intent(in) :: wspd !! Wind speed at 10 m height [m/s]
  real(kind=rk),intent(in) :: grav !! Gravitational acceleration [m/s^2]

  real(kind=rk) :: beta
  real(kind=rk) :: gamma ! Peak enhancement factor
  real(kind=rk) :: nu ! Nondimensional frequency
  real(kind=rk) :: r ! Exponent in peak enhancement factor
  real(kind=rk) :: omega ! Radian frequency [rad/s]
  real(kind=rk) :: sigma ! Spread of the spectrum peak

  omega = twopi*f
  nu = nondimensionalFrequency(wspd,fpeak,grav)
  if(nu >= 0.159_rk)then
    gamma = 6.489_rk + 6*log10(nu)
    if(gamma < 0)gamma = 0
  else
    gamma = 1.7_rk
  endif
  sigma = 0.08_rk + 1.29e-3_rk*nu**(-3)
  r = exp(-0.5_rk*((f-fpeak)/(sigma*fpeak))**2)
  beta = 0.0165_rk*nu**0.55_rk
  spec = twopi*beta*grav**2/omega**4/fpeak*exp(-(fpeak/f)**4)*gamma**r

endfunction donelanHamiltonHui
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function donelanHamiltonHuiDirectionalSpreading(f,&
  wspd,fpeak,theta,theta_mean) result(spreading)

  !! Directional spreading function based on the laboratory and field
  !! measurements by Donelan, Hamilton, and Hui (1985). Includes the
  !! high-frequency form for beta_s found by Banner (1990).
  !!
  !! References:
  !!
  !! Donelan, M. A., J. Hamilton, and W. H. Hui, 1985. Directional
  !! spectra of wind-generated waves. *Phil. Trans. Royal Soc. London A.*,
  !! **315**, 509-562.
  !!
  !! Banner, M. L., 1990. Equilibrium spectra of wind waves. *J. Phys.
  !! Oceanogr.*, **20**, 966-984.

  real(kind=rk),intent(in) :: f !! Frequency [Hz]
  real(kind=rk),intent(in) :: wspd !! Wind speed at 10 m height [m/s]
  real(kind=rk),intent(in) :: fpeak !! Peak frequency [Hz]
  real(kind=rk),intent(in) :: theta !! Wave direction [rad]
  real(kind=rk),intent(in) :: theta_mean !! Mean wave direction [rad]

  real(kind=rk) :: frel ! Frequency relative to peak frequency, f/fpeak
  real(kind=rk) :: nu ! Nondimensional frequency
  real(kind=rk) :: beta

  frel = f/fpeak

  if(frel < 0.56_rk)then
    beta = 1.24_rk
  elseif(frel >= 0.56_rk .and. frel < 0.95_rk)then
    beta = 2.61_rk*frel**1.3_rk
  elseif(frel >= 0.95_rk .and. frel < 1.6_rk)then
    beta = 2.28_rk*frel**(-1.3_rk)
  else
    beta = 10**(-0.4_rk+0.8393_rk*exp(-0.567_rk*log(frel**2)))
  endif

  spreading = 0.5_rk*beta/cosh(beta*(theta-theta_mean))**2

endfunction donelanHamiltonHuiDirectionalSpreading
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function donelanHamiltonHuiDirectionalSpectrum(f,theta,wspd,fpeak,&
  theta_mean,grav) result(spec)

  !! Returns directional frequency spectrum based on the laboratory and field
  !! measurements by Donelan, Hamilton, and Hui (1985). Includes the high
  !! frequency form for beta_s found by Banner (1990). This function invokes the
  !!  DHH omnidirectional spectrum and the directional spreading functions to
  !! compute directional frequency spectrum:
  !!
  !! $$
  !!     F(f,\theta) = F'(f) * D(f,\theta)
  !! $$
  !!
  !! References:
  !!
  !! Donelan, M. A., J. Hamilton, and W. H. Hui, 1985. Directional
  !! spectra of wind-generated waves. Phil. Trans. Royal Soc. London A.,
  !! 315, 509-562.
  !!
  !! Banner, M. L., 1990. Equilibrium spectra of wind waves. J. Phys. Oceanogr.,
  !! 20, 966-984.

  real(kind=rk),dimension(:),intent(in) :: f !! Frequency [Hz]
  real(kind=rk),dimension(:),intent(in) :: theta !! Wave direction [rad]
  real(kind=rk),intent(in) :: wspd !! Wind speed at 10 m height [m/s]
  real(kind=rk),intent(in) :: fpeak !! Peak frequency [Hz]
  real(kind=rk),intent(in) :: theta_mean !! Mean wave direction [rad]
  real(kind=rk),intent(in) :: grav !! Gravitational acceleration [m/s^2]

  real(kind=rk),dimension(:,:),allocatable :: spec

  integer(kind=ik) :: ndir

  allocate(spec(size(f),size(theta)))

  do concurrent(ndir = 1:size(theta))
    spec(:,ndir) = donelanHamiltonHui(f,fpeak,wspd,grav)&
      * donelanHamiltonHuiDirectionalSpreading(f,wspd,fpeak,theta(ndir),&
                                               theta_mean)
  enddo

endfunction donelanHamiltonHuiDirectionalSpectrum
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function jonswap(f,wspd,fetch,grav) result(spec)

  !! Computes the JONSWAP equilibrium spectrum (Hasselmann et al. 1973) based on
  !!  input wind speed at the height of 10 m and fetch.
  !!
  !! References:
  !!
  !! Hasselmann, K. et al., 1973. Measurements of wind-wave growth and swell
  !! decay during the Joint North Sea Wave Project (JONSWAP). Dtsch. Hydrogh.
  !! Z., Suppl. A, 8, 12, 95pp.

  real(kind=rk),intent(in) :: f !! Frequency [Hz]
  real(kind=rk),intent(in) :: wspd !! Wind speed at 10 m height [m/s]
  real(kind=rk),intent(in) :: fetch !! Fetch [m]
  real(kind=rk),intent(in) :: grav !! Gravitational acceleration [m/s^2]

  real(kind=rk) :: alpha ! Phillips' constant
  real(kind=rk) :: sigma ! Spread of the spectrum peak
  real(kind=rk) :: r ! Exponent in peak enhancement factor

  real(kind=rk) :: fpeak ! Peak frequency [Hz]
  real(kind=rk) :: omega ! Radian frequency [rad/s]

  real(kind=rk),parameter :: beta = -1.25_rk
  real(kind=rk),parameter :: gamma = 3.3_rk ! peak enhancement

  omega = twopi*f
  alpha = 0.076_rk*nondimensionalFetch(wspd,fetch,grav)**(-0.22_rk)
  fpeak = jonswapPeakFrequency(wspd,fetch,grav)
  if(f > fpeak)then
    sigma = 0.09_rk
  else
    sigma = 0.07_rk
  endif
  r = exp(-0.5_rk*((f-fpeak)/(sigma*fpeak))**2)
  spec = twopi*alpha*grav**2/omega**5*exp(beta*(fpeak/f)**4)*gamma**r

endfunction jonswap
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function jonswapPeakFrequency(wspd,fetch,grav)&
  result(fpeak)

  !! Computes the JONSWAP equilibrium peak frequency [Hz] on the input
  !! based on the 10-m wind speed and fetch [km] (Hasselmann et al., 1973).
  !!
  !! References:
  !!
  !! Hasselmann, K. et al., 1973. Measurements of wind-wave growth and swell
  !! decay during the Joint North Sea Wave Project (JONSWAP). Dtsch. Hydrogh.
  !! Z., Suppl. A, 8, 12, 95pp.

  real(kind=rk),intent(in) :: wspd !! Wind speed at 10 m height [m/s]
  real(kind=rk),intent(in) :: fetch !! Fetch [m]
  real(kind=rk),intent(in) :: grav !! Gravitational acceleration [m/s^2]

  real(kind=rk),parameter :: a = 3.5_rk
  real(kind=rk),parameter :: b = 1._rk/3._rk

  fpeak = a*(grav**2/(wspd*fetch))**b

endfunction jonswapPeakFrequency
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function phillips(f,fpeak,grav) result(spec)

  !! Computes the Phillips (1958) equilibrium spectrum based on the input
  !! peak frequency [Hz].
  !!
  !! References:
  !!
  !! Phillips, O.M., 1958. The equilibrium range in the spectrum of
  !! wind-generated waves. J. Fluid Mech., 4, 426–434.
  !! doi:10.1017/S0022112058000550.

  real(kind=rk),intent(in) :: f !! Frequency [Hz]
  real(kind=rk),intent(in) :: fpeak !! Peak frequency [Hz]
  real(kind=rk),intent(in) :: grav !! Gravitational acceleration [m/s^2]

  real(kind=rk),parameter :: alpha = 8.13e-3 !! Phillips' parameter

  if(f < fpeak)then
    spec = 0
  else
    spec = alpha*grav**2*(twopi*f)**(-5)
  endif

endfunction phillips
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function piersonMoskowitz(f,wspd,grav) result(spec)

  !! Computes the Pierson-Moskowitz (1964) equilibrium spectrum based on input
  !! wind speed at the height of 10 m.
  !!
  !! References:
  !!
  !! Pierson Jr., W. J., and L. Moskowitz (1964), A proposed spectral form for
  !! fully developed wind seas based on the similarity theory of S. A.
  !! Kitaigorodskii, J. Geophys. Res., 69(24), 5181–5190,
  !! doi:10.1029/JZ069i024p05181.

  real(kind=rk),intent(in) :: f !! Frequency [Hz]
  real(kind=rk),intent(in) :: wspd !! Wind speed at 10 m height [m/s]
  real(kind=rk),intent(in) :: grav !! Gravitational acceleration [m/s^2]

  real(kind=rk) :: omega
  real(kind=rk) :: fpeak

  real(kind=rk),parameter :: alpha = 8.1e-3_rk ! Phillips' constant
  real(kind=rk),parameter :: beta = -1.25_rk

  omega = twopi*f
  fpeak = piersonMoskowitzPeakFrequency(wspd,grav)
  spec = twopi*alpha*grav**2/omega**5*exp(beta*(fpeak/f)**4)

endfunction piersonMoskowitz
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function piersonMoskowitzPeakFrequency(wspd,grav)&
  result(fpeak)

  !! Computes the Pierson-Moskowitz (1964) peak frequency based on input wind
  !! speed at the height of 10 m.
  !!
  !! References:
  !!
  !! Pierson Jr., W. J., and L. Moskowitz (1964), A proposed spectral form for
  !! fully developed wind seas based on the similarity theory of S. A.
  !! Kitaigorodskii, J. Geophys. Res., 69(24), 5181–5190,
  !! doi:10.1029/JZ069i024p05181.

  real(kind=rk),intent(in) :: wspd !! Wind speed at 10 m height [m/s]
  real(kind=rk),intent(in) :: grav !! Gravitational acceleration [m/s^2]
  real(kind=rk),parameter :: const = 0.1325_rk

  fpeak = const*grav/max(wspd,1e-2_rk)

endfunction piersonMoskowitzPeakFrequency
!-------------------------------------------------------------------------------
endmodule mod_spectral_shapes


PROGRAM CONVERT_TEMP
    IMPLICIT NONE
    REAL centigrade, fahrenheit
    PRINT *, "Enter the temprature in centigrade"
    READ *, centigrade
    ! Perform the calculation
    fahrenheit = (centigrade*9.0 / 5.0) + 32.0
    PRINT *, " Fahrenheit temprature is : ", fahrenheit
    PRINT *, 10**4 !
    STOP
END


c     # ---------------------------------------------------------------
      double precision function q0_physical(xp,yp,zp)
      implicit none

      double precision xp, yp, zp

      double precision x0, y0, z0, q0, r0, r
      double precision xpp, ypp
      double precision Hsmooth

c     # Sphere centered at (0.5,0.5,0) on swirl
      x0 = 0.5
      y0 = 0.5
      z0 = 0
      r0 = 0.2   !! radius of sphere

c     # modulo(A,P) = A - floor(A/P)*P
c      write(6,*) 'mod(6.1,1.d0)  ', modulo(6.1d0,1.d0)
c      write(6,*) 'mod(0.5,1.d0)  ', modulo(0.5d0,1.d0)
c      write(6,*) 'mod(-0.5,1.d0) ', modulo(-0.5d0,1.d0)
c      write(6,*) 'mod(-1.3,1.d0) ', modulo(-1.3d0,1.d0)
c      write(6,*) ' '
c      write(6,*) 'mod(6.1,1.d0)  ', 6.1d0 - floor(6.1d0)
c      write(6,*) 'mod(0.5,1.d0)  ', 0.5d0 - floor(0.5d0)
c      write(6,*) 'mod(-0.5,1.d0) ', -0.5d0 - floor(-0.5d0)
c      write(6,*) 'mod(-1.3,1.d0) ', -1.3d0 - floor(-1.3d0)
c      stop

      xpp = modulo(xp,1.d0)
      ypp = modulo(yp,1.d0)

      r = sqrt((xpp - x0)**2 + (ypp-y0)**2)
      q0 = Hsmooth(r + r0) - Hsmooth(r - r0)

      q0_physical = q0

      end

c     # ---------------------------------------------------------------
      double precision function Hsmooth(r)
      implicit none

      double precision r

      Hsmooth = (tanh(r/0.02d0) + 1)/2.d0

      end


      program bucle_simultaneo
        implicit none
        real, parameter :: pi =3.14159265
        integer, parameter :: n=10
        real :: resultado_sin(n)
        integer :: i
        do  concurrent (i=1:n) !Cuidado la sintaxis es ligeramente diferente
          resultado_sin(i)=sin(i*pi/4.)
        end do
        print *, resultado_sin
      end program bucle_simultaneo


! =============================================================================
!                       Test trilinear interpolation
!
!         This unit test checks the trilinear interpolation par2grid
! =============================================================================
program test_trilinear
    use unit_test
    use constants, only : pi, zero, one, f12, f23, f32
    use parcel_container
    use parcel_interpl, only : par2grid, par2grid_timer
    use parcel_ellipsoid, only : get_abc
    use parameters, only : lower, update_parameters, vcell, dx, nx, ny, nz, ngrid
    use fields, only : volg, field_alloc
    use timer
    implicit none

    double precision :: error
    integer          :: ix, iy, iz, i, j, k, l, n_per_dim
    double precision :: im, corner(3)

    nx = 32
    ny = 32
    nz = 32
    lower  = (/-f32, -f32, -f32/)
    extent =  (/0.4d0, 0.4d0, 0.4d0/)

    call register_timer('par2grid', par2grid_timer)

    call update_parameters

    call field_alloc

    n_per_dim = 3

    n_parcels = n_per_dim ** 3 * nx *ny *nz
    call parcel_alloc(n_parcels)

    im = one / dble(n_per_dim)

    l = 1
    do iz = 0, nz-1
        do iy = 0, ny-1
            do ix = 0, nx-1
                corner = lower + dble((/ix, iy, iz/)) * dx
                do k = 1, n_per_dim
                    do j = 1, n_per_dim
                        do i = 1, n_per_dim
                            parcels%position(1, l) = corner(1) + dx(1) * (dble(i) - f12) * im
                            parcels%position(2, l) = corner(2) + dx(2) * (dble(j) - f12) * im
                            parcels%position(3, l) = corner(3) + dx(3) * (dble(k) - f12) * im
                            l = l + 1
                        enddo
                    enddo
                enddo
            enddo
        enddo
    enddo

    parcels%volume = vcell / dble(n_per_dim ** 3)

    parcels%B(:, :) = zero

    ! b11
    parcels%B(1, :) = get_abc(parcels%volume(1:n_parcels)) ** f23

    ! b22
    parcels%B(4, :) = parcels%B(1, :)

    call par2grid

    error = abs(sum(volg(0:nz, :, :)) - dble(ngrid) * vcell)

    call print_result_dp('Test trilinear (par2grid)', error, atol=dble(3.0e-14))

end program test_trilinear


! Recursive Fortran 95 quicksort routine
! sorts real numbers into ascending numerical order
! Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03
! Based on algorithm from Thomas H. Cormen, Charles E. Leiserson, Ronald L.
! Rivest, and Clifford Stein, Introduction to Algorithms, The MIT Press, 1997 edition.

! Made F conformant by Walt Brainerd

! Modified by Giulio Fella (02/2013) to sort the array index accordingly

! Contains the component subroutines: Partition, QsortC

MODULE mod_gf_qsort
  IMPLICIT NONE
  PUBLIC :: QsortC
  PRIVATE :: Partition

  ! Set kind of real arrays
  INTEGER, PARAMETER :: ki=SELECTED_REAL_KIND(p = 15, r = 30)

CONTAINS

  RECURSIVE SUBROUTINE QsortC(A, index_A)
    ! Input/output variables
    ! A    	: real(precision) array to sort
    ! index_A   : integer array indexing elements of A
    REAL(ki), INTENT(in out), DIMENSION(:) :: A
    INTEGER, INTENT(in out), DIMENSION(SIZE(A)) :: index_A
    INTEGER :: iq

    IF(SIZE(A) > 1) THEN
      CALL Partition(A,index_A, iq)
      CALL QsortC(A(:iq-1),index_A(:iq-1))
      CALL QsortC(A(iq:),index_A(iq:))
    ENDIF
  END SUBROUTINE QsortC

  SUBROUTINE Partition(A, index_A, marker)
    REAL(ki), INTENT(in out), DIMENSION(:) :: A
    INTEGER, INTENT(in out), DIMENSION(SIZE(A)) :: index_A
    INTEGER, INTENT(out) :: marker
    INTEGER :: i, j
    INTEGER :: index_temp
    REAL(ki) :: temp
    REAL(ki) :: x      ! pivot point
    x = A(1)
    i= 0
    j= SIZE(A) + 1

    DO
      j = j-1
      DO
        IF (A(j) <= x) EXIT
        j = j-1
      END DO
      i = i+1
      DO
        IF (A(i) >= x) EXIT
        i = i+1
      END DO
      IF (i < j) THEN
        ! exchange A(i) and A(j)
        temp = A(i)
        A(i) = A(j)
        A(j) = temp

        index_temp = index_A(i)
        index_A(i) = index_A(j)
        index_A(j) = index_temp

      ELSEIF (i == j) THEN
        marker = i+1
        RETURN
      ELSE
        marker = i
        RETURN
      ENDIF
    END DO

  END SUBROUTINE Partition

END MODULE mod_gf_qsort


    program demo_maxval
    implicit none
    integer,save :: ints(3,5)= reshape([&
       1,  2,  3,  4,  5, &
      10, 20, 30, 40, 50, &
      11, 22, 33, 44, 55  &
    ],shape(ints),order=[2,1])

       write(*,*) maxval(ints)
       write(*,*) maxval(ints,dim=1)
       write(*,*) maxval(ints,dim=2)
       ! find biggest number less than 30 with mask
       write(*,*) maxval(ints,mask=ints.lt.30)
    end program demo_maxval


PROGRAM square_roots

IMPLICIT NONE

INTEGER :: i
REAL, DIMENSION(10) :: value = (/ (i, i=1,10) /)
REAL, DIMENSION(10) :: square_root

! Calculate the square roots of the numbers.
DO i = 1, 10
   square_root(i) = SQRT(value(i))
END DO

! Write out each number and its square root.
DO i = 1, 10
   WRITE (*,100) value(i), square_root(i)
   100 FORMAT (1X,'Value = ',F5.1,'  Square Root = ',F10.4)
END DO

END PROGRAM square_roots


module functions

    implicit none
    integer :: gevals
    save

contains

    function g(x,ndim)

    implicit none
    integer, intent(in) :: ndim
    real(kind=8), intent(in) :: x(ndim)
    real(kind=8) :: g
    integer :: i

    g = 0.d0
    do i=1,ndim
        g = g + x(i)**2
        enddo

    gevals = gevals + 1

    end function g

end module functions


!*****************************************************************************************
!> author: Jacob Williams
!  date: 12/6/2015
!
!  Tests for different knot vectors.
!
!  This requires [pyplot_module](https://github.com/jacobwilliams/pyplot-fortran)
!
!### Results
!  ![Plot of results](https://raw.githubusercontent.com/jacobwilliams/bspline-fortran/master/src/tests/results/knot_tests.png)

    program knot_tests

    use bspline_module
    use bspline_kinds_module, only: wp, ip
    use pyplot_module
    use, intrinsic :: iso_fortran_env

    implicit none

    integer :: i    !! counter

    integer(ip),parameter :: kx  = 4    !! x bspline order
    integer(ip),parameter :: nx  = 6    !! number of points in x dimension
    real(wp),dimension(nx),parameter :: x = [(real(i*10,wp), i=0,11,(10+2)/nx)]    !! [0,20,40,60,80,100]

    real(wp),dimension(nx)    :: fcn
    real(wp),dimension(nx+kx) :: tx
    type(bspline_1d)          :: s_default, s1, s2
    real(wp),dimension(0:100) :: x_new,f_new_default,f1,f2 !,f_actual
    real(wp)                  :: xval
    type(pyplot)              :: plt
    integer(ip)               :: iflag
    integer                   :: istat  !! pyplot-fortran status flag

    !function evaluations for original grid:
    do i=1,nx
        fcn(i) = test_func(x(i))
    end do

    !initialize the plot:
    call plt%initialize(grid=.true.,xlabel='x',ylabel='f(x)',&
                        title='Knot Test',legend=.true.)
    call plt%add_plot(real(x,real64),real(fcn,real64),&
                        label='Function $f(x) = \sin(x \cdot \pi/18)$ : $x=[0,20,40,60,80,100]$',&
                        linestyle='ko--',markersize=5,linewidth=2,istat=istat)

    !initialize three with different knot sequences:

    ! x = [ 0,      20,40,60,80,100                ] (x points)
    ! t = [ 0,0,0,0,   40,60,      101,101,101,101 ] (tx for not a knot conditions)

    call s_default%initialize(x,fcn,kx,iflag)  !default (not-a-knot)
    if (iflag/=0) error stop 'error initializing s_default'

    !user-specified knots:

    tx = real([0,0,0,0,20,40,101,101,101,101], wp)
    call s1%initialize(x,fcn,kx,tx,iflag)
    if (iflag/=0) error stop 'error initializing s1'

    tx = real([0,0,0,0,60,80,101,101,101,101], wp)
    call s2%initialize(x,fcn,kx,tx,iflag)
    if (iflag/=0) error stop 'error initializing s2'

    do i = 0,100

        xval     = real(i,wp)
        x_new(i) = xval

        !f_actual(i) = test_func(xval)

        call s_default%evaluate(xval,0_ip,f_new_default(i),iflag)
        if (iflag/=0) error stop 'error evaluating s_default'

        call s1%evaluate(xval,0_ip,f1(i),iflag)
        if (iflag/=0) error stop 'error evaluating s1'

        call s2%evaluate(xval,0_ip,f2(i),iflag)
        if (iflag/=0) error stop 'error evaluating s2'

    end do

    !call plt%add_plot(x_new,f_actual,label='Actual function',linestyle='k--',linewidth=2)

    call plt%add_plot(real(x_new,real64),real(f_new_default,real64),&
            label='Interpolated : $t_x=[0,0,0,0,40,60,102,102,102,102]$ (Default)',&
            linestyle='b-',linewidth=1,istat=istat)
    call plt%add_plot(real(x_new,real64),real(f1,real64),&
            label='Interpolated : $t_x=[0,0,0,0,20,40,101,101,101,101]$',&
            linestyle='r-',linewidth=1,istat=istat)
    call plt%add_plot(real(x_new,real64),real(f2,real64),&
            label='Interpolated : $t_x=[0,0,0,0,60,80,101,101,101,101]$',&
            linestyle='g-',linewidth=1,istat=istat)

    !plot the results:
    call plt%savefig('knot_tests.png',istat=istat)

    contains

        pure function test_func(x) result(f)
        !! 1d test function

        implicit none

        real(wp) :: f
        real(wp),intent(in) :: x

        real(wp),parameter :: a = acos(-1.0_wp)/18.0_wp

        f = sin(a*x)

        end function test_func

    end program knot_tests