SUBROUTINE DIAG10_A( 1,10DIA10A1A.25
& PSTAR,PSTAR_OLD,U_ADJ,V_ADJ,Q,ETADOT, DIA10A1A.26
& THETA,P_EXNER,RS,SEC_U_LATITUDE, DIA10A1A.27
& ROW_LENGTH,P_LEVELS,Q_LEVELS,P_FIELD, DIA10A1A.28
& U_FIELD,AK,BK,AKH,BKH,ADVECTION_TIMESTEP, DIA10A1A.29
& FIRST_POINT,LAST_POINT, DIA10A1A.30
& NSECTS,NITEMS,TOTITEMS,NUM_STASH_LEVELS, DIA10A1A.31
& NUM_LEVEL_LISTS,LEN_STLIST,STASHLEN,SF, DIA10A1A.32
& STINDEX,STLIST,SI,STASH_LEVELS,STASHWORK, DIA10A1A.33
& FIELD,WORK_LENGTH, GPB1F403.943
& im_ident, GPB1F403.944
*CALL ARGFLDPT 
GPB1F403.945
*CALL ARGPPX GPB1F403.946
& ICODE,CMESSAGE) GPB1F403.947
DIA10A1A.35
IMPLICIT NONE DIA10A1A.36
DIA10A1A.37
INTEGER DIA10A1A.38
& P_FIELD !IN 1ST DIMENSION OF FIELD OF PSTAR DIA10A1A.39
&, U_FIELD !IN 1ST DIMENSION OF FIELD OF U,V DIA10A1A.40
&, ROW_LENGTH !IN NUMBER OF POINTS PER ROW DIA10A1A.41
&, P_LEVELS !IN NUMBER OF PRESSURE LEVELS DIA10A1A.42
&, Q_LEVELS !IN NUMBER OF WET LEVELS DIA10A1A.43
&, FIRST_POINT !IN FIRST POINT OUTPUT REQUIRED FOR. DIA10A1A.44
&, LAST_POINT !IN LAST POINT OUTPUT REQUIRED FOR. DIA10A1A.45
&, WORK_LENGTH !IN SIZE OF DYNAMICALLY ALLOCATED WORKSPACE DIA10A1A.46
DIA10A1A.47
INTEGER GPB1F403.948
& im_ident !IN : Internal model indent GPB1F403.949
GPB1F403.950
*CALL TYPFLDPT GPB1F403.951
*CALL CSUBMODL GPB1F403.952
*CALL CPPXREF GPB1F403.953
*CALL PPXLOOK GPB1F403.954
INTEGER DIA10A1A.48
& ICODE !OUT RETURN CODE. NON-ZERO IF ERROR-DETECTED DIA10A1A.49
DIA10A1A.50
CHARACTER DIA10A1A.51
& CMESSAGE*(*) !OUT ERROR MESSAGE DIA10A1A.52
DIA10A1A.53
C INPUT DATA DIA10A1A.54
DIA10A1A.55
REAL DIA10A1A.56
& PSTAR(P_FIELD) !IN PRIMARY MODEL ARRAY FOR PSTAR FIELD DIA10A1A.57
&, PSTAR_OLD(P_FIELD) !IN PSTAR FIELD AT PREVIOUS TIMESTEP. DIA10A1A.58
&, P_EXNER(P_FIELD,P_LEVELS+1) !IN EXNER PRESS ON 1/2 LVLS DIA10A1A.59
&, THETA(P_FIELD,P_LEVELS) !IN PRIMARY MODEL ARRAY FOR THETA FIELD DIA10A1A.60
&, U_ADJ(U_FIELD,P_LEVELS) !IN MEAN U OVER ADJUSTMENT STEPS DIA10A1A.61
&, V_ADJ(U_FIELD,P_LEVELS) !IN MEAN V OVER ADJUSTMENT STEPS DIA10A1A.62
&, Q(P_FIELD,Q_LEVELS) !IN PRIMARY MODEL ARRAY FOR HUMIDITY DIA10A1A.63
&, RS(P_FIELD,P_LEVELS) !IN EFFECTIVE RADIUS OF EARTH. DIA10A1A.64
&, ETADOT(P_FIELD,P_LEVELS)!IN VERTICAL VELOCITY. DIA10A1A.65
&, SEC_U_LATITUDE(U_FIELD) !IN 1./(COS(LAT)) AT U POINTS. DIA10A1A.66
DIA10A1A.67
REAL DIA10A1A.68
& AKH(P_LEVELS+1) !IN LAYER THICKNESS DIA10A1A.69
&, BKH(P_LEVELS+1) !IN LAYER THICKNESS DIA10A1A.70
&, AK (P_LEVELS) !IN VALUE AT LAYER CENTRE DIA10A1A.71
&, BK (P_LEVELS) !IN VALUE AT LAYER CENTRE DIA10A1A.72
&, ADVECTION_TIMESTEP !IN ADVECTION TIMESTEP. DIA10A1A.73
DIA10A1A.74
REAL DIA10A1A.75
& FIELD(P_FIELD*P_LEVELS) ! WORK-SPACE FOR OUTPUT FIELD DIA10A1A.76
DIA10A1A.77
C STASH REQUIREMENTS. DIA10A1A.78
DIA10A1A.79
INTEGER DIA10A1A.80
& NSECTS !IN NO OF PROCESSING SECTIONS (MASTER PCRS) DIA10A1A.81
&, NITEMS !IN MAX NO OF STASH ITEMS IN A SECTION DIA10A1A.82
&, TOTITEMS !IN MAX NO OF TOTAL STASH ITEMS DIA10A1A.83
&, NUM_STASH_LEVELS !IN MAX NUMBER OF LEVELS IN A LEVELS LIST DIA10A1A.84
&, NUM_LEVEL_LISTS !IN MAX NUMBER OF LEVELS LIST DIA10A1A.85
&, LEN_STLIST !IN LENGTH OF LIST OF ITEMS FROM STASH DIA10A1A.86
&, STASHLEN !IN SIZE OF STASHWORK DIA10A1A.87
DIA10A1A.88
INTEGER DIA10A1A.89
& STINDEX(2,NITEMS,0:NSECTS) !IN DIA10A1A.90
&, STLIST(LEN_STLIST,TOTITEMS) !IN DIA10A1A.91
&, SI(NITEMS,0:NSECTS) !IN DIA10A1A.92
&, STASH_LEVELS(NUM_STASH_LEVELS+1,NUM_LEVEL_LISTS) !IN DIA10A1A.93
DIA10A1A.94
LOGICAL DIA10A1A.95
& SF(0:NITEMS,0:NSECTS) !IN @DYALLOC.840
DIA10A1A.97
REAL DIA10A1A.98
& STASHWORK(STASHLEN) !INOUT. WORK SPACE HOLDING STASH OUTPUT. DIA10A1A.99
DIA10A1A.100
C*-------------------------------------------------------------------- DIA10A1A.101
DIA10A1A.102
C*L DEFINE LOCAL ARRAYS AND VARIABLES USED IN THIS ROUTINE---------- DIA10A1A.103
C DEFINE LOCAL ARRAYS: 2 ARE REQUIRED. DIA10A1A.104
REAL DIA10A1A.105
& VELOCITY(WORK_LENGTH) ! WORK-SPACE FOR INTERPOLATED DIA10A1A.106
& ! WIND FIELD. DIA10A1A.107
INTEGER ARS1F304.4
& FIRST_U,FIRST_P ! first point for COPYDIAG for U & P grids ARS1F304.5
& ,LAST_U,LAST_P ! last point for COPYDIAG for U & P grids ARS1F304.6
DIA10A1A.108
LOGICAL DIA10A1A.109
& LIST(P_LEVELS) DIA10A1A.110
DIA10A1A.111
C*-------------------------------------------------------------------- DIA10A1A.112
DIA10A1A.113
C DEFINE LOCAL VARIABLES DIA10A1A.114
REAL DIA10A1A.115
& RECIP_TIMESTEP DIA10A1A.116
&, EARTH_RADIUS_INVERSE DIA10A1A.117
&, SCALAR DIA10A1A.118
&, SCALAR_A DIA10A1A.119
&, SCALAR_B DIA10A1A.120
&, PKP1,PK ! Pressures at half levels k+1 and k DIA10A1A.121
&, P_EXNER_FULL ! Exner Pressure at full model level DIA10A1A.122
&, TEMP_I,TEMP_IP1 ! Temperatures at points/rows i and i+1 DIA10A1A.123
& ,FACTOR ! scaling factor ARS1F402.4
DIA10A1A.124
INTEGER DIA10A1A.125
& I,K,K1,LEVEL DIA10A1A.126
DIA10A1A.127
*CALL C_DG10_1 DIA10A1A.128
C Get UM constants DIA10A1A.129
*CALL C_A DIA10A1A.130
*CALL C_G DIA10A1A.131
*CALL C_R_CP DIA10A1A.132
*CALL C_LHEAT DIA10A1A.133
DIA10A1A.134
C*L EXTERNAL SUBROUTINES CALLED ------------------------------------ DIA10A1A.135
EXTERNAL COPYDIAG_3D,SET_LEVELS_LIST,COPYDIAG DIA10A1A.136
C*-------------------------------------------------------------------- DIA10A1A.137
DIA10A1A.138
*CALL P_EXNERC DIA10A1A.139
C Comdeck C_DG10_2 initialises local variables defined in C_DG10_1 DIA10A1A.140
*CALL C_DG10_2 DIA10A1A.141
DIA10A1A.142
CL-------------------------------------------------------------------- DIA10A1A.143
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD DIA10A1A.144
CL-------------------------------------------------------------------- DIA10A1A.145
FIRST_U = FIRST_FLD_PT GPB1F403.955
FIRST_P = FIRST_FLD_PT GPB1F403.956
LAST_U = LAST_U_FLD_PT GPB1F403.957
LAST_P = LAST_P_FLD_PT GPB1F403.958
DIA10A1A.146
CL ------------------------------------------------------------------- DIA10A1A.147
CL SECTION 1. DIAGNOSTICS INVOLVING MEAN U OVER ADJUSTMENT STEP. DIA10A1A.148
CL ------------------------------------------------------------------- DIA10A1A.149
DIA10A1A.150
EARTH_RADIUS_INVERSE = 1./A DIA10A1A.151
FACTOR=1.0e-6 ARS1F402.5
DIA10A1A.152
C -------------------------------------------------------------------- DIA10A1A.153
CL SECTION 1.1 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS. DIA10A1A.154
C -------------------------------------------------------------------- DIA10A1A.155
DIA10A1A.156
IF (L_UADJ_DP) THEN DIA10A1A.157
CL REMOVE RADIUS OF EARTH FROM U FIELD. DIA10A1A.158
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10A1A.159
DO 110 K=1,P_LEVELS DIA10A1A.160
K1 = (K-1)*U_FIELD DIA10A1A.161
DO I=FIRST_U,LAST_U GPB1F403.959
FIELD(K1+I) = -U_ADJ(I,K)*EARTH_RADIUS_INVERSE DIA10A1A.163
END DO DIA10A1A.164
110 CONTINUE DIA10A1A.165
DIA10A1A.166
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_DP),FIELD,FIRST_U, ARS1F304.11
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.12
& STLIST(1,INDEX_UADJ_DP),LEN_STLIST, DIA10A1A.169
& STASH_LEVELS,NUM_STASH_LEVELS+1, GPB1F403.960
& im_ident,10,201, GPB1F403.961
*CALL ARGPPX GPB1F403.962
& ICODE,CMESSAGE) GPB1F403.963
IF(ICODE.GT.0) THEN DIA10A1A.172
RETURN DIA10A1A.173
END IF DIA10A1A.174
END IF DIA10A1A.175
DIA10A1A.176
CL CHECK TO SEE IF ANY U DIAGNOSTICS REQUESTED WHICH NEED U_ADJ TO DIA10A1A.177
CL BE INTERPOLATED. DIA10A1A.178
DIA10A1A.179
IF(L_UADJ_T_DP.OR.L_UADJ_Q_DP) THEN DIA10A1A.180
DIA10A1A.181
C -------------------------------------------------------------------- DIA10A1A.182
CL SECTION 1.2 INTERPOLATE U TO C-GRID U POINTS. DIA10A1A.183
C -------------------------------------------------------------------- DIA10A1A.184
DIA10A1A.185
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10A1A.186
DO 120 K=1,P_LEVELS DIA10A1A.187
K1 = (K-1)*P_FIELD DIA10A1A.188
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO GPB1F403.964
VELOCITY(K1+I) = -.5*(U_ADJ(I,K) + U_ADJ(I-ROW_LENGTH,K)) DIA10A1A.190
& *EARTH_RADIUS_INVERSE DIA10A1A.191
END DO DIA10A1A.192
C SET POLAR VALUES EQUAL TO VALUE ON ADJACENT ROW. DIA10A1A.193
DIA10A1A.194
*IF DEF,MPP GPB1F403.965
IF (at_top_of_LPG) THEN GPB1F403.966
*ENDIF GPB1F403.967
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 GPB1F403.968
VELOCITY(K1+I) = -U_ADJ(I,K)*EARTH_RADIUS_INVERSE GPB1F403.969
ENDDO GPB1F403.970
*IF DEF,MPP GPB1F403.971
ENDIF GPB1F403.972
GPB1F403.973
IF (at_base_of_LPG) THEN GPB1F403.974
*ENDIF GPB1F403.975
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 GPB1F403.976
VELOCITY(K1+I) = -U_ADJ(I-ROW_LENGTH,K)* GPB1F403.977
& EARTH_RADIUS_INVERSE GPB1F403.978
ENDDO GPB1F403.979
*IF DEF,MPP GPB1F403.980
ENDIF GPB1F403.981
*ENDIF GPB1F403.982
120 CONTINUE DIA10A1A.200
DIA10A1A.201
C -------------------------------------------------------------------- DIA10A1A.202
CL SECTION 1.3 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10A1A.203
CL * TEMPERATURE. DIA10A1A.204
C -------------------------------------------------------------------- DIA10A1A.205
DIA10A1A.206
IF (L_UADJ_T_DP) THEN DIA10A1A.207
DO 130 K=1,P_LEVELS DIA10A1A.208
K1 = (K-1)*P_FIELD DIA10A1A.209
DO I=FIRST_P,LAST_P-1 GPB1F403.983
DIA10A1A.211
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10A1A.212
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10A1A.213
P_EXNER_FULL = P_EXNER_C DIA10A1A.214
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10A1A.215
TEMP_I = THETA(I,K) * P_EXNER_FULL ARS1F304.13
DIA10A1A.217
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1) DIA10A1A.218
PK = AKH(K) + BKH(K) *PSTAR(I+1) DIA10A1A.219
P_EXNER_FULL = P_EXNER_C DIA10A1A.220
& (P_EXNER(I+1,K+1),P_EXNER(I+1,K),PKP1,PK,KAPPA) DIA10A1A.221
TEMP_IP1 = THETA(I+1,K) * P_EXNER_FULL ARS1F304.14
DIA10A1A.223
FIELD(K1+I) = VELOCITY(K1+I) * 0.5 * (TEMP_I + TEMP_IP1) DIA10A1A.224
& *factor ARS1F402.6
DIA10A1A.225
END DO DIA10A1A.226
*IF -DEF,MPP GPB1F403.984
C RE-CALCULATE END POINTS DIA10A1A.227
DO I=FIRST_P+LAST_ROW_PT-1,LAST_P,ROW_LENGTH GPB1F403.985
DIA10A1A.229
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10A1A.230
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10A1A.231
P_EXNER_FULL = P_EXNER_C DIA10A1A.232
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10A1A.233
TEMP_I = THETA(I,K) * P_EXNER_FULL ARS1F304.15
DIA10A1A.235
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+1-ROW_LENGTH) DIA10A1A.236
PK = AKH(K) + BKH(K) *PSTAR(I+1-ROW_LENGTH) DIA10A1A.237
P_EXNER_FULL = P_EXNER_C DIA10A1A.238
& (P_EXNER(I+1-ROW_LENGTH,K+1),P_EXNER(I+1-ROW_LENGTH,K), DIA10A1A.239
& PKP1,PK,KAPPA) DIA10A1A.240
TEMP_IP1 = THETA(I+1-ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.16
DIA10A1A.242
FIELD(K1+I) = VELOCITY(K1+I) * 0.5 * (TEMP_I + TEMP_IP1) DIA10A1A.243
& *factor ARS1F402.7
DIA10A1A.244
END DO DIA10A1A.245
*ELSE GPB1F403.986
! Set last point of field (halo) to a valid number GPB1F403.987
FIELD(K1+LAST_P)=FIELD(K1+LAST_P-1) GPB1F403.988
*ENDIF GPB1F403.989
130 CONTINUE DIA10A1A.246
DIA10A1A.247
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_T_DP),FIELD,FIRST_P, ARS1F304.17
& LAST_P,P_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.18
& STLIST(1,INDEX_UADJ_T_DP),LEN_STLIST, DIA10A1A.250
& STASH_LEVELS, DIA10A1A.251
& NUM_STASH_LEVELS+1, GPB1F403.990
& im_ident,10,207, GPB1F403.991
*CALL ARGPPX GPB1F403.992
& ICODE,CMESSAGE) GPB1F403.993
IF(ICODE.GT.0) THEN DIA10A1A.253
RETURN DIA10A1A.254
END IF DIA10A1A.255
END IF DIA10A1A.256
DIA10A1A.257
C -------------------------------------------------------------------- DIA10A1A.258
CL SECTION 1.4 MEAN PRESSURE WEIGHTED U OVER ADJUSTMENT STEPS DIA10A1A.259
CL * HUMIDITY. DIA10A1A.260
C -------------------------------------------------------------------- DIA10A1A.261
DIA10A1A.262
IF (L_UADJ_Q_DP) THEN DIA10A1A.263
DO 140 K=1,Q_LEVELS DIA10A1A.264
K1 = (K-1)*P_FIELD DIA10A1A.265
DO I=FIRST_P,LAST_P-1 GPB1F403.994
FIELD(K1+I) = VELOCITY(K1+I)*.5* (Q(I,K)+Q(I+1,K)) DIA10A1A.267
END DO DIA10A1A.268
*IF -DEF,MPP GPB1F403.995
C RE-CALCULATE END POINTS DIA10A1A.269
DO I=FIRST_P+LAST_ROW_PT-1,LAST_P,ROW_LENGTH GPB1F403.996
FIELD(K1+I) = VELOCITY(K1+I)*.5* DIA10A1A.271
& (Q(I,K)+Q(I+1-ROW_LENGTH,K)) DIA10A1A.272
END DO DIA10A1A.273
*ELSE GPB1F403.997
! Set last point of field (halo) to a valid number GPB1F403.998
FIELD(K1+LAST_P)=FIELD(K1+LAST_P-1) GPB1F403.999
*ENDIF GPB1F403.1000
140 CONTINUE DIA10A1A.274
DIA10A1A.275
CALL COPYDIAG_3D (STASHWORK(LOC_UADJ_Q_DP),FIELD,FIRST_P, ARS1F304.19
& LAST_P,P_FIELD,ROW_LENGTH,Q_LEVELS, ARS1F304.20
& STLIST(1,INDEX_UADJ_Q_DP),LEN_STLIST, DIA10A1A.278
& STASH_LEVELS, DIA10A1A.279
& NUM_STASH_LEVELS+1, GPB1F403.1001
& im_ident,10,209, GPB1F403.1002
*CALL ARGPPX GPB1F403.1003
& ICODE,CMESSAGE) GPB1F403.1004
IF(ICODE.GT.0) THEN DIA10A1A.281
RETURN DIA10A1A.282
END IF DIA10A1A.283
END IF DIA10A1A.284
DIA10A1A.285
C END IF FOR U DIAGNOSTICS DIA10A1A.286
END IF DIA10A1A.287
DIA10A1A.288
CL ------------------------------------------------------------------- DIA10A1A.289
CL SECTION 2. DIAGNOSTICS INVOLVING MEAN V OVER ADJUSTMENT STEP. DIA10A1A.290
CL ------------------------------------------------------------------- DIA10A1A.291
DIA10A1A.292
C -------------------------------------------------------------------- DIA10A1A.293
CL SECTION 2.1 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS. DIA10A1A.294
C -------------------------------------------------------------------- DIA10A1A.295
DIA10A1A.296
IF (L_VADJ_DP) THEN DIA10A1A.297
CL REMOVE RADIUS OF EARTH * COSINE OF LATITUDE FROM V FIELD. DIA10A1A.298
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10A1A.299
DIA10A1A.300
DO 210 K=1,P_LEVELS DIA10A1A.301
K1 = (K-1)*U_FIELD DIA10A1A.302
DO I=FIRST_U,LAST_U GPB1F403.1005
FIELD(K1+I) = -V_ADJ(I,K)*EARTH_RADIUS_INVERSE DIA10A1A.304
& *SEC_U_LATITUDE(I) DIA10A1A.305
END DO DIA10A1A.306
210 CONTINUE DIA10A1A.307
DIA10A1A.308
CALL COPYDIAG_3D(STASHWORK(LOC_VADJ_DP),FIELD,FIRST_U, ARS1F304.21
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.22
& STLIST(1,INDEX_VADJ_DP),LEN_STLIST, DIA10A1A.311
& STASH_LEVELS, DIA10A1A.312
& NUM_STASH_LEVELS+1, GPB1F403.1006
& im_ident,10,202, GPB1F403.1007
*CALL ARGPPX GPB1F403.1008
& ICODE,CMESSAGE) GPB1F403.1009
IF(ICODE.GT.0) THEN DIA10A1A.314
RETURN DIA10A1A.315
END IF DIA10A1A.316
END IF DIA10A1A.317
DIA10A1A.318
CL CHECK TO SEE IF ANY V DIAGNOSTICS REQUESTED WHICH NEED V_ADJ TO DIA10A1A.319
CL BE INTERPOLATED. DIA10A1A.320
DIA10A1A.321
IF(L_VADJ_T_DP.OR.L_VADJ_Q_DP) THEN DIA10A1A.322
DIA10A1A.323
C -------------------------------------------------------------------- DIA10A1A.324
CL SECTION 2.2 INTERPOLATE V TO C-GRID V POINTS. DIA10A1A.325
C -------------------------------------------------------------------- DIA10A1A.326
DIA10A1A.327
C MINUS SIGN SETS DELTA P TO POSITIVE VALUE. DIA10A1A.328
DO 220 K=1,P_LEVELS DIA10A1A.329
K1 = (K-1)*U_FIELD DIA10A1A.330
DO I=FIRST_U+1,LAST_U GPB1F403.1010
VELOCITY(K1+I)= -.5*(V_ADJ(I,K)*SEC_U_LATITUDE(I) DIA10A1A.332
& +V_ADJ(I-1,K) DIA10A1A.333
& *SEC_U_LATITUDE(I-1)) DIA10A1A.334
& *EARTH_RADIUS_INVERSE DIA10A1A.335
END DO DIA10A1A.336
*IF -DEF,MPP GPB1F403.1011
C RE-CALCULATE END POINTS. DIA10A1A.337
DIA10A1A.338
DO I=FIRST_U+FIRST_ROW_PT-1,LAST_U,ROW_LENGTH GPB1F403.1012
VELOCITY(K1+I)= -.5*(V_ADJ(I,K)*SEC_U_LATITUDE(I) DIA10A1A.340
& +V_ADJ(I-1+ROW_LENGTH,K) DIA10A1A.341
& *SEC_U_LATITUDE(I+ROW_LENGTH-1)) DIA10A1A.342
& *EARTH_RADIUS_INVERSE DIA10A1A.343
END DO DIA10A1A.344
*ELSE GPB1F403.1013
! Set first point of field (halo) to a valid number GPB1F403.1014
VELOCITY(K1+FIRST_U)= VELOCITY(K1+FIRST_U+1) GPB1F404.180
*ENDIF GPB1F403.1016
220 CONTINUE DIA10A1A.345
DIA10A1A.346
C -------------------------------------------------------------------- DIA10A1A.347
CL SECTION 2.3 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10A1A.348
CL * TEMPERATURE. DIA10A1A.349
C -------------------------------------------------------------------- DIA10A1A.350
DIA10A1A.351
IF (L_VADJ_T_DP) THEN DIA10A1A.352
DO 230 K=1,P_LEVELS DIA10A1A.353
K1 = (K-1)*U_FIELD DIA10A1A.354
DO I=FIRST_U,LAST_U GPB1F403.1017
DIA10A1A.356
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) DIA10A1A.357
PK = AKH(K) + BKH(K) *PSTAR(I) DIA10A1A.358
P_EXNER_FULL = P_EXNER_C DIA10A1A.359
& (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) DIA10A1A.360
TEMP_I = THETA(I,K) * P_EXNER_FULL ARS1F304.23
DIA10A1A.362
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I+ROW_LENGTH) DIA10A1A.363
PK = AKH(K) + BKH(K) *PSTAR(I+ROW_LENGTH) DIA10A1A.364
P_EXNER_FULL = P_EXNER_C DIA10A1A.365
& (P_EXNER(I+ROW_LENGTH,K+1),P_EXNER(I+ROW_LENGTH,K), DIA10A1A.366
& PKP1,PK,KAPPA) DIA10A1A.367
TEMP_IP1 = THETA(I+ROW_LENGTH,K) * P_EXNER_FULL ARS1F304.24
DIA10A1A.369
FIELD(K1+I) = VELOCITY(K1+I) * 0.5 * (TEMP_I + TEMP_IP1) DIA10A1A.370
& * FACTOR ARS1F402.8
DIA10A1A.371
END DO DIA10A1A.372
230 CONTINUE DIA10A1A.373
DIA10A1A.374
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_T_DP),FIELD,FIRST_U, ARS1F304.25
& LAST_U,U_FIELD,ROW_LENGTH,P_LEVELS, ARS1F304.26
& STLIST(1,INDEX_VADJ_T_DP),LEN_STLIST, DIA10A1A.377
& STASH_LEVELS, DIA10A1A.378
& NUM_STASH_LEVELS+1, GPB1F403.1018
& im_ident,10,208, GPB1F403.1019
*CALL ARGPPX GPB1F403.1020
& ICODE,CMESSAGE) GPB1F403.1021
IF(ICODE.GT.0) THEN DIA10A1A.380
RETURN DIA10A1A.381
END IF DIA10A1A.382
END IF DIA10A1A.383
DIA10A1A.384
C -------------------------------------------------------------------- DIA10A1A.385
CL SECTION 2.4 MEAN PRESSURE WEIGHTED V OVER ADJUSTMENT STEPS DIA10A1A.386
CL * HUMIDITY. DIA10A1A.387
C -------------------------------------------------------------------- DIA10A1A.388
DIA10A1A.389
IF (L_VADJ_Q_DP) THEN DIA10A1A.390
DO 240 K=1,Q_LEVELS DIA10A1A.391
K1 = (K-1)*U_FIELD DIA10A1A.392
DO I=FIRST_U,LAST_U GPB1F403.1022
FIELD(K1+I) = VELOCITY(K1+I)*.5* DIA10A1A.394
& (Q(I,K)+Q(I+ROW_LENGTH,K)) DIA10A1A.395
END DO DIA10A1A.396
240 CONTINUE DIA10A1A.397
DIA10A1A.398
CALL COPYDIAG_3D (STASHWORK(LOC_VADJ_Q_DP),FIELD,FIRST_U, ARS1F304.27
& LAST_U,U_FIELD,ROW_LENGTH,Q_LEVELS, ARS1F304.28
& STLIST(1,INDEX_VADJ_Q_DP),LEN_STLIST, DIA10A1A.401
& STASH_LEVELS, DIA10A1A.402
& NUM_STASH_LEVELS+1, GPB1F403.1023
& im_ident,10,210, GPB1F403.1024
*CALL ARGPPX GPB1F403.1025
& ICODE,CMESSAGE) GPB1F403.1026
IF(ICODE.GT.0) THEN DIA10A1A.404
RETURN DIA10A1A.405
END IF DIA10A1A.406
END IF DIA10A1A.407
DIA10A1A.408
C END IF FOR V DIAGNOSTICS DIA10A1A.409
END IF DIA10A1A.410
DIA10A1A.411
CL ------------------------------------------------------------------- DIA10A1A.412
CL SECTION 3. DIAGNOSTICS NOT INVOLVING MEAN HORIZONTAL VELOCITIES. DIA10A1A.413
CL ------------------------------------------------------------------- DIA10A1A.414
DIA10A1A.415
C -------------------------------------------------------------------- DIA10A1A.416
CL SECTION 3.1 EFFECTIVE EARTH RADIUS AT MODEL LEVELS. DIA10A1A.417
C -------------------------------------------------------------------- DIA10A1A.418
DIA10A1A.419
IF (L_EFF_RADIUS) THEN DIA10A1A.420
CALL COPYDIAG_3D (STASHWORK(LOC_EFF_RADIUS),RS,FIRST_POINT, DIA10A1A.421
& LAST_POINT,P_FIELD,ROW_LENGTH,P_LEVELS, DIA10A1A.422
& STLIST(1,INDEX_EFF_RADIUS),LEN_STLIST, DIA10A1A.423
& STASH_LEVELS, DIA10A1A.424
& NUM_STASH_LEVELS+1, GPB1F403.1027
& im_ident,10,203, GPB1F403.1028
*CALL ARGPPX GPB1F403.1029
& ICODE,CMESSAGE) GPB1F403.1030
IF(ICODE.GT.0) THEN DIA10A1A.426
RETURN DIA10A1A.427
END IF DIA10A1A.428
END IF DIA10A1A.429
DIA10A1A.430
C -------------------------------------------------------------------- DIA10A1A.431
CL SECTION 3.2 MEAN ETADOT IN ADJUSTMENT STEPS. DIA10A1A.432
C -------------------------------------------------------------------- DIA10A1A.433
DIA10A1A.434
IF (L_ETADOT) THEN DIA10A1A.435
CALL COPYDIAG_3D(STASHWORK(LOC_ETADOT),ETADOT,FIRST_POINT, DIA10A1A.436
& LAST_POINT,P_FIELD,ROW_LENGTH,P_LEVELS, DIA10A1A.437
& STLIST(1,INDEX_ETADOT),LEN_STLIST, DIA10A1A.438
& STASH_LEVELS, DIA10A1A.439
& NUM_STASH_LEVELS+1, GPB1F403.1031
& im_ident,10,204, GPB1F403.1032
*CALL ARGPPX GPB1F403.1033
& ICODE,CMESSAGE) GPB1F403.1034
IF(ICODE.GT.0) THEN DIA10A1A.441
RETURN DIA10A1A.442
END IF DIA10A1A.443
DIA10A1A.444
CL CALL SET_LEVELS_LIST TO DETERMINE WHICH LEVELS OUTPUT ARRAY WAS DIA10A1A.445
CL REQUESTED ON. DIA10A1A.446
DIA10A1A.447
CALL SET_LEVELS_LIST(P_LEVELS,LEN_STLIST, DIA10A1A.448
& STLIST(1,INDEX_ETADOT), DIA10A1A.449
& LIST,STASH_LEVELS,NUM_STASH_LEVELS+1,ICODE, DIA10A1A.450
& CMESSAGE) DIA10A1A.451
K=0 DIA10A1A.452
CL CHECK TO SEE IF LEVEL 1 WAS REQUESTED AS THIS NEEDS SPECIAL TREATMENT DIA10A1A.453
IF(LIST(1)) THEN DIA10A1A.454
K=K+1 DIA10A1A.455
*IF DEF,STRAT DIA10A1A.456
CL IF STRATOSPHERIC MODEL THEN LEVEL 1 HOLDS ETADOT VALUES SO DIA10A1A.457
CL MASS-WEIGHTING NEEDS REMOVING. DIA10A1A.458
C SCALAR HOLDS DELTA ETA / RADIUS OF EARTH SQUARED. DIA10A1A.459
SCALAR= ((AK(1)-AKH(1))/PREF+ DIA10A1A.460
& (BK(1)-BKH(1)))/(A*A) DIA10A1A.461
C SCALAR_A HOLDS DIFFERENCE IN AK PART OF DP DIA10A1A.462
SCALAR_A= AK(1)-AKH(1) DIA10A1A.463
C SCALAR_B HOLDS DIFFERENCE IN BK PART OF DP DIA10A1A.464
SCALAR_B= BK(1)-BKH(1) DIA10A1A.465
C REMOVE A*A*DP/DETA FROM ETADOT FIELD. DIA10A1A.466
DO I=FIRST_P-1,LAST_P-1 GPB1F403.1035
STASHWORK(LOC_ETADOT+I) = STASHWORK(LOC_ETADOT+I)*SCALAR DIA10A1A.468
& /(SCALAR_A+SCALAR_B*PSTAR(I+1)) DIA10A1A.469
END DO DIA10A1A.470
*ELSE DIA10A1A.471
CL IF NOT STRATOSPHERIC MODEL THEN SET OUTPUT ETADOT FIELD TO ZERO. DIA10A1A.472
DO I=0,P_FIELD-1 DIA10A1A.473
STASHWORK(LOC_ETADOT+I) = 0. DIA10A1A.474
END DO DIA10A1A.475
*ENDIF DIA10A1A.476
END IF DIA10A1A.477
CL NOW REMOVE MASS-WEIGHT FROM ALL OTHER REQUESTED LEVELS. DIA10A1A.478
DO LEVEL=2,P_LEVELS DIA10A1A.479
IF(LIST(LEVEL)) THEN DIA10A1A.480
C SCALAR HOLDS DELTA ETA / RADIUS OF EARTH SQUARED. DIA10A1A.481
SCALAR=((AK(LEVEL)-AK(LEVEL-1))/PREF DIA10A1A.482
& +(BK(LEVEL)-BK(LEVEL-1))) DIA10A1A.483
& /(A*A) DIA10A1A.484
C SCALAR_A HOLDS DIFFERENCE IN AK PART OF DP DIA10A1A.485
SCALAR_A= AK(LEVEL)-AK(LEVEL-1) DIA10A1A.486
C SCALAR_B HOLDS DIFFERENCE IN BK PART OF DP DIA10A1A.487
SCALAR_B= BK(LEVEL)-BK(LEVEL-1) DIA10A1A.488
C REMOVE A*A*DP/DETA FROM ETADOT FIELD. DIA10A1A.489
DO I=FIRST_P-1,LAST_P-1 GPB1F403.1036
STASHWORK(LOC_ETADOT+K*P_FIELD+I) = DIA10A1A.491
& STASHWORK(LOC_ETADOT+K*P_FIELD+I) DIA10A1A.492
& *SCALAR DIA10A1A.493
& /(SCALAR_A+SCALAR_B*PSTAR(I+1)) DIA10A1A.494
END DO DIA10A1A.495
K=K+1 DIA10A1A.496
END IF DIA10A1A.497
END DO DIA10A1A.498
END IF DIA10A1A.499
DIA10A1A.500
C -------------------------------------------------------------------- DIA10A1A.501
CL SECTION 3.3 SURFACE PRESSURE TENDENCY. DIA10A1A.502
C -------------------------------------------------------------------- DIA10A1A.503
DIA10A1A.504
IF (L_PRESS_TEND) THEN DIA10A1A.505
RECIP_TIMESTEP = 1./ADVECTION_TIMESTEP DIA10A1A.506
DO I=FIRST_P,LAST_P GPB1F403.1037
FIELD(I) = (PSTAR(I) - PSTAR_OLD(I))*RECIP_TIMESTEP DIA10A1A.508
END DO DIA10A1A.509
CALL COPYDIAG(STASHWORK(LOC_PRESS_TEND),FIELD,FIRST_POINT, DIA10A1A.510
& LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1038
& im_ident,10,205, GPB1F403.1039
*CALL ARGPPX GPB1F403.1040
& ICODE,CMESSAGE) GPB1F403.1041
GPB1F403.1042
IF (ICODE .GT. 0) RETURN GPB1F403.1043
ENDIF DIA10A1A.512
DIA10A1A.513
C -------------------------------------------------------------------- DIA10A1A.514
CL SECTION 3.4 GEOPOTENTIAL. DIA10A1A.515
CL THIS DIAGNOSTIC ACCUMULATED IN ADJ_CTL OVER ALL P_LEVELS DIA10A1A.516
CL USED IN DIAG10_B TO CALCULATE ENERGY. DIA10A1A.517
CL ALREADY HELD IN STASHWORK. DIA10A1A.518
C -------------------------------------------------------------------- DIA10A1A.519
DIA10A1A.520
CL END OF ROUTINE DIAG10_A DIA10A1A.521
DIA10A1A.522
RETURN DIA10A1A.523
END DIA10A1A.524
*ENDIF DIA10A1A.525
*ENDIF AJC0F405.285