*IF DEF,A10_1A,OR,DEF,A10_1B,OR,DEF,A10_1C AAD2F404.243
C ******************************COPYRIGHT****************************** GTS2F400.7759
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7760
C GTS2F400.7761
C Use, duplication or disclosure of this code is subject to the GTS2F400.7762
C restrictions as set forth in the contract. GTS2F400.7763
C GTS2F400.7764
C Meteorological Office GTS2F400.7765
C London Road GTS2F400.7766
C BRACKNELL GTS2F400.7767
C Berkshire UK GTS2F400.7768
C RG12 2SZ GTS2F400.7769
C GTS2F400.7770
C If no contract has been raised with this copy of the code, the use, GTS2F400.7771
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7772
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7773
C Modelling at the above address. GTS2F400.7774
C ******************************COPYRIGHT****************************** GTS2F400.7775
C GTS2F400.7776
CLL SUBROUTINE P_TH_ADJ ------------------------------------------- PTHADJ1A.3
CLL PTHADJ1A.4
CLL PURPOSE: CALCULATES ADDS SURFACE PRESSURE INCREMENTS USING PTHADJ1A.5
CLL EQUATION (27). CALCULATES AND ADDS POTENTIAL TEMPERATURE PTHADJ1A.6
CLL INCREMENTS USING EQUATION (28). PTHADJ1A.7
CLL NOT SUITABLE FOR I.B.M USE. PTHADJ1A.8
CLL VERSION FOR CRAY Y-MP PTHADJ1A.9
CLL PTHADJ1A.10
CLL M.MAWSON <- PROGRAMMER OF SOME OR ALL OF PREVIOUS CODE OR CHANGES PTHADJ1A.11
CLL PTHADJ1A.12
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: PTHADJ1A.13
CLL VERSION DATE PTHADJ1A.14
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.132
CLL portability. Author Tracey Smith. TS150793.133
CLL PTHADJ1A.15
CLL 3.4 07/08/94 Directives inserted to improve parallel AAD2F304.22
CLL efficiency on C90. AAD2F304.23
CLL Authors: A. Dickinson, D. Salmond AAD2F304.24
CLL Reviewer: M. Mawson AAD2F304.25
! 4.1 02/04/96 Added TYPFLDPT arguments to dynamics routines APB0F401.228
! which allows many of the differences between APB0F401.229
! MPP and "normal" code to be at top level APB0F401.230
! P.Burton APB0F401.231
CLL AAD2F304.26
CLL AAD2F304.27
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, PTHADJ1A.16
CLL STANDARD B. VERSION 2, DATED 18/01/90 PTHADJ1A.17
CLL PTHADJ1A.18
CLL SYSTEM COMPONENTS COVERED: P113 PTHADJ1A.19
CLL PTHADJ1A.20
CLL SYSTEM TASK: P1 PTHADJ1A.21
CLL PTHADJ1A.22
CLL DOCUMENTATION: THE EQUATIONS USED ARE (27) AND (28) PTHADJ1A.23
CLL IN UNIFIED MODEL DOCUMENTATION PAPER NO. 10 PTHADJ1A.24
CLL M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON PTHADJ1A.25
CLL VERSION 10 DATED 10/09/90. PTHADJ1A.26
CLLEND------------------------------------------------------------- PTHADJ1A.27
PTHADJ1A.28
C PTHADJ1A.29
C*L ARGUMENTS:--------------------------------------------------- PTHADJ1A.30
PTHADJ1A.31
SUBROUTINE P_TH_ADJ 2PTHADJ1A.32
1 (PSTAR,PSTAR_OLD,THETA,THETA_REF, PTHADJ1A.33
2 ETADOT,RS,DELTA_AK,DELTA_BK, PTHADJ1A.34
3 P_FIELD,P_LEVELS, APB0F401.232
*CALL ARGFLDPT 
APB0F401.233
4 CALL_NUMBER,ADJUSTMENT_TIMESTEP, PTHADJ1A.36
5 ERROR_CODE,ERROR_MESSAGE, PTHADJ1A.37
* RECIP_RS_SQUARED_SURFACE,L_NEG_PSTAR) PTHADJ1A.38
PTHADJ1A.39
IMPLICIT NONE PTHADJ1A.40
LOGICAL PTHADJ1A.41
* L_NEG_PSTAR !IN SWITCH, IF TRUE THEN NEGATIVE PSTAR VALUES PTHADJ1A.42
* ! WILL BE DETECTED AND OUTPUT. PTHADJ1A.43
PTHADJ1A.44
PTHADJ1A.45
INTEGER PTHADJ1A.46
* P_LEVELS !IN NUMBER OF PRESSURE LEVELS OF DATA PTHADJ1A.47
*, P_FIELD !IN NUMBER OF POINTS IN PRESSURE FIELD. PTHADJ1A.48
*, CALL_NUMBER !IN ADJUSTMENT STEP NUMBER ON WHICH CALL PTHADJ1A.51
* ! TO ROUTINE IS BEING MADE. PTHADJ1A.52
! All TYPFLDPT arguments are intent IN APB0F401.234
*CALL TYPFLDPT APB0F401.235
PTHADJ1A.53
INTEGER PTHADJ1A.54
* ERROR_CODE !INOUT. 0 ON ENTRY. 1 ON EXIT IF NEGATIVE PTHADJ1A.55
* ! PRESSURE DETECTED. PTHADJ1A.56
PTHADJ1A.57
CHARACTER*(80) TS150793.134
* ERROR_MESSAGE !OUT. HOLDS ERROR MESSAGE IF ERROR_CODE TS150793.135
* ! NON-ZERO. TS150793.136
PTHADJ1A.61
REAL PTHADJ1A.62
* ETADOT(P_FIELD,P_LEVELS) !IN. HOLDS MASS-WEIGHTED VERTICAL PTHADJ1A.63
* ! VELOCITY. AT LEVEL ONE HOLDS SUM PTHADJ1A.64
* ! OF DIVERGENCES IN THE COLUMN. PTHADJ1A.65
*,RS(P_FIELD,P_LEVELS) !IN. RADIUS OF EARTH AT EACH LEVEL. PTHADJ1A.66
*,DELTA_AK(P_LEVELS) !IN. DIFFERENCE BETWEEN AK'S AT HALF PTHADJ1A.67
* ! LEVELS. PTHADJ1A.68
*,DELTA_BK(P_LEVELS) !IN. DIFFERENCE BETWEEN BK'S AT HALF PTHADJ1A.69
* ! LEVELS. PTHADJ1A.70
*,THETA_REF(P_LEVELS) !IN. REFERENCE THETA PROFILE. PTHADJ1A.71
*,ADJUSTMENT_TIMESTEP !IN. PTHADJ1A.72
*,RECIP_RS_SQUARED_SURFACE(P_FIELD) !IN. 1/(RS*RS) AT MODEL PTHADJ1A.73
* ! SURFACE. PTHADJ1A.74
PTHADJ1A.75
REAL PTHADJ1A.76
* PSTAR(P_FIELD) !INOUT. PRIMARY ARRAY FOR PSTAR PTHADJ1A.77
*,THETA(P_FIELD,P_LEVELS) !INOUT. PRIMARY ARRAY FOR THETA. PTHADJ1A.78
PTHADJ1A.79
REAL PTHADJ1A.80
* PSTAR_OLD(P_FIELD) !OUT. PSTAR AT OLD TIME-LEVEL. PTHADJ1A.81
PTHADJ1A.82
C*--------------------------------------------------------------------- PTHADJ1A.83
PTHADJ1A.84
C*L NO LOCAL ARRAYS NEEDED ------------------------------------------ PTHADJ1A.85
C*--------------------------------------------------------------------- PTHADJ1A.86
PTHADJ1A.87
C DEFINE COUNT VARIABLES FOR DO LOOPS ETC. PTHADJ1A.88
INTEGER PTHADJ1A.89
* I,K PTHADJ1A.90
*IF DEF,MPP APB0F401.236
&, info ! return code from GCOM APB0F401.237
*ENDIF APB0F401.238
PTHADJ1A.91
C*L NO EXTERNAL SUBROUTINE CALLS:--------------------------------- PTHADJ1A.92
C*--------------------------------------------------------------------- PTHADJ1A.93
PTHADJ1A.94
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD PTHADJ1A.95
CL--------------------------------------------------------------------- PTHADJ1A.96
CL INTERNAL STRUCTURE. PTHADJ1A.97
CL--------------------------------------------------------------------- PTHADJ1A.98
CL PTHADJ1A.99
CL--------------------------------------------------------------------- PTHADJ1A.100
CL SECTION 1. IF CALL NUMBER one STORE VALUE OF PSTAR AT OLD PTHADJ1A.101
cl TIME-LEVEL. PTHADJ1A.102
CL--------------------------------------------------------------------- PTHADJ1A.103
PTHADJ1A.104
IF (CALL_NUMBER.EQ.1) THEN PTHADJ1A.105
C STORE PSTAR AT OLD TIME-LEVEL. PTHADJ1A.106
! loop over all points, including valid halos APB0F401.239
DO 100 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.240
PSTAR_OLD(I) = PSTAR(I) PTHADJ1A.108
100 CONTINUE PTHADJ1A.109
END IF PTHADJ1A.110
PTHADJ1A.111
PTHADJ1A.112
CL PTHADJ1A.113
CL--------------------------------------------------------------------- PTHADJ1A.114
CL SECTION 2. ADJUST THETA USING EQUATION (28). PTHADJ1A.115
CL THETA ADJUSTMENT IS DONE BEFORE PSTAR AS THETA PTHADJ1A.116
CL ADJUSTMENT REQUIRES PSTAR AT LAST TIME-LEVEL. PTHADJ1A.117
CL--------------------------------------------------------------------- PTHADJ1A.118
PTHADJ1A.119
C LOOP OVER ALL LEVELS PTHADJ1A.120
cmic$ do all shared (adjustment_timestep, delta_ak, delta_bk) APB0F401.241
cmic$* shared (etadot, p_field, p_levels, pstar_old, rs) APB0F401.242
*CALL CMICFLD APB0F401.243
cmic$* shared (theta, theta_ref) AAD2F304.30
cmic$* private (i, k) AAD2F304.31
DO 200 K=1,P_LEVELS PTHADJ1A.121
PTHADJ1A.122
*IF DEF,GLOBAL PTHADJ1A.123
C LOOP OVER ALL POINTS AS VALUES OF DIVERGENCE AND VERTICAL VELOCITY PTHADJ1A.124
C AT THE POLES WERE CALCULATED IN VERT_VEL. PTHADJ1A.125
C AS ETADOT AT LEVEL 1 AND LEVEL P_LEVELS+1 ARE ZERO AND ALSO ARE PTHADJ1A.126
C NOT STORED, SLIGHTLY DIFFERENT CODE IS REQUIRED AT THESE LEVELS. PTHADJ1A.127
PTHADJ1A.128
IF(K.EQ.1) THEN PTHADJ1A.129
PTHADJ1A.130
C ADJUST ALL THETA VALUES. PTHADJ1A.131
PTHADJ1A.132
CFPP$ SELECT(CONCUR) PTHADJ1A.133
! loop over all points, including valid halos APB0F401.244
DO 210 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.245
THETA(I,K) = THETA(I,K) - ADJUSTMENT_TIMESTEP * .5 * PTHADJ1A.135
* (ETADOT(I,K+1)*(THETA_REF(K+1)- PTHADJ1A.136
* THETA_REF(K)))/ PTHADJ1A.137
* (RS(I,K)*RS(I,K)*(DELTA_AK(K)+ PTHADJ1A.138
* DELTA_BK(K)*PSTAR_OLD(I))) PTHADJ1A.139
210 CONTINUE PTHADJ1A.140
PTHADJ1A.141
ELSE IF (K.EQ.P_LEVELS) THEN PTHADJ1A.142
PTHADJ1A.143
C ADJUST ALL THETA VALUES. PTHADJ1A.144
PTHADJ1A.145
CFPP$ SELECT(CONCUR) PTHADJ1A.146
! loop over all points, including valid halos APB0F401.246
DO 220 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.247
THETA(I,K) = THETA(I,K) - ADJUSTMENT_TIMESTEP * .5 * PTHADJ1A.148
* (ETADOT(I,K)* PTHADJ1A.149
* (THETA_REF(K)-THETA_REF(K-1)))/ PTHADJ1A.150
* (RS(I,K)*RS(I,K)*(DELTA_AK(K)+ PTHADJ1A.151
* DELTA_BK(K)*PSTAR_OLD(I))) PTHADJ1A.152
220 CONTINUE PTHADJ1A.153
PTHADJ1A.154
ELSE PTHADJ1A.155
PTHADJ1A.156
C ADJUST ALL THETA VALUES. PTHADJ1A.157
PTHADJ1A.158
CFPP$ SELECT(CONCUR) PTHADJ1A.159
! loop over all points, including valid halos APB0F401.248
DO 230 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.249
THETA(I,K) = THETA(I,K) - ADJUSTMENT_TIMESTEP * .5 * PTHADJ1A.161
* (ETADOT(I,K+1)*(THETA_REF(K+1)- PTHADJ1A.162
* THETA_REF(K)) + ETADOT(I,K)* PTHADJ1A.163
* (THETA_REF(K)-THETA_REF(K-1)))/ PTHADJ1A.164
* (RS(I,K)*RS(I,K)*(DELTA_AK(K)+ PTHADJ1A.165
* DELTA_BK(K)*PSTAR_OLD(I))) PTHADJ1A.166
230 CONTINUE PTHADJ1A.167
PTHADJ1A.168
END IF PTHADJ1A.169
PTHADJ1A.170
*ELSE PTHADJ1A.171
C FOR LIMITED AREA MODEL ADJUST ALL VALUES NOT ON POLEWARDS BOUNDARIES. PTHADJ1A.172
C AS ETADOT AT LEVEL 1 AND LEVEL P_LEVELS+1 ARE ZERO AND ALSO ARE PTHADJ1A.173
C NOT STORED SLIGHTLY DIFFERENT CODE IS REQUIRED. PTHADJ1A.174
PTHADJ1A.175
IF(K.EQ.1) THEN PTHADJ1A.176
PTHADJ1A.177
C ADJUST ALL THETA VALUES. PTHADJ1A.178
PTHADJ1A.179
CFPP$ SELECT(CONCUR) PTHADJ1A.180
! loop over all points, missing poleward bounds but including halos APB0F401.250
DO 210 I=START_POINT_INC_HALO,END_P_POINT_INC_HALO APB0F401.251
THETA(I,K) = THETA(I,K) - ADJUSTMENT_TIMESTEP * .5 * PTHADJ1A.182
* (ETADOT(I,K+1)*(THETA_REF(K+1)- PTHADJ1A.183
* THETA_REF(K)))/ PTHADJ1A.184
* (RS(I,K)*RS(I,K)*(DELTA_AK(K)+ PTHADJ1A.185
* DELTA_BK(K)*PSTAR_OLD(I))) PTHADJ1A.186
210 CONTINUE PTHADJ1A.187
PTHADJ1A.188
ELSE IF (K.EQ.P_LEVELS) THEN PTHADJ1A.189
PTHADJ1A.190
C ADJUST ALL THETA VALUES. PTHADJ1A.191
PTHADJ1A.192
CFPP$ SELECT(CONCUR) PTHADJ1A.193
! loop over all points, missing poleward bounds but including halos APB0F401.252
DO 220 I=START_POINT_INC_HALO,END_P_POINT_INC_HALO APB0F401.253
THETA(I,K) = THETA(I,K) - ADJUSTMENT_TIMESTEP * .5 * PTHADJ1A.195
* (ETADOT(I,K)* PTHADJ1A.196
* (THETA_REF(K)-THETA_REF(K-1)))/ PTHADJ1A.197
* (RS(I,K)*RS(I,K)*(DELTA_AK(K)+ PTHADJ1A.198
* DELTA_BK(K)*PSTAR_OLD(I))) PTHADJ1A.199
220 CONTINUE PTHADJ1A.200
PTHADJ1A.201
ELSE PTHADJ1A.202
PTHADJ1A.203
C ADJUST ALL THETA VALUES. PTHADJ1A.204
PTHADJ1A.205
CFPP$ SELECT(CONCUR) PTHADJ1A.206
! loop over all points, missing poleward bounds but including halos APB0F401.254
DO 230 I=START_POINT_INC_HALO,END_P_POINT_INC_HALO APB0F401.255
THETA(I,K) = THETA(I,K) - ADJUSTMENT_TIMESTEP * .5 * PTHADJ1A.208
* (ETADOT(I,K+1)*(THETA_REF(K+1)- PTHADJ1A.209
* THETA_REF(K)) + ETADOT(I,K)* PTHADJ1A.210
* (THETA_REF(K)-THETA_REF(K-1)))/ PTHADJ1A.211
* (RS(I,K)*RS(I,K)*(DELTA_AK(K)+ PTHADJ1A.212
* DELTA_BK(K)*PSTAR_OLD(I))) PTHADJ1A.213
230 CONTINUE PTHADJ1A.214
PTHADJ1A.215
END IF PTHADJ1A.216
PTHADJ1A.217
*ENDIF PTHADJ1A.218
PTHADJ1A.219
C END LOOP OVER LEVELS PTHADJ1A.220
200 CONTINUE PTHADJ1A.221
PTHADJ1A.222
CL PTHADJ1A.223
CL--------------------------------------------------------------------- PTHADJ1A.224
CL SECTION 3. ADJUST PSTAR USING EQUATION (27). PTHADJ1A.225
CL--------------------------------------------------------------------- PTHADJ1A.226
PTHADJ1A.227
*IF -DEF,STRAT PTHADJ1A.228
*IF DEF,GLOBAL PTHADJ1A.229
C LOOP OVER ALL POINTS AS POLAR VALUES OF DIVERGENCE AND VERTICAL PTHADJ1A.230
C VELOCITY WERE CALCULATED IN VERT_VEL. PTHADJ1A.231
C ADJUST ALL PRESSURE VALUES. PTHADJ1A.232
PTHADJ1A.233
! loop over all points, including valid halos APB0F401.256
DO 300 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.257
PSTAR(I) = PSTAR(I) + ADJUSTMENT_TIMESTEP * ETADOT(I,1) PTHADJ1A.235
* *RECIP_RS_SQUARED_SURFACE(I) PTHADJ1A.236
300 CONTINUE PTHADJ1A.237
PTHADJ1A.238
*ELSE PTHADJ1A.239
PTHADJ1A.240
C IF LIMITED AREA MODEL ADJUST ALL PRESSURE VALUES NOT ON POLEWARDS PTHADJ1A.241
C BOUNDARIES. PTHADJ1A.242
PTHADJ1A.243
! loop over all points, missing poleward bounds but including halos APB0F401.258
DO 300 I=START_POINT_INC_HALO,END_P_POINT_INC_HALO APB0F401.259
PSTAR(I) = PSTAR(I) + ADJUSTMENT_TIMESTEP * ETADOT(I,1) PTHADJ1A.245
* *RECIP_RS_SQUARED_SURFACE(I) PTHADJ1A.246
300 CONTINUE PTHADJ1A.247
PTHADJ1A.248
*ENDIF PTHADJ1A.249
*ENDIF PTHADJ1A.250
PTHADJ1A.251
IF(L_NEG_PSTAR) THEN PTHADJ1A.252
PTHADJ1A.253
CL TEST FOR NEGATIVE PRESSURE VALUES. PTHADJ1A.254
PTHADJ1A.255
! loop over all points, including valid halos APB0F401.260
DO 310 I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.261
IF(PSTAR(I).LT.0.) THEN PTHADJ1A.257
ERROR_CODE = 1 PTHADJ1A.258
WRITE(6,*)' NEGATIVE PRESSURE AT POINT ',I GIE0F403.564
*IF DEF,MPP APB0F401.262
WRITE(6,*)' ON PROCESSOR ',MY_PROC_ID GIE0F403.565
*ENDIF APB0F401.264
END IF PTHADJ1A.260
310 CONTINUE PTHADJ1A.261
*IF DEF,MPP APB0F401.265
CALL GC_IMAX(1,N_PROCS,info,ERROR_CODE) APB0F401.266
*ENDIF APB0F401.267
PTHADJ1A.262
IF(ERROR_CODE.EQ.1) PTHADJ1A.263
* ERROR_MESSAGE='P_TH_ADJ : NEGATIVE PRESSURE VALUE CREATED.' PTHADJ1A.264
PTHADJ1A.265
ENDIF PTHADJ1A.266
CL END OF ROUTINE P_TH_ADJ PTHADJ1A.267
PTHADJ1A.268
RETURN PTHADJ1A.269
END PTHADJ1A.270
*ENDIF PTHADJ1A.271