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