model/src/seawater.F

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