pkg/openad/seawater.F

5dddee4ea2 Jean*0001 #include "CPP_OPTIONS.h"
                0002
                0003 C--  File seawater.F: routines that compute quantities related to seawater.
                0004 C--   Contents
d0305341db Mart*0005 C--   o SW_PTMP: routine to compute potential temperature (used by SW_TEMP)
58a003f85e Jean*0006 C--   o SW_TEMP: routine to compute in-situ temperature from pot. temp.
                0007 C--   o SW_ADTG: routine to compute adiabatic temperature gradient
d0305341db Mart*0008 C--              (used by SW_PTMP)
5dddee4ea2 Jean*0009
da3bdb7dd1 Jean*0010 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0011
                0012 CBOP
                0013 C     !ROUTINE: SW_PTMP
                0014 C     !INTERFACE:
58a003f85e Jean*0015       SUBROUTINE SW_PTMP  (S,T,P,PR, rv)
5dddee4ea2 Jean*0016
                0017 C     !DESCRIPTION: \bv
da3bdb7dd1 Jean*0018 C     *=============================================================*
                0019 C     | S/R  SW_PTMP
                0020 C     | o compute potential temperature as per UNESCO 1983 report.
                0021 C     *=============================================================*
d0305341db Mart*0022 C     \ev
da3bdb7dd1 Jean*0023 C     started:
                0024 C              Armin Koehl akoehl@ucsd.edu
                0025 C
                0026 C     ==================================================================
                0027 C     SUBROUTINE SW_PTMP
                0028 C     ==================================================================
5dddee4ea2 Jean*0029
                0030 C     !USES:
                0031       IMPLICIT NONE
d0305341db Mart*0032 C     === Global variables ===
5dddee4ea2 Jean*0033
                0034 C     !INPUT/OUTPUT PARAMETERS:
d0305341db Mart*0035 C     === Routine arguments ===
ba0b047096 Mart*0036 C     S  :: salinity    [         (PSS-78) ]
d0305341db Mart*0037 C     T  :: temperature [degree C (IPTS-68)]
                0038 C     P  :: pressure    [db]
                0039 C     PR :: Reference pressure  [db]
                0040 C     rv :: return value (potential temeparture in degree C)
5dddee4ea2 Jean*0041       _RL S,T,P,PR
                0042       _RL rv
                0043
da3bdb7dd1 Jean*0044 C     !LOCAL VARIABLES
d0305341db Mart*0045 C     === local variables ===
5dddee4ea2 Jean*0046       _RL del_P ,del_th, th, q
                0047       _RL onehalf, two, three
da3bdb7dd1 Jean*0048       PARAMETER ( onehalf = 0.5 _d 0, two = 2. _d 0, three = 3. _d 0 )
5dddee4ea2 Jean*0049       _RL adtg_val
da3bdb7dd1 Jean*0050 CEOP
                0051
                0052 C theta1
5dddee4ea2 Jean*0053       del_P  = PR - P
                0054       call sw_adtg(S,T,P, adtg_val)
                0055       del_th = del_P*adtg_val
                0056       th     = T + onehalf*del_th
                0057       q      = del_th
da3bdb7dd1 Jean*0058 C theta2
5dddee4ea2 Jean*0059       call sw_adtg(S,th,P+onehalf*del_P, adtg_val)
                0060       del_th = del_P*adtg_val
                0061
                0062       th     = th + (1 - 1/sqrt(two))*(del_th - q)
                0063       q      = (two-sqrt(two))*del_th + (-two+three/sqrt(two))*q
                0064
da3bdb7dd1 Jean*0065 C theta3
5dddee4ea2 Jean*0066       call sw_adtg(S,th,P+onehalf*del_P, adtg_val)
                0067       del_th = del_P*adtg_val
                0068       th     = th + (1 + 1/sqrt(two))*(del_th - q)
                0069       q      = (two + sqrt(two))*del_th + (-two-three/sqrt(two))*q
                0070
da3bdb7dd1 Jean*0071 C theta4
5dddee4ea2 Jean*0072       call sw_adtg(S,th,P+del_P, adtg_val)
                0073       del_th = del_P*adtg_val
                0074       rv     = th + (del_th - two*q)/(two*three)
da3bdb7dd1 Jean*0075       RETURN
                0076       END
5dddee4ea2 Jean*0077
da3bdb7dd1 Jean*0078 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5dddee4ea2 Jean*0079
                0080 CBOP
                0081 C     !ROUTINE: SW_TEMP
                0082 C     !INTERFACE:
58a003f85e Jean*0083       SUBROUTINE SW_TEMP( S, T, P, PR, rv)
5dddee4ea2 Jean*0084 C     !DESCRIPTION: \bv
                0085 C     *=============================================================*
                0086 C     | S/R  SW_TEMP
                0087 C     | o compute in-situ temperature from potential temperature
                0088 C     *=============================================================*
                0089 C
                0090 C     REFERENCES:
                0091 C     Fofonoff, P. and Millard, R.C. Jr
                0092 C     Unesco 1983. Algorithms for computation of fundamental properties of
                0093 C     seawater, 1983. _Unesco Tech. Pap. in Mar. Sci._, No. 44, 53 pp.
                0094 C     Eqn.(31) p.39
                0095 C
                0096 C     Bryden, H. 1973.
07712e28f8 Jean*0097 C     New Polynomials for thermal expansion, adiabatic temperature gradient
                0098 C     and potential temperature of sea water.
5dddee4ea2 Jean*0099 C     DEEP-SEA RES., 1973, Vol20,401-408.
d0305341db Mart*0100 C     \ev
5dddee4ea2 Jean*0101
                0102 C     !USES:
                0103       IMPLICIT NONE
                0104 C     === Global variables ===
                0105
                0106 C     !INPUT/OUTPUT PARAMETERS:
                0107 C     === Routine arguments ===
da3bdb7dd1 Jean*0108 C     S      :: salinity
                0109 C     T      :: potential temperature
                0110 C     P      :: pressure
                0111 C     PR     :: reference pressure
d0305341db Mart*0112 C     rv :: return value (in-situ temeparture in degree C)
da3bdb7dd1 Jean*0113       _RL  S, T, P, PR
5dddee4ea2 Jean*0114       _RL rv
                0115
da3bdb7dd1 Jean*0116 C     !LOCAL VARIABLES:
d0305341db Mart*0117 C     === local variables ===
                0118 CEOP
5dddee4ea2 Jean*0119
d0305341db Mart*0120       CALL SW_PTMP  (S,T,PR,P,rv)
5dddee4ea2 Jean*0121
                0122       RETURN
                0123       END
                0124
da3bdb7dd1 Jean*0125 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5dddee4ea2 Jean*0126
da3bdb7dd1 Jean*0127 CBOP
                0128 C     !ROUTINE: SW_ADTG
                0129 C     !INTERFACE:
5dddee4ea2 Jean*0130       SUBROUTINE SW_ADTG  (S,T,P, rv)
                0131
da3bdb7dd1 Jean*0132 C     !DESCRIPTION: \bv
                0133 C     *=============================================================*
                0134 C     | S/R  SW_ADTG
                0135 C     | o compute adiabatic temperature gradient as per UNESCO 1983 routines.
                0136 C     *=============================================================*
d0305341db Mart*0137 C     \ev
da3bdb7dd1 Jean*0138 C
                0139 C     started:
                0140 C              Armin Koehl akoehl@ucsd.edu
                0141
                0142 C     !USES:
                0143       IMPLICIT NONE
d0305341db Mart*0144 C     === Global variables ===
da3bdb7dd1 Jean*0145
                0146 C     !INPUT/OUTPUT PARAMETERS:
d0305341db Mart*0147 C     === Routine arguments ===
5dddee4ea2 Jean*0148       _RL S,T,P
58a003f85e Jean*0149       _RL rv
da3bdb7dd1 Jean*0150
                0151 C     !LOCAL VARIABLES:
d0305341db Mart*0152 C     === local variables ===
da3bdb7dd1 Jean*0153       _RL a0,a1,a2,a3,b0,b1,c0,c1,c2,c3,d0,d1,e0,e1,e2
5dddee4ea2 Jean*0154       _RL sref
da3bdb7dd1 Jean*0155 CEOP
5dddee4ea2 Jean*0156
                0157       sref = 35. _d 0
                0158       a0 =  3.5803 _d -5
                0159       a1 = +8.5258 _d -6
                0160       a2 = -6.836 _d -8
                0161       a3 =  6.6228 _d -10
                0162
                0163       b0 = +1.8932 _d -6
                0164       b1 = -4.2393 _d -8
                0165
                0166       c0 = +1.8741 _d -8
                0167       c1 = -6.7795 _d -10
                0168       c2 = +8.733 _d -12
                0169       c3 = -5.4481 _d -14
                0170
                0171       d0 = -1.1351 _d -10
                0172       d1 =  2.7759 _d -12
                0173
                0174       e0 = -4.6206 _d -13
                0175       e1 = +1.8676 _d -14
                0176       e2 = -2.1687 _d -16
                0177
                0178       rv =      a0 + (a1 + (a2 + a3*T)*T)*T
                0179      &     + (b0 + b1*T)*(S-sref)
                0180      &     + ( (c0 + (c1 + (c2 + c3*T)*T)*T) + (d0 + d1*T)*(S-sref) )*P
                0181      &     + (  e0 + (e1 + e2*T)*T )*P*P
da3bdb7dd1 Jean*0182
                0183       RETURN
                0184       END