*IF DEF,A05_2A,OR,DEF,A05_2C,OR,DEF,A05_3B AJX1F405.186
C ******************************COPYRIGHT****************************** GTS2F400.8407
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8408
C GTS2F400.8409
C Use, duplication or disclosure of this code is subject to the GTS2F400.8410
C restrictions as set forth in the contract. GTS2F400.8411
C GTS2F400.8412
C Meteorological Office GTS2F400.8413
C London Road GTS2F400.8414
C BRACKNELL GTS2F400.8415
C Berkshire UK GTS2F400.8416
C RG12 2SZ GTS2F400.8417
C GTS2F400.8418
C If no contract has been raised with this copy of the code, the use, GTS2F400.8419
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8420
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8421
C Modelling at the above address. GTS2F400.8422
C ******************************COPYRIGHT****************************** GTS2F400.8423
C GTS2F400.8424
CLL SUBROUTINE SATCAL------------------------------------------------- SATCAL2A.3
CLL SATCAL2A.4
CLL PURPOSE : CALCULATES SATURATED TEMPERATURE SATCAL2A.5
CLL SATCAL2A.6
CLL SUITABLE FOR SINGLE COLUMN MODEL USE SATCAL2A.7
CLL SATCAL2A.8
CLL CODE WRITTEN FOR CRAY Y-MP BY S.BETT AND D.GREGORY AUTUMN 1991 SATCAL2A.9
CLL SATCAL2A.10
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: SATCAL2A.11
CLL VERSION DATE SATCAL2A.12
CLL 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.17
CLL SATCAL2A.13
CLL PROGRAMMING STANDARDS : UNIFIED MODEL DOCUMENTATION PAPER NO. 3 SATCAL2A.14
CLL VERSION NO. 4 DATED 5/2/92 SATCAL2A.15
CLL SATCAL2A.16
CLL SYSTEM TASK : P27 SATCAL2A.17
CLL SATCAL2A.18
CLL DOCUMENTATION : UNIFIED MODEL DOCUMENTATION PAPER P27 SATCAL2A.19
CLL SATCAL2A.20
CLLEND----------------------------------------------------------------- SATCAL2A.21
C SATCAL2A.22
C*L ARGUMENTS--------------------------------------------------------- SATCAL2A.23
C SATCAL2A.24
SUBROUTINE SATCAL (NPNTS,T,TH,PK,QS,THDDS,K,EXK,Q_K,THE_K) 10,6SATCAL2A.25
C SATCAL2A.26
IMPLICIT NONE SATCAL2A.27
C SATCAL2A.28
C----------------------------------------------------------------------- SATCAL2A.29
C MODEL CONSTANTS SATCAL2A.30
C----------------------------------------------------------------------- SATCAL2A.31
C SATCAL2A.32
*CALL C_LHEAT 
SATCAL2A.33
*CALL C_R_CP SATCAL2A.34
*CALL C_0_DG_C SATCAL2A.35
C SATCAL2A.36
C----------------------------------------------------------------------- SATCAL2A.37
C VECTOR LENGTHS AND LOOP COUNTERS SATCAL2A.38
C----------------------------------------------------------------------- SATCAL2A.39
C SATCAL2A.40
C SATCAL2A.44
INTEGER I ! LOOP COUNTER SATCAL2A.45
C SATCAL2A.46
INTEGER IC ! LOOP COUNTER SATCAL2A.47
C SATCAL2A.48
INTEGER NPNTS ! VECTOR LENGTH SATCAL2A.49
C SATCAL2A.50
INTEGER K ! IN PRESENT MODEL LAYER SATCAL2A.51
C SATCAL2A.52
C----------------------------------------------------------------------- SATCAL2A.53
C VARIABLES WHICH ARE INPUT SATCAL2A.54
C----------------------------------------------------------------------- SATCAL2A.55
C SATCAL2A.56
REAL TH(NPNTS) ! IN POTENTIAL TEMPERATURE (K) SATCAL2A.57
C SATCAL2A.58
REAL T(NPNTS) ! IN TEMPERATURE (K) SATCAL2A.59
C SATCAL2A.60
REAL PK(NPNTS) ! IN PRESSURE OF LAYER K (PA) SATCAL2A.61
C SATCAL2A.62
REAL Q_K(NPNTS) ! IN MIXING RATIO OF LAYER K (KG/KG) SATCAL2A.63
C SATCAL2A.64
REAL EXK(NPNTS) ! IN EXNER RATIO OF LAYER K SATCAL2A.65
C SATCAL2A.66
REAL THE_K(NPNTS) ! IN ENVIRONMENTAL POTENTIAL TEMPERATURE SATCAL2A.67
! IN LAYER K SATCAL2A.68
C SATCAL2A.69
C----------------------------------------------------------------------- SATCAL2A.70
C VARIABLES WHICH ARE OUTPUT SATCAL2A.71
C----------------------------------------------------------------------- SATCAL2A.72
C SATCAL2A.73
REAL QS(NPNTS) ! OUT SATURATED SPECIFIC HUMIDITY SATCAL2A.74
! (KG/KG) SATCAL2A.75
C SATCAL2A.76
REAL THDDS(NPNTS) ! OUT SATURATED ENVIRONMENTAL SATCAL2A.77
! POTENTIAL TEMPERATURE (K) SATCAL2A.78
C----------------------------------------------------------------------- SATCAL2A.79
C VARIABLES WHICH ARE LOCALLY DEFINED SATCAL2A.80
C----------------------------------------------------------------------- SATCAL2A.81
C SATCAL2A.82
REAL TS(NPNTS) ! SATURATED TEMPERATURE (K) SATCAL2A.92
C SATCAL2A.93
REAL T_FG(NPNTS) ! TEMPERATURE FIRST GUESS (K) SATCAL2A.94
C SATCAL2A.95
REAL TH_FG(NPNTS) ! POTENTIAL TEMPERATURE FIRST GUESS (K) SATCAL2A.96
C SATCAL2A.97
REAL DQBYDT(NPNTS) ! FIRST GUESS AT MIXING RATIO INCREMENT SATCAL2A.98
! (KG/KG/K) SATCAL2A.99
C SATCAL2A.100
REAL L ! LATENT HEAT SATCAL2A.102
C SATCAL2A.103
C SATCAL2A.104
C----------------------------------------------------------------------- SATCAL2A.105
C EXTERNAL ROUTINES CALLED SATCAL2A.106
C----------------------------------------------------------------------- SATCAL2A.107
C SATCAL2A.108
EXTERNAL QSAT, DQS_DTH SATCAL2A.109
C SATCAL2A.110
C----------------------------------------------------------------------- SATCAL2A.111
C SET INITIAL FIRST GUESS TEMPERATURE AND THETA - BASED UPON SATCAL2A.112
C ENVIRONMENTAL TEMPERATURE IN LAYER K SATCAL2A.113
C----------------------------------------------------------------------- SATCAL2A.114
C SATCAL2A.115
DO I=1,NPNTS SATCAL2A.116
TH_FG(I) = THE_K(I) SATCAL2A.117
T_FG(I) = TH_FG(I)*EXK(I) SATCAL2A.118
END DO SATCAL2A.119
C SATCAL2A.120
C---------------------------------------------------------------------- SATCAL2A.121
C CALCULATE QSAT FOR INITIAL FIRST GUESS TEMPERATURE SATCAL2A.122
C---------------------------------------------------------------------- SATCAL2A.123
C SATCAL2A.124
CALL QSAT(QS,T_FG,PK,NPNTS) SATCAL2A.125
C SATCAL2A.126
C---------------------------------------------------------------------- SATCAL2A.127
C DO TWO ITERATIONS TO FIND SATURATION POINT DUE TO EVAPORATION SATCAL2A.128
C---------------------------------------------------------------------- SATCAL2A.129
C SATCAL2A.130
DO IC=1,2 SATCAL2A.131
C SATCAL2A.132
C---------------------------------------------------------------------- SATCAL2A.133
C CALCULATE DQSAT/DT FOR FIRST GUESS TEMPERATURE SATCAL2A.134
C---------------------------------------------------------------------- SATCAL2A.135
C SATCAL2A.136
CALL DQS_DTH(DQBYDT,K,TH_FG,QS,EXK,NPNTS) SATCAL2A.137
C SATCAL2A.138
C---------------------------------------------------------------------- SATCAL2A.139
C CALCULATE UPDATED TEMPERATURE AT SATURATION SATCAL2A.140
C---------------------------------------------------------------------- SATCAL2A.141
C SATCAL2A.142
DO I=1,NPNTS SATCAL2A.143
C SATCAL2A.144
IF (T_FG(I).GT.TM) THEN SATCAL2A.145
L=LC SATCAL2A.146
ELSE SATCAL2A.147
L=LC+LF SATCAL2A.148
END IF SATCAL2A.149
C SATCAL2A.150
THDDS(I) = (TH(I) - (L/(CP*EXK(I)))*(QS(I)-Q_K(I)- SATCAL2A.151
* TH_FG(I)*DQBYDT(I))) / SATCAL2A.152
* (1+(L/(CP*EXK(I)))*DQBYDT(I)) SATCAL2A.153
C SATCAL2A.154
C---------------------------------------------------------------------- SATCAL2A.155
C CALCULATE TEMPERATURE AT SATURATION AND UPDATE FIRST GUESS SATCAL2A.156
C---------------------------------------------------------------------- SATCAL2A.157
C SATCAL2A.158
TH_FG(I) = THDDS(I) SATCAL2A.159
T_FG(I) = TH_FG(I)*EXK(I) SATCAL2A.160
C SATCAL2A.161
END DO SATCAL2A.162
C SATCAL2A.163
C---------------------------------------------------------------------- SATCAL2A.164
C CALCULATE REVISED SATURATION MIXING RATIO AT SATURATION SATCAL2A.165
C--------------------------------------------------------------------- SATCAL2A.166
C SATCAL2A.167
CALL QSAT(QS,T_FG,PK,NPNTS) SATCAL2A.168
C SATCAL2A.169
END DO SATCAL2A.170
C SATCAL2A.171
RETURN SATCAL2A.172
END SATCAL2A.173
C SATCAL2A.174
*ENDIF SATCAL2A.175