SUBROUTINE LSPP_CTL(CLOUD_FRACTION,LS_RAIN,LS_SNOW, 1,38AYY1F404.25
& PDF_QC_OR_CF_LIQ,PDF_BS_OR_CF_ICE,P_FIELDDA,Q_LEVELSDA,INT4, AYY1F404.26
& QTOT_DIM1,QTOT_DIM2, AWO4F405.25
& LSPICE_DIM1,LSPICE_DIM2, ADM0F405.37
*CALL ARGSIZE 
@DYALLOC.2219
*CALL ARGD1 @DYALLOC.2220
*CALL ARGDUMA @DYALLOC.2221
*CALL ARGDUMO @DYALLOC.2222
*CALL ARGDUMW GKR1F401.223
*CALL ARGSTS @DYALLOC.2223
*CALL ARGPTRA @DYALLOC.2224
*CALL ARGPTRO @DYALLOC.2225
*CALL ARGCONA @DYALLOC.2226
*CALL ARGPPX GKR0F305.946
*CALL ARGFLDPT APBCF401.3
& ICODE,CMESSAGE) @DYALLOC.2227
LSPP_CT1.27
IMPLICIT NONE LSPP_CT1.28
@DYALLOC.2228
*CALL CMAXSIZE @DYALLOC.2229
*CALL CSUBMODL GSS1F305.931
*CALL TYPSIZE @DYALLOC.2230
*CALL TYPD1 @DYALLOC.2231
*CALL TYPDUMA @DYALLOC.2232
*CALL TYPDUMO @DYALLOC.2233
*CALL TYPDUMW GKR1F401.224
*CALL TYPSTS @DYALLOC.2234
*CALL TYPPTRA @DYALLOC.2235
*CALL TYPPTRO @DYALLOC.2236
*CALL TYPCONA @DYALLOC.2237
*CALL PPXLOOK GKR0F305.947
*CALL TYPFLDPT APBCF401.4
LSPP_CT1.29
INTEGER LSPP_CT1.30
& INT4, ! Dummy variable for STASH_MAXLEN(4) LSPP_CT1.31
& ICODE, ! Return code : 0 Normal Exit LSPP_CT1.32
C ! : >0 Error LSPP_CT1.33
& P_FIELDDA, ! Extra copy of P_FIELD for dynamic alloc @DYALLOC.2238
& Q_LEVELSDA ! and Q_LEVELS @DYALLOC.2239
& ,QTOT_DIM1,QTOT_DIM2 ! Dimensions of QTOTAL array AWO4F405.26
& ,LSPICE_DIM1,LSPICE_DIM2 ! Required for ADM0F405.39
! diagnostic array dimensions ADM0F405.40
! LSPICE_DIM1=P_FIELDDA if diagnostics 222,223,224 or 225 chosen, ADM0F405.41
! 1 otherwise. ADM0F405.42
! LSPICE_DIM2=Q_LEVELSDA if diagnostics 222,223,224 or 225 chosen, ADM0F405.43
! 1 otherwise. ADM0F405.44
LSPP_CT1.36
REAL LSPP_CT1.37
& CLOUD_FRACTION(P_FIELDDA,Q_LEVELSDA), @DYALLOC.2240
& LS_RAIN(P_FIELDDA), @DYALLOC.2241
& LS_SNOW(P_FIELDDA), ! OUT AYY2F400.192
& PDF_QC_OR_CF_LIQ(P_FIELDDA,Q_LEVELSDA), ! IN AYY1F404.27
& PDF_BS_OR_CF_ICE(P_FIELDDA,Q_LEVELSDA) ! IN AYY1F404.28
LSPP_CT1.41
CHARACTER*80 TS150793.104
& CMESSAGE ! Error message if return code >0 LSPP_CT1.43
LSPP_CT1.44
*IF DEF,MPP APB1F305.340
! Parameters and Common blocks APB1F305.341
*CALL PARVARS APB1F305.342
*ENDIF APB1F305.343
GSS1F305.932
*CALL CHSUNITS RS030293.208
*CALL CCONTROL LSPP_CT1.46
*CALL C_LHEAT GSS1F304.761
*CALL C_0_DG_C ADM0F405.38
*CALL CRUNTIMC ADR1F305.104
*CALL CTIME ADR1F305.105
LSPP_CT1.53
CL External subroutines called LSPP_CT1.54
LSPP_CT1.55
EXTERNAL LSPP_CT1.56
& TIMER,GLUE_LSPP,COPYDIAG,STASH,QSAT,SET_LEVELS_LIST AYY2F400.195
& ,VISBTY,QSAT_WAT RB200193.61
& ,FLUX_DIAG GSS1F304.762
& ,RAINOUT AWO4F405.27
LSPP_CT1.61
CL Dynamically allocated area for stash processing LSPP_CT1.62
LSPP_CT1.63
REAL LSPP_CT1.64
& STASHWORK(INT4) LSPP_CT1.65
LSPP_CT1.66
REAL LSPP_CT1.67
& P_WORK(P_FIELDDA),QS_WORK(P_FIELDDA) @DYALLOC.2243
LSPP_CT1.69
C Local variables LSPP_CT1.70
LSPP_CT1.71
INTEGER LSPP_CT1.72
& I,J,LEVEL, LSPP_CT1.73
& ROWS, LSPP_CT1.74
& FIRST_POINT, LSPP_CT1.75
& LAST_POINT, LSPP_CT1.76
& POINTS LSPP_CT1.77
& ,IM_IDENT ! internal model identifier GRB4F305.279
& ,IM_INDEX ! internal model index for STASH arrays GRB4F305.280
LSPP_CT1.78
REAL QTOTAL(QTOT_DIM1,QTOT_DIM2) ! TOTAL CONDENSED WATER FOR AWO4F405.28
! USE WITH SULPHUR CYCLE & SOOT ADM0F405.45
& ,LS_RAIN3D(LSPICE_DIM1,LSPICE_DIM2) ! Rain rate out of each ADM0F405.46
! level for diagnostic ADM0F405.47
& ,LS_SNOW3D(LSPICE_DIM1,LSPICE_DIM2) ! Snow rate out of each ADM0F405.48
! level for diagnostic ADM0F405.49
REAL RNOUT_SO4DIS(P_FIELDDA) ! column total rained-out SO4DIS AWO4F401.4
REAL RNOUT_SOOT(P_FIELDDA) ! flux of rained-out soot. AWO4F405.269
! AWO4F401.5
REAL LSCAV_SO2(P_FIELDDA) ! column total scavenged SO2 AWO4F401.6
& ,LSCAV_NH3(P_FIELDDA) ! column total scavenged NH3 AWO4F405.29
& ,LSCAV_SO4AIT(P_FIELDDA) ! column total scavenged SO4_AIKEN AWO4F401.7
& ,LSCAV_SO4ACC(P_FIELDDA) ! column total scavenged SO4_ACCU AWO4F401.8
& ,LSCAV_SO4DIS(P_FIELDDA) ! column total scavenged SO4_DISS AWO4F401.9
& ,LSCAV_AGEDSOOT(P_FIELDDA) ! column tot scavenged aged soot AWO4F405.228
! AWO4F401.10
LOGICAL LSPP_CT1.79
& LIST(Q_LEVELSDA) ! Levels list for diagnostics @DYALLOC.2244
LSPP_CT1.81
CL LSPP_CT1.82
CL--- SECTION 4 --- STRATIFORM PRECIPITATION ---------- LSPP_CT1.83
CL LSPP_CT1.84
GRB4F305.281
C Set up internal model identifier and STASH index GRB4F305.282
im_ident = atmos_im GRB4F305.283
im_index = internal_model_index(im_ident) GRB4F305.284
LSPP_CT1.85
! Set up grid pointers APBCF401.5
FIRST_POINT = START_POINT_INC_HALO APBCF401.6
LAST_POINT = END_P_POINT_INC_HALO APBCF401.7
POINTS = LAST_POINT-FIRST_POINT+1 APBCF401.8
ROWS = POINTS/ROW_LENGTH APBCF401.9
LSPP_CT1.90
! IF USING SULPHUR CYCLE OR SOOT, STORE THE TOTAL AWO4F405.270
! CONDENSED WATER PRIOR TO LARGE-SCALE PRECIPITATION. AWO4F401.12
! AWO4F401.13
IF (L_SULPC_SO2 .OR. L_SOOT) THEN AWO4F405.271
DO LEVEL = 1,Q_LEVELS AWO4F401.15
DO I = FIRST_POINT,LAST_POINT AWO4F401.16
QTOTAL(I,LEVEL) = D1(JQCF(LEVEL) + I - 1) AWO4F401.17
& + D1(JQCL(LEVEL) + I - 1) AWO4F401.18
ENDDO AWO4F401.19
ENDDO AWO4F401.20
ENDIF AWO4F401.21
! AWO4F401.22
IF(LTIMER) THEN LSPP_CT1.91
CALL TIMER('LS_PPN ',3) LSPP_CT1.92
END IF LSPP_CT1.93
LSPP_CT1.94
CMESSAGE=' ' LSPP_CT1.95
ICODE=0 LSPP_CT1.96
LSPP_CT1.97
C Initialise output arrays to zero. LSPP_CT1.98
LSPP_CT1.99
DO I=1,P_FIELD LSPP_CT1.100
LS_RAIN(I) = 0.0 LSPP_CT1.101
LS_SNOW(I) = 0.0 LSPP_CT1.102
END DO LSPP_CT1.103
CALL GLUE_LSPP( AYY2F400.196
C Input data not changed on output LSPP_CT1.106
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),CLOUD_FRACTION, LSPP_CT1.108
& A_LEVDEPC(JDELTA_AK), LSPP_CT1.109
& A_LEVDEPC(JDELTA_BK),D1(JPSTAR),SECS_PER_STEPim(atmos_im), ADR1F305.106
& D1(JLAND),CW_SEA,CW_LAND, ADR1F305.107
& PDF_QC_OR_CF_LIQ,PDF_BS_OR_CF_ICE, AYY1F404.29
& RHCRIT, ADM3F404.2
& D1(JRHC(1)), L_RHCPT, ASK1F405.229
C Size and control data LSPP_CT1.113
& Q_LEVELS,P_FIELD,POINTS,FIRST_POINT,LSPICE_DIM1,LSPICE_DIM2, ADM0F405.50
& A_INTHD(13), ! Aerosol levels = Boundary layer levels ADM0F405.51
C Input data changed on output LSPP_CT1.117
& D1(JQ(1)),D1(JQCF(1)),D1(JQCL(1)),D1(JTHETA(1)), LSPP_CT1.119
& D1(JSO2(1)),L_SULPC_SO2, AWO4F401.23
& D1(JNH3(1)),L_SULPC_NH3, AWO4F405.30
& D1(JSO4_AITKEN(1)),D1(JSO4_ACCU(1)),D1(JSO4_DISS(1)), AWO4F401.24
& D1(JSOOT_AGD(1)), !INOUT AWO4F405.229
& L_SOOT, AWO4F405.230
& D1(JMURK(1)),L_MURK_SOURCE, APC3F304.88
C Output data LSPP_CT1.121
& LS_RAIN,LS_SNOW,LS_RAIN3D,LS_SNOW3D, ADM0F405.52
& LSCAV_SO2,LSCAV_SO4AIT,LSCAV_SO4ACC,LSCAV_SO4DIS, AWO4F401.25
& LSCAV_NH3, AWO4F405.31
! AWO4F401.26
& LSCAV_AGEDSOOT, !OUT AWO4F405.231
& ICODE) APC3F304.90
LSPP_CT1.124
IF(LTIMER) THEN LSPP_CT1.125
CALL TIMER('LS_PPN ',4) LSPP_CT1.126
END IF LSPP_CT1.127
LSPP_CT1.128
LSPP_CT1.129
IF(ICODE.GT.0) THEN LSPP_CT1.130
CMESSAGE=' LSPP_CTL : Error in LS_PPN ' LSPP_CT1.131
RETURN LSPP_CT1.132
ENDIF LSPP_CT1.133
! IF SULPHUR CYCLE MODELLING IS BEING USED, CALL THE AWO4F401.27
! SUBROUTINE RAINOUT TO REMOVE DISSOLVED SULPHATE. AWO4F405.32
! AWO4F401.29
IF (L_SULPC_SO2) THEN AWO4F401.30
! AWO4F401.31
CALL RAINOUT(D1(JQCF(1)),D1(JQCL(1)),QTOTAL, AWO4F405.33
& LS_RAIN,LS_SNOW, AWO1F403.6
& D1(JSO4_DISS(1)),FIRST_POINT,LAST_POINT, AWO4F401.33
& P_FIELD,Q_LEVELS,RNOUT_SO4DIS, AWO1F403.7
& A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK),D1(JPSTAR)) AWO1F403.8
! AWO4F401.35
ENDIF AWO4F401.36
LSPP_CT1.134
! AWO4F405.272
! If soot is being used, call RAINOUT to AWO4F405.273
! remove soot in cloud water. AWO4F405.274
! AWO4F405.275
IF (L_SOOT) THEN AWO4F405.276
CALL RAINOUT( AWO4F405.277
& D1(JQCF(1)), AWO4F405.278
& D1(JQCL(1)), AWO4F405.279
& QTOTAL, AWO4F405.280
& LS_RAIN, AWO4F405.281
& LS_SNOW, AWO4F405.282
& D1(JSOOT_CLD(1)), AWO4F405.283
& FIRST_POINT, AWO4F405.284
& LAST_POINT, AWO4F405.285
& P_FIELD, AWO4F405.286
& Q_LEVELS, AWO4F405.287
& RNOUT_SOOT, AWO4F405.288
& A_LEVDEPC(JDELTA_AK), AWO4F405.289
& A_LEVDEPC(JDELTA_BK), AWO4F405.290
& D1(JPSTAR) AWO4F405.291
& ) AWO4F405.292
AWO4F405.293
ENDIF AWO4F405.294
! AWO4F405.295
! AWO4F405.296
IF (LEMCORR) THEN GSS1F304.763
C LSPP_CT1.136
C ADD LARGE-SCALE RAIN AND SNOW AT THE SURFACE TO THE LSPP_CT1.137
C DIABATIC HEATING FOR USE IN THE ENERGY CORRECTION LSPP_CT1.138
C PROCEDURE LSPP_CT1.139
C LSPP_CT1.140
IF (LTIMER) THEN LSPP_CT1.141
CALL TIMER('FLX_DIAG',3) LSPP_CT1.142
END IF LSPP_CT1.143
C LSPP_CT1.144
CALL FLUX_DIAG(LS_RAIN,COS_P_LATITUDE, APB5F401.144
& P_FIELD,FIRST_POINT,POINTS, APB5F401.145
& LC,SECS_PER_STEPim(atmos_im),D1(JNET_FLUX)) GSM3F404.50
CALL FLUX_DIAG(LS_SNOW,COS_P_LATITUDE, APB5F401.147
& P_FIELD,FIRST_POINT,POINTS, APB5F401.148
& (LC+LF),SECS_PER_STEPim(atmos_im),D1(JNET_FLUX)) GSM3F404.51
C LSPP_CT1.151
IF (LTIMER) THEN LSPP_CT1.152
CALL TIMER('FLX_DIAG',4) LSPP_CT1.153
END IF LSPP_CT1.154
C LSPP_CT1.155
END IF ! LEMCORR GSS1F304.764
LSPP_CT1.157
CL Copy diagnostic information to STASHWORK for STASH processing LSPP_CT1.158
LSPP_CT1.159
C Item 201 Large scale rain LSPP_CT1.160
LSPP_CT1.161
IF(SF(201,4)) THEN LSPP_CT1.162
LSPP_CT1.163
CALL COPYDIAG(STASHWORK(si(201,4,im_index)),LS_RAIN, GRB4F305.285
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1201
& im_ident,4,201, GPB1F403.1202
*CALL ARGPPX GPB1F403.1203
& ICODE,CMESSAGE) GPB1F403.1204
GPB1F403.1205
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1206
LSPP_CT1.166
C Code to convert rate to ammount for a given timestep LSPP_CT1.167
LSPP_CT1.168
DO I=1,P_FIELD LSPP_CT1.169
STASHWORK(si(201,4,im_index)+I-1)= GRB4F305.286
& STASHWORK(SI(201,4,im_index)+I-1)*SECS_PER_STEPim(a_im) ADR1F305.110
END DO LSPP_CT1.172
LSPP_CT1.173
END IF LSPP_CT1.174
LSPP_CT1.175
C Item 202 Large scale snow LSPP_CT1.176
LSPP_CT1.177
IF(SF(202,4)) THEN LSPP_CT1.178
LSPP_CT1.179
CALL COPYDIAG(STASHWORK(si(202,4,im_index)),LS_SNOW, GRB4F305.287
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1207
& im_ident,4,202, GPB1F403.1208
*CALL ARGPPX GPB1F403.1209
& ICODE,CMESSAGE) GPB1F403.1210
GPB1F403.1211
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1212
LSPP_CT1.182
DO I=1,P_FIELD LSPP_CT1.183
STASHWORK(si(202,4,im_index)+I-1)= GRB4F305.288
& STASHWORK(SI(202,4,im_index)+I-1)*SECS_PER_STEPim(a_im) ADR1F305.111
END DO LSPP_CT1.186
LSPP_CT1.187
END IF LSPP_CT1.188
LSPP_CT1.189
C Item 203 Large scale rain LSPP_CT1.190
LSPP_CT1.191
IF(SF(203,4)) THEN LSPP_CT1.192
LSPP_CT1.193
CALL COPYDIAG(STASHWORK(si(203,4,im_index)),LS_RAIN, GRB4F305.289
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1213
& im_ident,4,203, GPB1F403.1214
*CALL ARGPPX GPB1F403.1215
& ICODE,CMESSAGE) GPB1F403.1216
GPB1F403.1217
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1218
LSPP_CT1.196
END IF LSPP_CT1.197
LSPP_CT1.198
C Item 204 Large scale snow LSPP_CT1.199
LSPP_CT1.200
IF(SF(204,4)) THEN LSPP_CT1.201
LSPP_CT1.202
CALL COPYDIAG(STASHWORK(si(204,4,im_index)),LS_SNOW, GRB4F305.290
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1219
& im_ident,4,204, GPB1F403.1220
*CALL ARGPPX GPB1F403.1221
& ICODE,CMESSAGE) GPB1F403.1222
GPB1F403.1223
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1224
LSPP_CT1.205
END IF LSPP_CT1.206
LSPP_CT1.207
LSPP_CT1.208
LSPP_CT1.209
IF(SF(205,4)) THEN LSPP_CT1.210
LSPP_CT1.211
CL Copy Cloud water to STASHWORK LSPP_CT1.212
LSPP_CT1.213
CALL COPYDIAG_3D(STASHWORK(si(205,4,im_index)),D1(JQCL(1)), GRB4F305.291
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, LSPP_CT1.215
& P_LEVELS,STLIST(1,STINDEX(1,205,4,im_index)),LEN_STLIST, GRB4F305.292
& STASH_LEVELS,NUM_STASH_LEVELS+1, GPB1F403.1225
& im_ident,4,205, GPB1F403.1226
*CALL ARGPPX GPB1F403.1227
& ICODE,CMESSAGE) GPB1F403.1228
LSPP_CT1.218
IF (ICODE.GT.0) THEN LSPP_CT1.219
CMESSAGE="LSPP_CTL : ERROR IN COPYDIAG_3D(cloud water)" LSPP_CT1.220
RETURN LSPP_CT1.221
END IF LSPP_CT1.222
LSPP_CT1.223
END IF LSPP_CT1.224
LSPP_CT1.225
IF(SF(206,4)) THEN LSPP_CT1.226
LSPP_CT1.227
CL Copy Cloud ice to STASHWORK LSPP_CT1.228
LSPP_CT1.229
CALL COPYDIAG_3D(STASHWORK(si(206,4,im_index)),D1(JQCF(1)), GRB4F305.293
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, LSPP_CT1.231
& P_LEVELS,STLIST(1,STINDEX(1,206,4,im_index)),LEN_STLIST, GRB4F305.294
& STASH_LEVELS,NUM_STASH_LEVELS+1, GPB1F403.1229
& im_ident,4,206, GPB1F403.1230
*CALL ARGPPX GPB1F403.1231
& ICODE,CMESSAGE) GPB1F403.1232
LSPP_CT1.234
IF (ICODE.GT.0) THEN LSPP_CT1.235
CMESSAGE="LSPP_CTL : ERROR IN COPYDIAG_3D(cloud ice)" LSPP_CT1.236
RETURN LSPP_CT1.237
END IF LSPP_CT1.238
LSPP_CT1.239
END IF LSPP_CT1.240
LSPP_CT1.241
C Item 207 Relative Humidity LSPP_CT1.242
LSPP_CT1.243
IF(SF(207,4)) THEN LSPP_CT1.244
CALL SET_LEVELS_LIST(Q_LEVELS,LEN_STLIST, LSPP_CT1.245
& STLIST(1,STINDEX(1,207,4,im_index)), GRB4F305.295
& LIST,STASH_LEVELS,NUM_STASH_LEVELS+1,ICODE,CMESSAGE) LSPP_CT1.247
IF (ICODE.GT.0) RETURN LSPP_CT1.248
LSPP_CT1.249
LEVEL=0 LSPP_CT1.250
DO J=1,Q_LEVELS LSPP_CT1.251
IF(LIST(J)) THEN LSPP_CT1.252
LEVEL=LEVEL+1 LSPP_CT1.253
DO I=1,P_FIELD LSPP_CT1.254
P_WORK(I)=D1(JPSTAR+I-1)*A_LEVDEPC(JBK+J-1)+ LSPP_CT1.255
& A_LEVDEPC(JAK+J-1) LSPP_CT1.256
END DO LSPP_CT1.257
CALL QSAT(QS_WORK,D1(JTHETA(J)),P_WORK,P_FIELD) LSPP_CT1.258
LSPP_CT1.259
DO I=1,P_FIELD LSPP_CT1.260
STASHWORK(si(207,4,im_index)+(LEVEL-1)*P_FIELD+I-1)= GRB4F305.296
& D1(JQ(J)+I-1)/QS_WORK(I)*100. LSPP_CT1.262
END DO LSPP_CT1.263
END IF RB200193.62
END DO RB200193.63
END IF RB200193.64
RB200193.65
C Item 208 Visibility RB200193.66
RB200193.67
IF(SF(208,4)) THEN RB200193.68
CALL SET_LEVELS_LIST(Q_LEVELS,LEN_STLIST, RB200193.69
& STLIST(1,STINDEX(1,208,4,im_index)), GRB4F305.297
& LIST,STASH_LEVELS,NUM_STASH_LEVELS+1,ICODE,CMESSAGE) RB200193.71
IF (ICODE.GT.0) RETURN RB200193.72
RB200193.73
LEVEL=0 RB200193.74
DO J=1,Q_LEVELS RB200193.75
IF(LIST(J)) THEN RB200193.76
LEVEL=LEVEL+1 RB200193.77
DO I=1,P_FIELD RB200193.78
P_WORK(I)=D1(JPSTAR+I-1)*A_LEVDEPC(JBK+J-1)+ RB200193.79
& A_LEVDEPC(JAK+J-1) RB200193.80
END DO RB200193.81
CALL QSAT_WAT(QS_WORK,D1(JTHETA(J)),P_WORK,P_FIELD) RB200193.82
C Change QS_WORK from QSAT(water) to RH RB200193.83
DO I = 1,P_FIELD RB200193.84
QS_WORK(I) = D1(JQ(J)+I-1)/QS_WORK(I)*100.0 RB200193.85
END DO RB200193.86
RB200193.87
CALL VISBTY(A_LEVDEPC(JAK+J-1),A_LEVDEPC(JBK+J-1), APC0F405.112
& D1(JPSTAR),D1(JTHETA(J)),D1(JQ(J)), APC0F405.113
& D1(JQCL(J)),D1(JQCF(J)), APC0F405.114
& D1(JMURK(LEVEL)), APC0F405.115
& 0.5,RHCRIT(J),L_MURK, ! 0.5 for median vis APC0F405.116
& P_FIELD, APC3F304.93
& STASHWORK(si(208,4,im_index)+(LEVEL-1)*P_FIELD)) GRB4F305.298
END IF LSPP_CT1.264
END DO LSPP_CT1.265
END IF LSPP_CT1.266
LSPP_CT1.267
! AWO4F401.37
IF (L_SULPC_SO2) THEN AWO4F401.38
! AWO4F401.39
! Write LSPSCVGD_TRACER to STASHWORK array . AWO4F401.40
! AWO4F401.41
IF(SF(211,4)) THEN ! write scavenged SO2 to STASH AWO4F401.42
CALL COPYDIAG(STASHWORK(SI(211,4,im_index)),LSCAV_SO2, AWO4F401.43
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1233
& im_ident,4,211, GPB1F403.1234
*CALL ARGPPX GPB1F403.1235
& ICODE,CMESSAGE) GPB1F403.1236
GPB1F403.1237
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1238
ENDIF AWO4F401.45
! AWO4F405.34
IF(SF(216,4)) THEN AWO4F405.35
CALL COPYDIAG(STASHWORK(SI(216,4,im_index)),LSCAV_SO2, AWO4F405.36
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, AWO4F405.37
& im_ident,4,216, AWO4F405.38
*CALL ARGPPX AWO4F405.39
& ICODE,CMESSAGE) AWO4F405.40
AWO4F405.41
IF (ICODE .GT. 0) GOTO 9999 AWO4F405.42
! AWO4F405.43
! Convert amount scavenged per tstep to flux per sec AWO4F405.44
DO I=1,P_FIELD AWO4F405.45
STASHWORK(SI(216,4,im_index)+I-1)= AWO4F405.46
& STASHWORK(SI(216,4,im_index)+I-1)/SECS_PER_STEPim(atmos_im) AWO4F405.47
END DO AWO4F405.48
ENDIF AWO4F405.49
! AWO4F405.50
! AWO4F401.46
! AWO4F405.51
IF (L_SULPC_NH3) THEN AWO4F405.52
! AWO4F405.53
IF(SF(215,4)) THEN ! write scavenged NH3 to STASH AWO4F405.54
CALL COPYDIAG(STASHWORK(SI(215,4,im_index)),LSCAV_NH3, AWO4F405.55
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, AWO4F405.56
& im_ident,4,215, AWO4F405.57
*CALL ARGPPX AWO4F405.58
& ICODE,CMESSAGE) AWO4F405.59
AWO4F405.60
IF (ICODE .GT. 0) GOTO 9999 AWO4F405.61
! AWO4F405.62
! Convert amount scavenged per tstep to flux per sec AWO4F405.63
DO I=1,P_FIELD AWO4F405.64
STASHWORK(SI(215,4,im_index)+I-1)= AWO4F405.65
& STASHWORK(SI(215,4,im_index)+I-1)/SECS_PER_STEPim(atmos_im) AWO4F405.66
END DO AWO4F405.67
ENDIF AWO4F405.68
! AWO4F405.69
END IF ! end L_SULPC_NH3 condition AWO4F405.70
IF(SF(212,4)) THEN ! write scavenged SO4_AIT to STASH AWO4F401.47
CALL COPYDIAG(STASHWORK(SI(212,4,im_index)),LSCAV_SO4AIT, AWO4F401.48
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1239
& im_ident,4,212, GPB1F403.1240
*CALL ARGPPX GPB1F403.1241
& ICODE,CMESSAGE) GPB1F403.1242
GPB1F403.1243
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1244
ENDIF AWO4F401.50
! AWO4F405.71
IF(SF(217,4)) THEN AWO4F405.72
CALL COPYDIAG(STASHWORK(SI(217,4,im_index)),LSCAV_SO4AIT, AWO4F405.73
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, AWO4F405.74
& im_ident,4,217, AWO4F405.75
*CALL ARGPPX AWO4F405.76
& ICODE,CMESSAGE) AWO4F405.77
AWO4F405.78
IF (ICODE .GT. 0) GOTO 9999 AWO4F405.79
! AWO4F405.80
! Convert amount scavenged per tstep to flux per sec AWO4F405.81
DO I=1,P_FIELD AWO4F405.82
STASHWORK(SI(217,4,im_index)+I-1)= AWO4F405.83
& STASHWORK(SI(217,4,im_index)+I-1)/SECS_PER_STEPim(atmos_im) AWO4F405.84
END DO AWO4F405.85
ENDIF AWO4F405.86
! AWO4F405.87
! AWO4F401.51
IF(SF(213,4)) THEN ! write scavenged SO4_ACC to STASH AWO4F401.52
CALL COPYDIAG(STASHWORK(SI(213,4,im_index)),LSCAV_SO4ACC, AWO4F401.53
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1245
& im_ident,4,213, GPB1F403.1246
*CALL ARGPPX GPB1F403.1247
& ICODE,CMESSAGE) GPB1F403.1248
GPB1F403.1249
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1250
ENDIF AWO4F401.55
! AWO4F405.88
IF(SF(218,4)) THEN AWO4F405.89
CALL COPYDIAG(STASHWORK(SI(218,4,im_index)),LSCAV_SO4ACC, AWO4F405.90
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, AWO4F405.91
& im_ident,4,218, AWO4F405.92
*CALL ARGPPX AWO4F405.93
& ICODE,CMESSAGE) AWO4F405.94
AWO4F405.95
IF (ICODE .GT. 0) GOTO 9999 AWO4F405.96
! AWO4F405.97
! Convert amount scavenged per tstep to flux per sec AWO4F405.98
DO I=1,P_FIELD AWO4F405.99
STASHWORK(SI(218,4,im_index)+I-1)= AWO4F405.100
& STASHWORK(SI(218,4,im_index)+I-1)/SECS_PER_STEPim(atmos_im) AWO4F405.101
END DO AWO4F405.102
ENDIF AWO4F405.103
! AWO4F405.104
! AWO4F401.56
IF(SF(214,4)) THEN ! write scavenged SO4_DIS to STASH AWO4F401.57
! AWO4F401.58
! First add RNOUT_SO4DIS and LSCAV_SO4DIS AWO4F401.59
DO I=FIRST_POINT,LAST_POINT AWO4F401.60
LSCAV_SO4DIS(I) = LSCAV_SO4DIS(I)+RNOUT_SO4DIS(I) AWO4F401.61
END DO AWO4F401.62
! AWO4F401.63
CALL COPYDIAG(STASHWORK(SI(214,4,im_index)),LSCAV_SO4DIS, AWO4F401.64
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1251
& im_ident,4,214, GPB1F403.1252
*CALL ARGPPX GPB1F403.1253
& ICODE,CMESSAGE) GPB1F403.1254
GPB1F403.1255
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1256
ENDIF AWO4F401.66
! AWO4F405.105
IF(SF(219,4)) THEN AWO4F405.106
CALL COPYDIAG(STASHWORK(SI(219,4,im_index)),LSCAV_SO4DIS, AWO4F405.107
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, AWO4F405.108
& im_ident,4,219, AWO4F405.109
*CALL ARGPPX AWO4F405.110
& ICODE,CMESSAGE) AWO4F405.111
AWO4F405.112
IF (ICODE .GT. 0) GOTO 9999 AWO4F405.113
! AWO4F405.114
! Convert amount scavenged per tstep to flux per sec AWO4F405.115
DO I=1,P_FIELD AWO4F405.116
STASHWORK(SI(219,4,im_index)+I-1)= AWO4F405.117
& STASHWORK(SI(219,4,im_index)+I-1)/SECS_PER_STEPim(atmos_im) AWO4F405.118
END DO AWO4F405.119
ENDIF AWO4F405.120
! AWO4F405.121
! AWO4F401.67
END IF ! End L_SULPC_SO2 condition AWO4F401.68
! Convert units of soot rainout and washout deposition fluxes AWO4F405.232
! from kg/m2/ts to kg/m2/s. AWO4F405.233
AWO4F405.234
IF (L_SOOT) THEN AWO4F405.235
DO I=FIRST_POINT,LAST_POINT AWO4F405.236
RNOUT_SOOT(I) = RNOUT_SOOT(I)/SECS_PER_STEPim(atmos_im) AWO4F405.237
END DO AWO4F405.238
! AWO4F405.239
DO I=FIRST_POINT,LAST_POINT AWO4F405.240
LSCAV_AGEDSOOT(I) = LSCAV_AGEDSOOT(I)/ AWO4F405.241
& SECS_PER_STEPim(atmos_im) AWO4F405.242
END DO AWO4F405.243
AWO4F405.244
! AWO4F405.245
! Write rainout flux to STASH AWO4F405.246
IF(SF(220,4)) THEN ! Rainout flux of aged soot AWO4F405.247
CALL COPYDIAG(STASHWORK(SI(220,4,im_index)),RNOUT_SOOT, AWO4F405.248
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, AWO4F405.249
& im_ident,4,220, AWO4F405.250
*CALL ARGPPX AWO4F405.251
& ICODE,CMESSAGE) AWO4F405.252
IF (ICODE.GT.0) RETURN AWO4F405.253
ENDIF AWO4F405.254
AWO4F405.255
! Write washout flux to STASH AWO4F405.256
IF(SF(221,4)) THEN ! Washout (below cloud scavenging) flux AWO4F405.257
! of aged soot AWO4F405.258
CALL COPYDIAG(STASHWORK(SI(221,4,im_index)),LSCAV_AGEDSOOT, AWO4F405.259
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, AWO4F405.260
& im_ident,4,221, AWO4F405.261
*CALL ARGPPX AWO4F405.262
& ICODE,CMESSAGE) AWO4F405.263
IF (ICODE.GT.0) RETURN AWO4F405.264
ENDIF AWO4F405.265
ENDIF ! L_SOOT AWO4F405.266
! AWO4F405.267
! AWO4F405.268
! ADM0F405.53
IF(SF(222,4)) THEN ADM0F405.54
! ADM0F405.55
! Copy 3D field of rain rate out of layer (kg/m2/s) to STASHWORK ADM0F405.56
! ADM0F405.57
CALL COPYDIAG_3D(STASHWORK(si(222,4,im_index)),LS_RAIN3D, ADM0F405.58
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ADM0F405.59
& P_LEVELS,STLIST(1,STINDEX(1,222,4,im_index)),LEN_STLIST, ADM0F405.60
& STASH_LEVELS,NUM_STASH_LEVELS+1, ADM0F405.61
& im_ident,4,222, ADM0F405.62
*CALL ARGPPX ADM0F405.63
& ICODE,CMESSAGE) ADM0F405.64
! ADM0F405.65
IF (ICODE.GT.0) THEN ADM0F405.66
CMESSAGE="LSPP_CTL : ERROR IN COPYDIAG_3D(3D rainrate)" ADM0F405.67
RETURN ADM0F405.68
END IF ADM0F405.69
! ADM0F405.70
END IF ADM0F405.71
! ADM0F405.72
IF(SF(223,4)) THEN ADM0F405.73
! ADM0F405.74
! Copy 3D field of snow rate out of layer (kg/m2/s) to STASHWORK ADM0F405.75
! ADM0F405.76
CALL COPYDIAG_3D(STASHWORK(si(223,4,im_index)),LS_SNOW3D, ADM0F405.77
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ADM0F405.78
& P_LEVELS,STLIST(1,STINDEX(1,223,4,im_index)),LEN_STLIST, ADM0F405.79
& STASH_LEVELS,NUM_STASH_LEVELS+1, ADM0F405.80
& im_ident,4,223, ADM0F405.81
*CALL ARGPPX ADM0F405.82
& ICODE,CMESSAGE) ADM0F405.83
! ADM0F405.84
IF (ICODE.GT.0) THEN ADM0F405.85
CMESSAGE="LSPP_CTL : ERROR IN COPYDIAG_3D(3D snowrate)" ADM0F405.86
RETURN ADM0F405.87
END IF ADM0F405.88
! ADM0F405.89
END IF ADM0F405.90
! ADM0F405.91
! Need to produce diagnsotic 225 before 224 in order to save memory. ADM0F405.92
! ADM0F405.93
IF(SF(225,4)) THEN ADM0F405.94
! ADM0F405.95
! Supercooled 3D rain content. It is equal to ADM0F405.96
! the 3D rainrate at T < 0 and equal to 0 at T > 0 ADM0F405.97
! Alter the array LS_RAIN3D directly ADM0F405.98
! ADM0F405.99
DO J=1,Q_LEVELS ADM0F405.100
DO I=1,P_FIELD ADM0F405.101
IF (D1(JTHETA(J)+I-1) .GE. ZERODEGC) THEN ADM0F405.102
! Warm temperatures ADM0F405.103
LS_RAIN3D(I,J)=0.0 ADM0F405.104
ENDIF ADM0F405.105
ENDDO ADM0F405.106
ENDDO ADM0F405.107
! Copy to stashwork ADM0F405.108
CALL COPYDIAG_3D(STASHWORK(si(225,4,im_index)),LS_RAIN3D, ADM0F405.109
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ADM0F405.110
& P_LEVELS,STLIST(1,STINDEX(1,225,4,im_index)),LEN_STLIST, ADM0F405.111
& STASH_LEVELS,NUM_STASH_LEVELS+1, ADM0F405.112
& im_ident,4,225, ADM0F405.113
*CALL ARGPPX ADM0F405.114
& ICODE,CMESSAGE) ADM0F405.115
! ADM0F405.116
IF (ICODE.GT.0) THEN ADM0F405.117
CMESSAGE="LSPP_CTL : ERROR IN COPYDIAG_3D(Supercooled 3D rain)" ADM0F405.118
RETURN ADM0F405.119
END IF ADM0F405.120
! ADM0F405.121
END IF ADM0F405.122
! ADM0F405.123
IF(SF(224,4)) THEN ADM0F405.124
! ADM0F405.125
! Supercooled liquid water content. It is equal to ADM0F405.126
! the liquid water content at T < 0 and equal to 0 at T > 0 ADM0F405.127
! Use LS_RAIN3D as the array in order to save memory ADM0F405.128
! ADM0F405.129
DO J=1,Q_LEVELS ADM0F405.130
DO I=1,P_FIELD ADM0F405.131
IF (D1(JTHETA(J)+I-1) .LT. ZERODEGC) THEN ADM0F405.132
! Supercooled temperatures ADM0F405.133
LS_RAIN3D(I,J)=D1(JQCL(J)+I-1) ADM0F405.134
ELSE ADM0F405.135
! Warm temperatures ADM0F405.136
LS_RAIN3D(I,J)=0.0 ADM0F405.137
ENDIF ADM0F405.138
ENDDO ADM0F405.139
ENDDO ADM0F405.140
! Copy to stashwork ADM0F405.141
CALL COPYDIAG_3D(STASHWORK(si(224,4,im_index)),LS_RAIN3D, ADM0F405.142
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ADM0F405.143
& P_LEVELS,STLIST(1,STINDEX(1,224,4,im_index)),LEN_STLIST, ADM0F405.144
& STASH_LEVELS,NUM_STASH_LEVELS+1, ADM0F405.145
& im_ident,4,224, ADM0F405.146
*CALL ARGPPX ADM0F405.147
& ICODE,CMESSAGE) ADM0F405.148
! ADM0F405.149
IF (ICODE.GT.0) THEN ADM0F405.150
CMESSAGE="LSPP_CTL : ERROR IN COPYDIAG_3D(Supercooled QCL)" ADM0F405.151
RETURN ADM0F405.152
END IF ADM0F405.153
! ADM0F405.154
END IF ADM0F405.155
! ADM0F405.156
C call STASH to process output LSPP_CT1.268
LSPP_CT1.269
IF(LTIMER) THEN LSPP_CT1.270
CALL TIMER('STASH ',3) LSPP_CT1.271
END IF LSPP_CT1.272
LSPP_CT1.273
CALL STASH(a_sm,a_im,4,STASHWORK, GKR0F305.948
*CALL ARGSIZE @DYALLOC.2246
*CALL ARGD1 @DYALLOC.2247
*CALL ARGDUMA @DYALLOC.2248
*CALL ARGDUMO @DYALLOC.2249
*CALL ARGDUMW GKR1F401.225
*CALL ARGSTS @DYALLOC.2250
*CALL ARGPPX GKR0F305.949
& ICODE,CMESSAGE) @DYALLOC.2254
LSPP_CT1.275
IF(LTIMER) THEN LSPP_CT1.276
CALL TIMER('STASH ',4) LSPP_CT1.277
END IF LSPP_CT1.278
LSPP_CT1.279
9999 CONTINUE GPB1F403.1257
RETURN LSPP_CT1.280
END LSPP_CT1.281
LSPP_CT1.282
C ----------------------------------------------------- LSPP_CT1.283
LSPP_CT1.284
*ENDIF LSPP_CT1.285