SUBROUTINE DIAG10_B( 1,12DIA10B1A.26
& U_ADJ,V_ADJ,QT,THETAL,P_EXNER,PSTAR,U,V, DIA10B1A.27
& SEC_U_LATITUDE,AKH,BKH, DIA10B1A.28
& ROW_LENGTH,P_LEVELS,Q_LEVELS,P_FIELD, DIA10B1A.29
& U_FIELD,FIRST_POINT,LAST_POINT, DIA10B1A.30
& NSECTS,NITEMS,TOTITEMS,NUM_STASH_LEVELS, DIA10B1A.31
& NUM_LEVEL_LISTS,LEN_STLIST,STASHLEN,SF, DIA10B1A.32
& STINDEX,STLIST,SI,STASH_LEVELS,STASHWORK, DIA10B1A.33
& FIELD, GPB1F403.1045
& im_ident, GPB1F403.1046
*CALL ARGFLDPT 
GPB1F403.1047
*CALL ARGPPX GPB1F403.1048
& ICODE,CMESSAGE) GPB1F403.1049
DIA10B1A.35
IMPLICIT NONE DIA10B1A.36
DIA10B1A.37
INTEGER DIA10B1A.38
& P_FIELD !IN 1ST DIMENSION OF FIELD OF PSTAR DIA10B1A.39
&, U_FIELD !IN 1ST DIMENSION OF FIELD OF U,V DIA10B1A.40
&, ROW_LENGTH !IN NUMBER OF POINTS PER ROW DIA10B1A.41
&, P_LEVELS !IN NUMBER OF PRESSURE LEVELS DIA10B1A.42
&, Q_LEVELS !IN NUMBER OF WET LEVELS DIA10B1A.43
&, FIRST_POINT !IN FIRST POINT OUTPUT REQUIRED FOR. DIA10B1A.44
&, LAST_POINT !IN LAST POINT OUTPUT REQUIRED FOR. DIA10B1A.45
DIA10B1A.46
INTEGER GPB1F403.1050
& im_ident !IN : Internal model indent GPB1F403.1051
GPB1F403.1052
*CALL TYPFLDPT GPB1F403.1053
*CALL CSUBMODL GPB1F403.1054
*CALL CPPXREF GPB1F403.1055
*CALL PPXLOOK GPB1F403.1056
INTEGER DIA10B1A.47
& ICODE !OUT RETURN CODE. NON-ZERO IF ERROR-DETECTED DIA10B1A.48
DIA10B1A.49
CHARACTER DIA10B1A.50
& CMESSAGE*(*) !OUT ERROR MESSAGE DIA10B1A.51
DIA10B1A.52
C INPUT DATA DIA10B1A.53
DIA10B1A.54
REAL DIA10B1A.55
& P_EXNER(P_FIELD,P_LEVELS+1) !IN EXNER PRESS ON 1/2 LVLS DIA10B1A.56
&, THETAL(P_FIELD,P_LEVELS)!IN PRIMARY MODEL ARRAY FOR THETAL FIELD DIA10B1A.57
&, PSTAR(P_FIELD) !IN PRIMARY MODEL ARRAY FOR PSTAR DIA10B1A.58
&, U(U_FIELD,P_LEVELS) !IN PRIMARY MODEL ARRAY FOR U FIELD DIA10B1A.59
&, V(U_FIELD,P_LEVELS) !IN PRIMARY MODEL ARRAY FOR V FIELD DIA10B1A.60
&, U_ADJ(U_FIELD,P_LEVELS) !IN MEAN U OVER ADJUSTENT STEPS DIA10B1A.61
&, V_ADJ(U_FIELD,P_LEVELS) !IN MEAN V OVER ADJUSTENT STEPS. DIA10B1A.62
&, QT(P_FIELD,Q_LEVELS) !IN PRIMARY MODEL ARRAY FOR TOTAL WATER DIA10B1A.63
&, SEC_U_LATITUDE(U_FIELD) !IN 1./(COS(LAT)) AT U POINTS. DIA10B1A.64
&, AKH(P_LEVELS+1) !IN Hybrid Coords. A and B values DIA10B1A.65
&, BKH(P_LEVELS+1) !IN at half levels. DIA10B1A.66
DIA10B1A.67
REAL DIA10B1A.68
& FIELD(P_FIELD*P_LEVELS) ! WORK-SPACE FOR OUTPUT FIELD DIA10B1A.69
DIA10B1A.70
C STASH REQUIREMENTS. DIA10B1A.71
DIA10B1A.72
INTEGER DIA10B1A.73
& NSECTS !IN NO OF PROCESSING SECTIONS (MASTER PCRS) DIA10B1A.74
&, NITEMS !IN MAX NO OF STASH ITEMS IN A SECTION DIA10B1A.75
&, TOTITEMS !IN MAX NO OF TOTAL STASH ITEMS DIA10B1A.76
&, NUM_STASH_LEVELS !IN MAX NUMBER OF LEVELS IN A LEVELS LIST DIA10B1A.77
&, NUM_LEVEL_LISTS !IN MAX NUMBER OF LEVELS LIST DIA10B1A.78
&, LEN_STLIST !IN LENGTH OF LIST OF ITEMS FROM STASH DIA10B1A.79
&, STASHLEN !IN SIZE OF STASHWORK DIA10B1A.80
DIA10B1A.81
INTEGER DIA10B1A.82
& STINDEX(2,NITEMS,0:NSECTS) !IN DIA10B1A.83
&, STLIST(LEN_STLIST,TOTITEMS) !IN DIA10B1A.84
&, SI(NITEMS,0:NSECTS) !IN DIA10B1A.85
&, STASH_LEVELS(NUM_STASH_LEVELS+1,NUM_LEVEL_LISTS) !IN DIA10B1A.86
DIA10B1A.87
LOGICAL DIA10B1A.88
& SF(0:NITEMS,0:NSECTS) !IN @DYALLOC.843
DIA10B1A.90
REAL DIA10B1A.91
& STASHWORK(STASHLEN) !INOUT. WORK SPACE HOLDING STASH OUTPUT. DIA10B1A.92
DIA10B1A.93
C*-------------------------------------------------------------------- DIA10B1A.94
DIA10B1A.95
C*L DEFINE LOCAL ARRAYS AND VARIABLES USED IN THIS ROUTINE---------- DIA10B1A.96
C DEFINE LOCAL ARRAYS: 1 is REQUIRED. DIA10B1A.97
REAL DIA10B1A.98
& VELOCITY(P_FIELD*P_LEVELS) ! WORK-SPACE FOR INTERPOLATED WIND DIA10B1A.99
& ! FIELD. DIA10B1A.100
DIA10B1A.101
C*-------------------------------------------------------------------- DIA10B1A.102
DIA10B1A.103
C DEFINE LOCAL VARIABLES DIA10B1A.104
REAL DIA10B1A.105
& EARTH_RADIUS_INVERSE DIA10B1A.106
&, RECIP_G DIA10B1A.107
&, PKP1,PK ! Pressure at half levels k+1 and k DIA10B1A.108
&, P_EXNER_FULL ! Exner pressure at full model level DIA10B1A.109
&, TEMPL_I,TEMPL_IP1 ! Temperatures at points/rows i and i+1 DIA10B1A.110
&, FACTOR ! Field normalised by this factor ARS1F304.35
DIA10B1A.111
INTEGER DIA10B1A.112
& I,K,K1,LEVEL DIA10B1A.113
& ,FIRST_U,FIRST_P ! first point for copydiag u and p grids ARS1F304.36
& ,LAST_U,LAST_P ! Last point for copydiag u and p grids ARS1F304.37
DIA10B1A.114
*CALL C_DG10_1 DIA10B1A.115
DIA10B1A.116
C Get UM constants. DIA10B1A.117
*CALL C_A DIA10B1A.118
*CALL C_G DIA10B1A.119
*CALL C_R_CP DIA10B1A.120
*CALL C_LHEAT DIA10B1A.121
DIA10B1A.122
C*L EXTERNAL SUBROUTINES CALLED ------------------------------------ DIA10B1A.123
EXTERNAL COPYDIAG_3D DIA10B1A.124
C*-------------------------------------------------------------------- DIA10B1A.125
DIA10B1A.126
C P_EXNERC contains statement function P_EXNER_C DIA10B1A.127
*CALL P_EXNERC DIA10B1A.128
DIA10B1A.129
C Comdeck C_DG10_2 initilaises local variables defined in C_DG10_1 DIA10B1A.130
*CALL C_DG10_2 DIA10B1A.131
DIA10B1A.132
CL-------------------------------------------------------------------- DIA10B1A.133
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD DIA10B1A.134
CL-------------------------------------------------------------------- DIA10B1A.135
FIRST_U=FIRST_FLD_PT GPB1F403.1057
FIRST_P=FIRST_FLD_PT GPB1F403.1058
LAST_U = LAST_U_FLD_PT GPB1F403.1059
LAST_P = LAST_P_FLD_PT GPB1F403.1060
DIA10B1A.136
CL ------------------------------------------------------------------- DIA10B1A.137
CL SECTION 1. DIAGNOSTICS INVOLVING MEAN U OVER ADJUSTMENT STEP. DIA10B1A.138
CL ------------------------------------------------------------------- DIA10B1A.139
DIA10B1A.140
EARTH_RADIUS_INVERSE = 1./A DIA10B1A.141
RECIP_G = 1./G DIA10B1A.142
FACTOR=1.0e-6 ARS1F304.42
DIA10B1A.143
C -------------------------------------------------------------------- DIA10B1A.144
CL SECTION 1.1 ITEM 215 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10B1A.145
CL * U DIA10B1A.146
C -------------------------------------------------------------------- DIA10B1A.147
DIA10B1A.148
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10B1A.149
IF (L_UADJ_U_DP) THEN DIA10B1A.150
DO 110 K=1,P_LEVELS DIA10B1A.151
K1 = (K-1)*U_FIELD DIA10B1A.152
DO I=FIRST_U,LAST_U GPB1F403.1061
FIELD(K1+I) = -U(I,K)*U_ADJ(I,K)*EARTH_RADIUS_INVERSE*FACTOR ARS1F402.12
END DO DIA10B1A.155
110 CONTINUE DIA10B1A.156
DIA10B1A.157
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_U_DP),FIELD,FIRST_U, ARS1F304.43
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.44
& STLIST(1,INDEX_UADJ_U_DP),LEN_STLIST, DIA10B1A.160
& STASH_LEVELS, DIA10B1A.161
& NUM_STASH_LEVELS+1, GPB1F403.1062
& im_ident,10,215, GPB1F403.1063
*CALL ARGPPX GPB1F403.1064
& ICODE,CMESSAGE) GPB1F403.1065
IF(ICODE.GT.0) THEN DIA10B1A.163
RETURN DIA10B1A.164
END IF DIA10B1A.165
END IF DIA10B1A.166
DIA10B1A.167
C -------------------------------------------------------------------- DIA10B1A.168
CL SECTION 1.2 ITEM 217 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10B1A.169
CL * V DIA10B1A.170
C -------------------------------------------------------------------- DIA10B1A.171
DIA10B1A.172
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10B1A.173
IF (L_UADJ_V_DP) THEN DIA10B1A.174
DO 120 K=1,P_LEVELS DIA10B1A.175
K1 = (K-1)*U_FIELD DIA10B1A.176
DO I=FIRST_U,LAST_U GPB1F403.1066
FIELD(K1+I) = -V(I,K)*U_ADJ(I,K)*EARTH_RADIUS_INVERSE*FACTOR ARS1F402.13
END DO DIA10B1A.179
120 CONTINUE DIA10B1A.180
DIA10B1A.181
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_V_DP),FIELD,FIRST_U, ARS1F304.45
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.46
& STLIST(1,INDEX_UADJ_V_DP),LEN_STLIST, DIA10B1A.184
& STASH_LEVELS, DIA10B1A.185
& NUM_STASH_LEVELS+1, GPB1F403.1067
& im_ident,10,217, GPB1F403.1068
*CALL ARGPPX GPB1F403.1069
& ICODE,CMESSAGE) GPB1F403.1070
IF(ICODE.GT.0) THEN DIA10B1A.187
RETURN DIA10B1A.188
END IF DIA10B1A.189
END IF DIA10B1A.190
DIA10B1A.191
C CHECK TO SEE IF ANY U DIAGNOSTICS REQUESTED WHICH NEED U_ADJ TO DIA10B1A.192
C BE INTERPOLATED. DIA10B1A.193
DIA10B1A.194
IF(L_UADJ_TL_DP.OR.L_UADJ_QT_DP.OR. DIA10B1A.195
& L_UADJ_GEOPOT_DP.OR.L_UADJ_ENERGY_DP) THEN DIA10B1A.196
DIA10B1A.197
C -------------------------------------------------------------------- DIA10B1A.198
CL SECTION 1.3 REMOVE RADIUS OF EARTH FROM U FIELD AND DIA10B1A.199
CL INTERPOLATE TO C-GRID U POINTS. DIA10B1A.200
C -------------------------------------------------------------------- DIA10B1A.201
DIA10B1A.202
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10B1A.203
DO 130 K=1,P_LEVELS DIA10B1A.204
K1 = (K-1)*P_FIELD DIA10B1A.205
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO GPB1F403.1071
VELOCITY(K1+I) = -.5*(U_ADJ(I,K) + U_ADJ(I-ROW_LENGTH,K)) DIA10B1A.207
& *EARTH_RADIUS_INVERSE DIA10B1A.208
END DO DIA10B1A.209
C SET POLAR VALUES EQUAL TO VALUE ON ADJACENT ROW. DIA10B1A.210
DIA10B1A.211
*IF DEF,MPP GPB1F403.1072
IF (at_top_of_LPG) THEN GPB1F403.1073
*ENDIF GPB1F403.1074
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 GPB1F403.1075
VELOCITY(K1+I) = -U_ADJ(I,K)*EARTH_RADIUS_INVERSE GPB1F403.1076
ENDDO GPB1F403.1077
*IF DEF,MPP GPB1F403.1078
ENDIF GPB1F403.1079
GPB1F403.1080
IF (at_base_of_LPG) THEN GPB1F403.1081
*ENDIF GPB1F403.1082
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 GPB1F403.1083
VELOCITY(K1+I) = -U_ADJ(I-ROW_LENGTH,K)* GPB1F403.1084
& EARTH_RADIUS_INVERSE GPB1F403.1085
ENDDO GPB1F403.1086
*IF DEF,MPP GPB1F403.1087
ENDIF GPB1F403.1088
*ENDIF GPB1F403.1089
130 CONTINUE DIA10B1A.217
DIA10B1A.218
C -------------------------------------------------------------------- DIA10B1A.219
CL SECTION 1.4 ITEM 211 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10B1A.220
CL * LIQUID WATER TEMPERATURE. DIA10B1A.221
C -------------------------------------------------------------------- DIA10B1A.222
DIA10B1A.223
IF (L_UADJ_TL_DP) THEN DIA10B1A.224
DO 140 K=1,P_LEVELS DIA10B1A.225
K1 = (K-1)*P_FIELD DIA10B1A.226
DO I=FIRST_P,LAST_P-1 GPB1F403.1090
DIA10B1A.228
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.229
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.230
P_EXNER_FULL = P_EXNER_C DIA10B1A.231
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.232
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.47
DIA10B1A.234
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1) DIA10B1A.235
PK = AKH(K) + BKH(K) *PSTAR(I+1) DIA10B1A.236
P_EXNER_FULL = P_EXNER_C DIA10B1A.237
& (P_EXNER(I+1,K+1),P_EXNER(I+1,K),PKP1,PK,KAPPA) DIA10B1A.238
TEMPL_IP1 = THETAL(I+1,K) * P_EXNER_FULL ARS1F304.48
DIA10B1A.240
FIELD(K1+I) = VELOCITY(K1+I) * 0.5 * (TEMPL_I + TEMPL_IP1) DIA10B1A.241
& *FACTOR ARS1F402.14
DIA10B1A.242
END DO DIA10B1A.243
*IF -DEF,MPP GPB1F403.1091
C RE-CALCULATE END POINTS DIA10B1A.244
DO I=FIRST_P+LAST_ROW_PT-1,LAST_P,ROW_LENGTH GPB1F403.1092
DIA10B1A.246
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.247
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.248
P_EXNER_FULL = P_EXNER_C DIA10B1A.249
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.250
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.49
DIA10B1A.252
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1-ROW_LENGTH) DIA10B1A.253
PK = AKH(K) + BKH(K) *PSTAR(I+1-ROW_LENGTH) DIA10B1A.254
P_EXNER_FULL = P_EXNER_C DIA10B1A.255
& (P_EXNER(I+1-ROW_LENGTH,K+1),P_EXNER(I+1-ROW_LENGTH,K), DIA10B1A.256
& PKP1,PK,KAPPA) DIA10B1A.257
TEMPL_IP1 = THETAL(I+1-ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.50
DIA10B1A.259
FIELD(K1+I) = VELOCITY(K1+I) * 0.5 * (TEMPL_I + TEMPL_IP1) DIA10B1A.260
& *FACTOR ARS1F402.15
DIA10B1A.261
END DO DIA10B1A.262
*ELSE GPB1F403.1093
! Set last point of field (halo) to a valid number GPB1F403.1094
FIELD(K1+LAST_P)=FIELD(K1+LAST_P-1) GPB1F403.1095
*ENDIF GPB1F403.1096
140 CONTINUE DIA10B1A.263
DIA10B1A.264
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_TL_DP),FIELD,FIRST_P, ARS1F304.51
& LAST_P,P_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.52
& STLIST(1,INDEX_UADJ_TL_DP),LEN_STLIST, DIA10B1A.267
& STASH_LEVELS, DIA10B1A.268
& NUM_STASH_LEVELS+1, GPB1F403.1097
& im_ident,10,211, GPB1F403.1098
*CALL ARGPPX GPB1F403.1099
& ICODE,CMESSAGE) GPB1F403.1100
IF(ICODE.GT.0) THEN DIA10B1A.270
RETURN DIA10B1A.271
END IF DIA10B1A.272
END IF DIA10B1A.273
DIA10B1A.274
C -------------------------------------------------------------------- DIA10B1A.275
CL SECTION 1.5 ITEM 213 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10B1A.276
CL * TOTAL WATER. DIA10B1A.277
C -------------------------------------------------------------------- DIA10B1A.278
DIA10B1A.279
IF (L_UADJ_QT_DP) THEN DIA10B1A.280
DO 150 K=1,Q_LEVELS DIA10B1A.281
K1 = (K-1)*P_FIELD DIA10B1A.282
DO I=FIRST_P,LAST_P-1 GPB1F403.1101
FIELD(K1+I) = VELOCITY(K1+I)*.5*(QT(I,K)+QT(I+1,K)) DIA10B1A.284
END DO DIA10B1A.285
*IF -DEF,MPP GPB1F403.1102
C RE-CALCULATE END POINTS DIA10B1A.286
DO I=FIRST_P+LAST_ROW_PT-1,LAST_P,ROW_LENGTH GPB1F403.1103
FIELD(K1+I) = VELOCITY(K1+I)*.5* DIA10B1A.288
& (QT(I,K)+QT(I+1-ROW_LENGTH,K)) DIA10B1A.289
END DO DIA10B1A.290
*ELSE GPB1F403.1104
! Set last point of field (halo) to a valid number GPB1F403.1105
FIELD(K1+LAST_P)=FIELD(K1+LAST_P-1) GPB1F403.1106
*ENDIF GPB1F403.1107
150 CONTINUE DIA10B1A.291
DIA10B1A.292
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_QT_DP),FIELD,FIRST_P, ARS1F304.53
& LAST_P,P_FIELD,ROW_LENGTH,Q_LEVELS, ARS1F304.54
& STLIST(1,INDEX_UADJ_QT_DP),LEN_STLIST, DIA10B1A.295
& STASH_LEVELS, DIA10B1A.296
& NUM_STASH_LEVELS+1, GPB1F403.1108
& im_ident,10,213, GPB1F403.1109
*CALL ARGPPX GPB1F403.1110
& ICODE,CMESSAGE) GPB1F403.1111
IF(ICODE.GT.0) THEN DIA10B1A.298
RETURN DIA10B1A.299
END IF DIA10B1A.300
END IF DIA10B1A.301
DIA10B1A.302
C -------------------------------------------------------------------- DIA10B1A.303
CL SECTION 1.6 ITEM 219 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10B1A.304
CL * GEOPOTENTIAL DIA10B1A.305
C -------------------------------------------------------------------- DIA10B1A.306
DIA10B1A.307
IF (L_UADJ_GEOPOT_DP) THEN DIA10B1A.308
DO 160 K=1,P_LEVELS DIA10B1A.309
K1 = (K-1)*P_FIELD DIA10B1A.310
DO I=FIRST_P,LAST_P-1 GPB1F403.1112
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.55
& (STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1)+ DIA10B1A.313
& STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I)) DIA10B1A.314
END DO DIA10B1A.315
*IF -DEF,MPP GPB1F403.1113
C RE-CALCULATE END POINTS DIA10B1A.316
DO I=FIRST_P+LAST_ROW_PT-1,LAST_P,ROW_LENGTH GPB1F403.1114
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.56
& (STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1)+ DIA10B1A.319
& STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-ROW_LENGTH)) DIA10B1A.320
END DO DIA10B1A.321
*ELSE GPB1F403.1115
! Set last point of field (halo) to a valid number GPB1F403.1116
FIELD(K1+LAST_P)=FIELD(K1+LAST_P-1) GPB1F403.1117
*ENDIF GPB1F403.1118
160 CONTINUE DIA10B1A.322
DIA10B1A.323
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_GEOPOT_DP),FIELD, DIA10B1A.324
& FIRST_P, ARS1F304.57
& LAST_P,P_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.58
& STLIST(1,INDEX_UADJ_GEOPOT_DP),LEN_STLIST, DIA10B1A.327
& STASH_LEVELS, DIA10B1A.328
& NUM_STASH_LEVELS+1, GPB1F403.1119
& im_ident,10,219, GPB1F403.1120
*CALL ARGPPX GPB1F403.1121
& ICODE,CMESSAGE) GPB1F403.1122
IF(ICODE.GT.0) THEN DIA10B1A.330
RETURN DIA10B1A.331
END IF DIA10B1A.332
END IF DIA10B1A.333
DIA10B1A.334
C -------------------------------------------------------------------- DIA10B1A.335
CL SECTION 1.7 ITEM 221 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10B1A.336
CL * MOIST STATIC ENERGY. DIA10B1A.337
C -------------------------------------------------------------------- DIA10B1A.338
DIA10B1A.339
IF (L_UADJ_ENERGY_DP) THEN DIA10B1A.340
DO 170 K=1,Q_LEVELS DIA10B1A.341
K1 = (K-1)*P_FIELD DIA10B1A.342
DO I=FIRST_P,LAST_P-1 GPB1F403.1123
DIA10B1A.344
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.345
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.346
P_EXNER_FULL = P_EXNER_C DIA10B1A.347
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.348
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.59
DIA10B1A.350
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1) DIA10B1A.351
PK = AKH(K) + BKH(K) *PSTAR(I+1) DIA10B1A.352
P_EXNER_FULL = P_EXNER_C DIA10B1A.353
& (P_EXNER(I+1,K+1),P_EXNER(I+1,K),PKP1,PK,KAPPA) DIA10B1A.354
TEMPL_IP1 = THETAL(I+1,K) * P_EXNER_FULL ARS1F304.60
DIA10B1A.356
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.61
& (STASHWORK(K1+LOC_GEOPOTENTIAL+I-1)+ DIA10B1A.358
& STASHWORK(K1+LOC_GEOPOTENTIAL+I)+CP* DIA10B1A.359
& (TEMPL_I + TEMPL_IP1) DIA10B1A.360
& +LC*(QT(I,K)+QT(I+1,K))) DIA10B1A.361
DIA10B1A.362
END DO DIA10B1A.363
*IF -DEF,MPP GPB1F403.1124
C RE-CALCULATE END POINTS DIA10B1A.364
DO I=FIRST_P+LAST_ROW_PT-1,LAST_P,ROW_LENGTH GPB1F403.1125
DIA10B1A.366
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.367
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.368
P_EXNER_FULL = P_EXNER_C DIA10B1A.369
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.370
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.62
DIA10B1A.372
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1-ROW_LENGTH) DIA10B1A.373
PK = AKH(K) + BKH(K) *PSTAR(I+1-ROW_LENGTH) DIA10B1A.374
P_EXNER_FULL = P_EXNER_C DIA10B1A.375
& (P_EXNER(I+1-ROW_LENGTH,K+1),P_EXNER(I+1-ROW_LENGTH,K), DIA10B1A.376
& PKP1,PK,KAPPA) DIA10B1A.377
TEMPL_IP1 = THETAL(I+1-ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.63
DIA10B1A.379
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.64
& (STASHWORK(K1+LOC_GEOPOTENTIAL+I-1)+ DIA10B1A.381
& STASHWORK(K1+LOC_GEOPOTENTIAL+I-ROW_LENGTH)+CP* ARS1F304.65
& (TEMPL_I + TEMPL_IP1) DIA10B1A.383
& +LC*(QT(I,K)+QT(I+1-ROW_LENGTH,K))) DIA10B1A.384
END DO DIA10B1A.385
*ELSE GPB1F403.1126
! Set last point of field (halo) to a valid number GPB1F403.1127
FIELD(K1+LAST_P)=FIELD(K1+LAST_P-1) GPB1F403.1128
*ENDIF GPB1F403.1129
170 CONTINUE DIA10B1A.386
DIA10B1A.387
DO 175 K= Q_LEVELS+1,P_LEVELS DIA10B1A.388
K1 = (K-1)*P_FIELD DIA10B1A.389
DO I=FIRST_P,LAST_P-1 GPB1F403.1130
DIA10B1A.391
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.392
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.393
P_EXNER_FULL = P_EXNER_C DIA10B1A.394
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.395
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.66
DIA10B1A.397
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1) DIA10B1A.398
PK = AKH(K) + BKH(K) *PSTAR(I+1) DIA10B1A.399
P_EXNER_FULL = P_EXNER_C DIA10B1A.400
& (P_EXNER(I+1,K+1),P_EXNER(I+1,K),PKP1,PK,KAPPA) DIA10B1A.401
TEMPL_IP1 = THETAL(I+1,K) * P_EXNER_FULL ARS1F304.67
DIA10B1A.403
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.68
& (STASHWORK(K1+LOC_GEOPOTENTIAL+I-1)+ DIA10B1A.405
& STASHWORK(K1+LOC_GEOPOTENTIAL+I)+CP* DIA10B1A.406
& (TEMPL_I + TEMPL_IP1) ) DIA10B1A.407
END DO DIA10B1A.408
*IF -DEF,MPP GPB1F403.1131
C RE-CALCULATE END POINTS DIA10B1A.409
DO I=FIRST_P+LAST_ROW_PT-1,LAST_P,ROW_LENGTH GPB1F403.1132
DIA10B1A.411
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.412
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.413
P_EXNER_FULL = P_EXNER_C DIA10B1A.414
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.415
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.69
DIA10B1A.417
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1-ROW_LENGTH) DIA10B1A.418
PK = AKH(K) + BKH(K) *PSTAR(I+1-ROW_LENGTH) DIA10B1A.419
P_EXNER_FULL = P_EXNER_C DIA10B1A.420
& (P_EXNER(I+1-ROW_LENGTH,K+1),P_EXNER(I+1-ROW_LENGTH,K), DIA10B1A.421
& PKP1,PK,KAPPA) DIA10B1A.422
TEMPL_IP1 = THETAL(I+1-ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.70
DIA10B1A.424
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.71
& (STASHWORK(K1+LOC_GEOPOTENTIAL+I-1)+ DIA10B1A.426
& STASHWORK(K1+LOC_GEOPOTENTIAL+I-ROW_LENGTH)+CP* ARS1F304.72
& (TEMPL_I + TEMPL_IP1) ) DIA10B1A.428
DIA10B1A.429
END DO DIA10B1A.430
*ELSE GPB1F403.1133
! Set last point of field (halo) to a valid number GPB1F403.1134
FIELD(K1+LAST_P)=FIELD(K1+LAST_P-1) GPB1F403.1135
*ENDIF GPB1F403.1136
175 CONTINUE DIA10B1A.431
DIA10B1A.432
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_ENERGY_DP),FIELD, DIA10B1A.433
& FIRST_P, ARS1F304.73
& LAST_P,P_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.74
& STLIST(1,INDEX_UADJ_ENERGY_DP),LEN_STLIST, DIA10B1A.436
& STASH_LEVELS, DIA10B1A.437
& NUM_STASH_LEVELS+1, GPB1F403.1137
& im_ident,10,221, GPB1F403.1138
*CALL ARGPPX GPB1F403.1139
& ICODE,CMESSAGE) GPB1F403.1140
IF(ICODE.GT.0) THEN DIA10B1A.439
RETURN DIA10B1A.440
END IF DIA10B1A.441
END IF DIA10B1A.442
DIA10B1A.443
C END IF FOR U DIAGNOSTICS. DIA10B1A.444
END IF DIA10B1A.445
DIA10B1A.446
CL ------------------------------------------------------------------- DIA10B1A.447
CL SECTION 2. DIAGNOSTICS INVOLVING MEAN V OVER ADJUSTMENT STEP. DIA10B1A.448
CL ------------------------------------------------------------------- DIA10B1A.449
DIA10B1A.450
C -------------------------------------------------------------------- DIA10B1A.451
CL SECTION 2.1 ITEM 216 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10B1A.452
CL * U DIA10B1A.453
C -------------------------------------------------------------------- DIA10B1A.454
DIA10B1A.455
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10B1A.456
IF (L_VADJ_U_DP) THEN DIA10B1A.457
DO 210 K=1,P_LEVELS DIA10B1A.458
K1 = (K-1)*U_FIELD DIA10B1A.459
DO I=FIRST_U,LAST_U GPB1F403.1141
FIELD(K1+I)= -U(I,K)*V_ADJ(I,K)*SEC_U_LATITUDE(I) DIA10B1A.461
& *EARTH_RADIUS_INVERSE*FACTOR ARS1F402.16
END DO DIA10B1A.463
210 CONTINUE DIA10B1A.464
DIA10B1A.465
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_U_DP),FIELD,FIRST_U, ARS1F304.75
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.76
& STLIST(1,INDEX_VADJ_U_DP),LEN_STLIST, DIA10B1A.468
& STASH_LEVELS, DIA10B1A.469
& NUM_STASH_LEVELS+1, GPB1F403.1142
& im_ident,10,216, GPB1F403.1143
*CALL ARGPPX GPB1F403.1144
& ICODE,CMESSAGE) GPB1F403.1145
IF(ICODE.GT.0) THEN DIA10B1A.471
RETURN DIA10B1A.472
END IF DIA10B1A.473
END IF DIA10B1A.474
DIA10B1A.475
C -------------------------------------------------------------------- DIA10B1A.476
CL SECTION 2.2 ITEM 218 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10B1A.477
CL * V DIA10B1A.478
C -------------------------------------------------------------------- DIA10B1A.479
DIA10B1A.480
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10B1A.481
IF (L_VADJ_V_DP) THEN DIA10B1A.482
DO 220 K=1,P_LEVELS DIA10B1A.483
K1 = (K-1)*U_FIELD DIA10B1A.484
DO I=FIRST_U,LAST_U GPB1F403.1146
FIELD(K1+I)= -V(I,K)*V_ADJ(I,K)*SEC_U_LATITUDE(I) DIA10B1A.486
& *EARTH_RADIUS_INVERSE*FACTOR ARS1F402.17
END DO DIA10B1A.488
220 CONTINUE DIA10B1A.489
DIA10B1A.490
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_V_DP),FIELD,FIRST_U, ARS1F304.77
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.78
& STLIST(1,INDEX_VADJ_V_DP),LEN_STLIST, DIA10B1A.493
& STASH_LEVELS, DIA10B1A.494
& NUM_STASH_LEVELS+1, GPB1F403.1147
& im_ident,10,218, GPB1F403.1148
*CALL ARGPPX GPB1F403.1149
& ICODE,CMESSAGE) GPB1F403.1150
IF(ICODE.GT.0) THEN DIA10B1A.496
RETURN DIA10B1A.497
END IF DIA10B1A.498
END IF DIA10B1A.499
DIA10B1A.500
C CHECK TO SEE IF ANY V DIAGNOSTICS REQUESTED WHICH NEED V_ADJ TO DIA10B1A.501
C BE INTERPOLATED. DIA10B1A.502
DIA10B1A.503
IF(L_VADJ_TL_DP.OR.L_VADJ_QT_DP.OR. DIA10B1A.504
& L_VADJ_GEOPOT_DP.OR.L_VADJ_ENERGY_DP) THEN DIA10B1A.505
DIA10B1A.506
C -------------------------------------------------------------------- DIA10B1A.507
CL SECTION 2.3 REMOVE RADIUS OF EARTH * COSINE OF LATITUDE FROM V FIELD DIA10B1A.508
CL AND INTERPOLATE TO C-GRID V POINTS. DIA10B1A.509
C -------------------------------------------------------------------- DIA10B1A.510
DIA10B1A.511
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10B1A.512
DO 230 K=1,P_LEVELS DIA10B1A.513
K1 = (K-1)*U_FIELD DIA10B1A.514
DO I=FIRST_U+1,LAST_U GPB1F403.1151
VELOCITY(K1+I)=-.5*(V_ADJ(I,K)*SEC_U_LATITUDE(I)+ DIA10B1A.516
& V_ADJ(I-1,K)*SEC_U_LATITUDE(I-1)) DIA10B1A.517
& *EARTH_RADIUS_INVERSE DIA10B1A.518
END DO DIA10B1A.519
*IF -DEF,MPP GPB1F403.1152
C RE-CALCULATE END POINTS. DIA10B1A.520
DIA10B1A.521
DO I= FIRST_U+FIRST_ROW_PT-1,LAST_U,ROW_LENGTH GPB1F403.1153
VELOCITY(K1+I)=-.5*(V_ADJ(I,K)*SEC_U_LATITUDE(I)+ DIA10B1A.523
& V_ADJ(I+ROW_LENGTH-1,K)* DIA10B1A.524
& SEC_U_LATITUDE(I+ROW_LENGTH-1)) DIA10B1A.525
& *EARTH_RADIUS_INVERSE DIA10B1A.526
END DO DIA10B1A.527
*ELSE GPB1F403.1154
! Set first point of field (halo) to a valid number GPB1F403.1155
VELOCITY(K1+FIRST_U)=VELOCITY(K1+FIRST_U+1) GPB1F403.1156
*ENDIF GPB1F403.1157
230 CONTINUE DIA10B1A.528
DIA10B1A.529
DIA10B1A.530
C -------------------------------------------------------------------- DIA10B1A.531
CL SECTION 2.4 ITEM 212 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10B1A.532
CL * LIQUID WATER TEMPERATURE. DIA10B1A.533
C -------------------------------------------------------------------- DIA10B1A.534
DIA10B1A.535
IF (L_VADJ_TL_DP) THEN DIA10B1A.536
DO 240 K=1,P_LEVELS DIA10B1A.537
K1 = (K-1)*U_FIELD DIA10B1A.538
DO I=FIRST_U,LAST_U GPB1F403.1158
DIA10B1A.540
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.541
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.542
P_EXNER_FULL = P_EXNER_C DIA10B1A.543
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.544
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.79
DIA10B1A.546
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+ROW_LENGTH) DIA10B1A.547
PK = AKH(K) + BKH(K) *PSTAR(I+ROW_LENGTH) DIA10B1A.548
P_EXNER_FULL = P_EXNER_C DIA10B1A.549
& (P_EXNER(I+ROW_LENGTH,K+1),P_EXNER(I+ROW_LENGTH,K), DIA10B1A.550
& PKP1,PK,KAPPA) DIA10B1A.551
TEMPL_IP1 = THETAL(I+ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.80
DIA10B1A.553
DIA10B1A.554
FIELD(K1+I) = VELOCITY(K1+I) * 0.5 * (TEMPL_I+TEMPL_IP1) DIA10B1A.555
& *FACTOR ARS1F402.18
DIA10B1A.556
END DO DIA10B1A.557
240 CONTINUE DIA10B1A.558
DIA10B1A.559
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_TL_DP),FIELD,FIRST_U, ARS1F304.81
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.82
& STLIST(1,INDEX_VADJ_TL_DP),LEN_STLIST, DIA10B1A.562
& STASH_LEVELS, DIA10B1A.563
& NUM_STASH_LEVELS+1, GPB1F403.1159
& im_ident,10,212, GPB1F403.1160
*CALL ARGPPX GPB1F403.1161
& ICODE,CMESSAGE) GPB1F403.1162
IF(ICODE.GT.0) THEN DIA10B1A.565
RETURN DIA10B1A.566
END IF DIA10B1A.567
END IF DIA10B1A.568
DIA10B1A.569
C -------------------------------------------------------------------- DIA10B1A.570
CL SECTION 2.5 ITEM 214 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10B1A.571
CL * TOTAL WATER. DIA10B1A.572
C -------------------------------------------------------------------- DIA10B1A.573
DIA10B1A.574
IF (L_VADJ_QT_DP) THEN DIA10B1A.575
DO 250 K=1,Q_LEVELS DIA10B1A.576
K1 = (K-1)*U_FIELD DIA10B1A.577
DO I=FIRST_U,LAST_U GPB1F403.1163
FIELD(K1+I) = VELOCITY(K1+I)*.5* DIA10B1A.579
& (QT(I,K)+QT(I+ROW_LENGTH,K)) DIA10B1A.580
END DO DIA10B1A.581
250 CONTINUE DIA10B1A.582
DIA10B1A.583
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_QT_DP),FIELD,FIRST_U, ARS1F304.83
& LAST_U,U_FIELD,ROW_LENGTH,Q_LEVELS, ARS1F304.84
& STLIST(1,INDEX_VADJ_QT_DP),LEN_STLIST, DIA10B1A.586
& STASH_LEVELS, DIA10B1A.587
& NUM_STASH_LEVELS+1, GPB1F403.1164
& im_ident,10,214, GPB1F403.1165
*CALL ARGPPX GPB1F403.1166
& ICODE,CMESSAGE) GPB1F403.1167
IF(ICODE.GT.0) THEN DIA10B1A.589
RETURN DIA10B1A.590
END IF DIA10B1A.591
END IF DIA10B1A.592
DIA10B1A.593
C -------------------------------------------------------------------- DIA10B1A.594
CL SECTION 2.6 ITEM 220 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10B1A.595
CL * GEOPOTENTIAL HEIGHT DIA10B1A.596
C -------------------------------------------------------------------- DIA10B1A.597
DIA10B1A.598
IF (L_VADJ_GEOPOT_DP) THEN DIA10B1A.599
DO 260 K=1,P_LEVELS DIA10B1A.600
K1 = (K-1)*U_FIELD DIA10B1A.601
DO I=FIRST_U,LAST_U GPB1F403.1168
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.85
& (STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1)+ DIA10B1A.604
& STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1+ROW_LENGTH)) DIA10B1A.605
END DO DIA10B1A.606
260 CONTINUE DIA10B1A.607
DIA10B1A.608
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_GEOPOT_DP),FIELD, DIA10B1A.609
& FIRST_U, ARS1F304.86
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.87
& STLIST(1,INDEX_VADJ_GEOPOT_DP),LEN_STLIST, DIA10B1A.612
& STASH_LEVELS, DIA10B1A.613
& NUM_STASH_LEVELS+1, GPB1F403.1169
& im_ident,10,220, GPB1F403.1170
*CALL ARGPPX GPB1F403.1171
& ICODE,CMESSAGE) GPB1F403.1172
IF(ICODE.GT.0) THEN DIA10B1A.615
RETURN DIA10B1A.616
END IF DIA10B1A.617
END IF DIA10B1A.618
DIA10B1A.619
C -------------------------------------------------------------------- DIA10B1A.620
CL SECTION 2.7 ITEM 222 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10B1A.621
CL * MOIST STATIC ENERGY. DIA10B1A.622
C -------------------------------------------------------------------- DIA10B1A.623
DIA10B1A.624
IF (L_VADJ_ENERGY_DP) THEN DIA10B1A.625
DO 270 K=1,Q_LEVELS DIA10B1A.626
K1 = (K-1)*U_FIELD DIA10B1A.627
DO I=FIRST_U,LAST_U GPB1F403.1173
DIA10B1A.629
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.630
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.631
P_EXNER_FULL = P_EXNER_C DIA10B1A.632
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.633
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.88
DIA10B1A.635
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+ROW_LENGTH) DIA10B1A.636
PK = AKH(K) + BKH(K) *PSTAR(I+ROW_LENGTH) DIA10B1A.637
P_EXNER_FULL = P_EXNER_C DIA10B1A.638
& (P_EXNER(I+ROW_LENGTH,K+1),P_EXNER(I+ROW_LENGTH,K), DIA10B1A.639
& PKP1,PK,KAPPA) DIA10B1A.640
TEMPL_IP1 = THETAL(I+ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.89
DIA10B1A.642
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.90
& (STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1)+ ARS1F304.91
& STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1+ROW_LENGTH) ARS1F304.92
& +CP*(TEMPL_I + TEMPL_IP1) DIA10B1A.646
& +LC*(QT(I,K)+QT(I+ROW_LENGTH,K))) DIA10B1A.647
DIA10B1A.648
END DO DIA10B1A.649
270 CONTINUE DIA10B1A.650
DO 275 K= Q_LEVELS+1,P_LEVELS DIA10B1A.651
K1 = (K-1)*U_FIELD DIA10B1A.652
DO I=FIRST_U,LAST_U GPB1F403.1174
DIA10B1A.654
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10B1A.655
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10B1A.656
P_EXNER_FULL = P_EXNER_C DIA10B1A.657
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10B1A.658
TEMPL_I = THETAL(I,K) * P_EXNER_FULL ARS1F304.93
DIA10B1A.660
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+ROW_LENGTH) DIA10B1A.661
PK = AKH(K) + BKH(K) *PSTAR(I+ROW_LENGTH) DIA10B1A.662
P_EXNER_FULL = P_EXNER_C DIA10B1A.663
& (P_EXNER(I+ROW_LENGTH,K+1),P_EXNER(I+ROW_LENGTH,K), DIA10B1A.664
& PKP1,PK,KAPPA) DIA10B1A.665
TEMPL_IP1 = THETAL(I+ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.94
DIA10B1A.667
FIELD(K1+I) = VELOCITY(K1+I)*.5*FACTOR* ARS1F304.95
& (STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1)+ ARS1F304.96
& STASHWORK((K-1)*P_FIELD+LOC_GEOPOTENTIAL+I-1+ROW_LENGTH) ARS1F304.97
& + CP * (TEMPL_I + TEMPL_I+1) ) DIA10B1A.671
DIA10B1A.672
END DO DIA10B1A.673
275 CONTINUE DIA10B1A.674
DIA10B1A.675
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_ENERGY_DP),FIELD, DIA10B1A.676
& FIRST_U, ARS1F304.98
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.99
& STLIST(1,INDEX_VADJ_ENERGY_DP),LEN_STLIST, DIA10B1A.679
& STASH_LEVELS, DIA10B1A.680
& NUM_STASH_LEVELS+1, GPB1F403.1175
& im_ident,10,222, GPB1F403.1176
*CALL ARGPPX GPB1F403.1177
& ICODE,CMESSAGE) GPB1F403.1178
IF(ICODE.GT.0) THEN DIA10B1A.682
RETURN DIA10B1A.683
END IF DIA10B1A.684
END IF DIA10B1A.685
DIA10B1A.686
C END IF FOR V DIAGNOSTICS. DIA10B1A.687
DIA10B1A.688
END IF DIA10B1A.689
DIA10B1A.690
CL END OF ROUTINE DIAG10_B DIA10B1A.691
DIA10B1A.692
RETURN DIA10B1A.693
END DIA10B1A.694
*ENDIF DIA10B1A.695
*ENDIF AJC0F405.291