SUBROUTINE BL_CTL(CLOUD_FRACTION,SNOW_SUBLIMATION,SNOWMELT, 1,151AJS1F401.217
& CANOPY_EVAPORATION,EXT, AJS1F401.218
& SOIL_EVAPORATION,SURF_HT_FLUX,SURF_RADFLUX, AJS1F401.219
& T1_SD,Q1_SD,WORK1,WORK2,WORK3, ASJ1F304.11
& PHOTOSYNTH_ACT_RAD,PDF_QC_OR_CF_LIQ,PDF_BS_OR_CF_ICE, AYY1F404.41
& RADHEAT_RATE,RADHEAT_DIM1, ARN1F404.150
& P_FIELDDA,Q_LEVELSDA,BL_LEVELSDA, AJS1F401.221
& ST_LEVELSDA,SM_LEVELSDA,INT3, AJS1F401.222
& LAND_FIELDDA, AJS1F401.223
& TILE_FIELDDA,TILE_PTS,TILE_INDEX, ARE1F404.59
& RAD_NO_SNOW,RAD_SNOW,SNOW_FRAC, ARE1F404.60
& ECAN_TILE,SNOW_SURF_HTF,SOIL_SURF_HTF, ARE1F404.61
*CALL ARGSIZE 
@DYALLOC.620
*CALL ARGD1 @DYALLOC.621
*CALL ARGDUMA @DYALLOC.622
*CALL ARGDUMO @DYALLOC.623
*CALL ARGDUMW GKR1F401.189
*CALL ARGSTS @DYALLOC.624
*CALL ARGPTRA @DYALLOC.625
*CALL ARGPTRO @DYALLOC.626
*CALL ARGCONA @DYALLOC.627
*CALL ARGPPX GKR0F305.907
*CALL ARGFLDPT APBGF401.21
& ICODE,CMESSAGE) @DYALLOC.628
BL_CTL1.32
IMPLICIT NONE BL_CTL1.33
C @DYALLOC.629
*CALL CMAXSIZE @DYALLOC.630
*CALL CSUBMODL GSS1F305.921
*CALL TYPSIZE @DYALLOC.631
*CALL TYPD1 @DYALLOC.632
*CALL TYPDUMA @DYALLOC.633
*CALL TYPDUMO @DYALLOC.634
*CALL TYPDUMW GKR1F401.190
*CALL TYPSTS @DYALLOC.635
*CALL TYPPTRA @DYALLOC.636
*CALL TYPPTRO @DYALLOC.637
*CALL TYPCONA @DYALLOC.638
*CALL PPXLOOK GKR0F305.908
! All TYPFLDPT arguments are intent IN APBGF401.22
*CALL TYPFLDPT APBGF401.23
BL_CTL1.34
INTEGER BL_CTL1.35
& INT3, ! Dummy variable for STASH_MAXLEN(3) BL_CTL1.36
& ICODE, ! Return code : 0 Normal Exit BL_CTL1.37
C ! : >0 Error BL_CTL1.38
& P_FIELDDA, ! Extra copy of P_FIELD for dynamic alloc @DYALLOC.639
& LAND_FIELDDA,! Extra copy of LAND_FIELD for dynamic alloc AJS1F401.224
& TILE_FIELDDA,! LAND_FIELD for tiled diagnostics (7A only) ARE1F404.62
& Q_LEVELSDA, ! and Q_LEVELS @DYALLOC.640
& BL_LEVELSDA, ! and BL_LEVELS @DYALLOC.641
& RADHEAT_DIM1, ! and dimension of RADHEAT rate either ARN1F404.151
! ! P_FIELD or 1 according to version of Sec.3 ARN1F404.152
& ST_LEVELSDA, ! and ST_LEVELS AJS1F401.225
& SM_LEVELSDA ! and SM_LEVELS AJS1F401.226
BL_CTL1.41
REAL BL_CTL1.42
& PDF_QC_OR_CF_LIQ(P_FIELDDA,Q_LEVELSDA), ! INOUT AYY1F404.42
& PDF_BS_OR_CF_ICE(P_FIELDDA,Q_LEVELSDA), ! INOUT AYY1F404.43
& ASURF(P_FIELDDA), ! AJS1F400.212
& CLOUD_FRACTION(P_FIELDDA,Q_LEVELSDA), ! Used to pass @DYALLOC.643
& SNOWMELT(P_FIELDDA), ! information AJS1F400.213
& SNOW_SUBLIMATION(P_FIELDDA), ! to other sections AJS1F400.214
& CANOPY_EVAPORATION(P_FIELDDA), ! AJS1F400.215
& EXT(LAND_FIELDDA,SM_LEVELSDA), ! AJS1F401.227
& SOIL_EVAPORATION(P_FIELDDA), ! @DYALLOC.646
& SURF_HT_FLUX(P_FIELDDA), ! AJS1F401.228
& SURF_RADFLUX(P_FIELDDA), ! @DYALLOC.647
& PHOTOSYNTH_ACT_RAD(P_FIELDDA), ! AJS1F401.229
& RADHEAT_RATE(RADHEAT_DIM1,BL_LEVELSDA), ARN1F404.153
& T1_SD(P_FIELDDA), ASJ1F304.12
& Q1_SD(P_FIELDDA), ASJ1F304.13
& WORK1(P_FIELDDA), ! Used as workspace @DYALLOC.648
& WORK2(P_FIELDDA), ! within its section @DYALLOC.649
& WORK3(P_FIELDDA), ! ASJ1F304.14
& QCF_FLUX(P_FIELDDA,BL_LEVELSDA), ! Flux of ice AYY1F404.44
& TR_FLUX(P_FIELDDA,BL_LEVELSDA) ASJ1F304.15
&, EPOT(P_FIELDDA) ! potential evaporation ANG1F405.5
&, FSMC(LAND_FIELDDA) ! soil moisture availability ANG1F405.6
BL_CTL1.52
ARN0F405.3
! Type identifiers for boundary layers: ARN0F405.4
REAL ARN0F405.5
& BL_TYPE_1(P_FIELDDA) ! OUT Indicator set to 1.0 if stable ARN0F405.6
! ! b.l. diagnosed, 0.0 otherwise. ARN0F405.7
&,BL_TYPE_2(P_FIELDDA) ! OUT Indicator set to 1.0 if Sc over ARN0F405.8
! ! stable surface layer diagnosed, ARN0F405.9
! ! 0.0 otherwise. ARN0F405.10
&,BL_TYPE_3(P_FIELDDA) ! OUT Indicator set to 1.0 if well ARN0F405.11
! ! mixed b.l. diagnosed, ARN0F405.12
! ! 0.0 otherwise. ARN0F405.13
&,BL_TYPE_4(P_FIELDDA) ! OUT Indicator set to 1.0 if ARN0F405.14
! ! decoupled Sc layer (not over ARN0F405.15
! ! cumulus) diagnosed, ARN0F405.16
! ! 0.0 otherwise. ARN0F405.17
&,BL_TYPE_5(P_FIELDDA) ! OUT Indicator set to 1.0 if ARN0F405.18
! ! decoupled Sc layer over cumulus ARN0F405.19
! diagnosed, 0.0 otherwise. ARN0F405.20
&,BL_TYPE_6(P_FIELDDA) ! OUT Indicator set to 1.0 if a ARN0F405.21
! ! cumulus capped b.l. diagnosed, ARN0F405.22
! ! 0.0 otherwise. ARN0F405.23
ARN0F405.24
! Additional arguments for 7A boundary layer (MOSES II) ARE1F404.63
*CALL NSTYPES ARE1F404.64
INTEGER ARE1F404.65
& TILE_PTS(NTYPE), ! OUT ABX1F405.194
& TILE_INDEX(TILE_FIELDDA,NTYPE) ! OUT ABX1F405.195
REAL ARE1F404.68
& RAD_NO_SNOW(P_FIELDDA), ! IN ARE1F404.69
& RAD_SNOW(P_FIELDDA), ! IN ARE1F404.70
& SNOW_FRAC(TILE_FIELDDA), ! IN ARE1F404.71
& ECAN_TILE(TILE_FIELDDA,NTYPE-1), ! OUT ARE1F404.72
& SNOW_SURF_HTF(TILE_FIELDDA), ! OUT ARE1F404.73
& SOIL_SURF_HTF(TILE_FIELDDA) ! OUT ARE1F404.74
ARE1F404.75
CHARACTER*80 TS150793.31
& CMESSAGE ! Error message if return code >0 BL_CTL1.54
BL_CTL1.55
*IF DEF,MPP APB1F305.116
! Parameters and Common blocks APB1F305.117
*CALL PARVARS APB1F305.118
*ENDIF APB1F305.119
*CALL CHSUNITS RS030293.199
*CALL CCONTROL BL_CTL1.57
*CALL C_R_CP BL_CTL1.61
*CALL C_LHEAT BL_CTL1.62
*CALL CHISTORY GDR3F305.12
*CALL CTRACERA ASJ1F304.18
*CALL CRUNTIMC ADR1F305.41
*CALL CTIME ADR1F305.42
BL_CTL1.63
*CALL C_MDI ACN1F405.3
*CALL C_PI APC3F304.4
*CALL C_VISBTY ! Version of visibility code APC3F304.5
*CALL C_SULBDY ! parameters for Sulphur Cycle AJS1F401.232
CL External subroutines called BL_CTL1.64
BL_CTL1.65
EXTERNAL BL_CTL1.66
& BL_INTCT,EXTDIAG,TIMER,STASH, AJS1F400.216
& TR_MIX,POLAR_UV,GLUE_CLD,POLAR, AYY2F400.107
& FLUX_DIAG, ASJ1F304.20
& TRSRCE, AJS1F401.233
& SET_LEVELS_LIST,FROM_LAND_POINTS,COPYDIAG_3D, ASJ1F304.21
& DEWPNT, ASW0F304.3
& COPYDIAG,VISBTY,QSAT,QSAT_WAT,BL_LSP ADM3F404.425
BL_CTL1.75
CL Dynamically allocated area for stash processing BL_CTL1.76
BL_CTL1.77
REAL BL_CTL1.78
& STASHWORK(INT3), BL_CTL1.79
& WORK4(P_FIELDDA*BL_LEVELSDA), @DYALLOC.651
& WORK5(P_FIELDDA*BL_LEVELSDA), ASW0F304.4
& WORK6(P_FIELDDA), AJS1F401.234
& WORK7(LAND_FIELDDA), AJS1F401.235
& WORK8(LAND_FIELDDA), AJS1F401.236
& WORK9(LAND_FIELDDA), AJS1F401.237
& WORK10(P_FIELDDA) AJS1F401.238
BL_CTL1.82
REAL ARE1F404.76
& ESOIL_TILE(TILE_FIELDDA,NTYPE-1), ARE1F404.77
& FTL_TILE(TILE_FIELDDA,NTYPE), ARE1F404.78
& G_LEAF(TILE_FIELDDA,NPFT), ARE1F404.79
& GPP_FT(TILE_FIELDDA,NPFT), ABX1F405.196
& NPP_FT(TILE_FIELDDA,NPFT), ARE1F404.80
& RESP_P_FT(TILE_FIELDDA,NPFT), ABX1F405.197
& RESP_S(TILE_FIELDDA), ARE1F404.81
& RESP_W_FT(TILE_FIELDDA,NPFT), ARE1F404.82
& RIB_TILE(TILE_FIELDDA,NTYPE) ARE1F404.83
ARE1F404.84
C Local variables BL_CTL1.83
REAL ! FOR PROGNOSTIC ICE PRECIP AYY1F404.45
& CLOUD_FRAC_BL(P_FIELDDA,Q_LEVELSDA) AYY1F404.46
BL_CTL1.84
REAL ! FOR SULPHUR CYCLE AJS1F401.239
& RHO_ARESIST(P_FIELDDA), ! RHOSTAR*CD_STD*VSHR AJS1F401.240
& ARESIST(P_FIELDDA), ! 1/(CD_STD*VSHR) AJS1F401.241
& RESIST_B(P_FIELDDA), ! (1/CH-1/CD_STD)/VSHR AJS1F401.242
& RESIST_S(P_FIELDDA), ! stomatal resistance AJS1F401.243
& RHO_ARESIST_TILE(TILE_FIELDDA,NTYPE), ARE1F404.85
! ! RHO_ARESIST on land tiles ARE1F404.86
& ARESIST_TILE(TILE_FIELDDA,NTYPE), ARE1F404.87
! ! ARESIST on land tiles ARE1F404.88
& RESIST_B_TILE(TILE_FIELDDA,NTYPE), ARE1F404.89
! ! RESIST_B on land tiles ARE1F404.90
& DRYDEP_STR(P_FIELDDA), ! surface dry deposited Sulphur AJS1F401.244
! !Cycle tracers for output to STASH AJS1F401.245
& STR_RESIST_B(P_FIELDDA), ! Rb for Sulphur Cycle tracer AJS1F401.246
& STR_RESIST_S(P_FIELDDA), ! Rs for Sulphur Cycle tracer AJS1F401.247
& RES_FACTOR(P_FIELDDA), ! Ra/(Ra+Rb+Rs) for dry deposition AJS1F401.248
& ZERO_FIELD(P_FIELDDA), ! dummy array of zeros AJS1F401.249
& CO2_FLUX(P_FIELDDA), ! array of total CO2 flux ACN1F405.4
& LAND_CO2(P_FIELDDA), ! array of CO2 land flux ACN1F405.5
& LAND_CO2_L(LAND_FIELDDA), ! land points CO2 land flux ACN1F405.6
& DAMP_FACTOR(P_FIELDDA), ! Canopy moistening factor AWO3F405.11
& SNOW_F ! calculated snow fraction AJS1F401.250
&, TILE_FRAC(TILE_FIELDDA,NTYPE) ! snow-adjusted tile fraction ABX1F405.200
&, CCA(P_FIELDDA) ! convective cloud amt on one level AJX0F404.469
INTEGER AJX0F404.470
& LEV ! used in calculation of CCA AJX0F404.471
! AJS1F401.251
REAL BL_CTL1.85
& AK1P5M, ! Value of AK at 1.5 metres BL_CTL1.86
& BK1P5M ! Value of BK at 1.5 metres BL_CTL1.87
PARAMETER( PC120793.5
& AK1P5M =0.0, PC120793.6
& BK1P5M =1.0) PC120793.7
BL_CTL1.88
INTEGER BL_CTL1.89
& ROWS, BL_CTL1.91
& FIRST_POINT, BL_CTL1.92
& LAST_POINT, BL_CTL1.93
& POINTS, BL_CTL1.94
& JS, BL_CTL1.95
& LEVEL_OUT, BL_CTL1.96
& LEVEL, BL_CTL1.97
& PSLEVEL, ! loop counter for pseudolevels ABX1F405.198
& PSLEVEL_OUT, ! index for pseudolevels sent to STASH ABX1F405.199
& I,J, AJS1F401.252
& NRML(P_FIELDDA), ASJ1F304.23
& N_TRACER ASJ1F304.24
& ,im_ident ! Internal model identifier GDR4F305.5
& ,im_index ! Internal model index for stash arrays GDR4F305.6
& ,STHU_PTR ! local pointer to D1 array for STHU AJS1F401.253
& ,STHF_PTR ! local pointer to D1 array for STHF AJS1F401.254
& ,LAND_FIELD_TRIF !\ For dimensioning variables in BL_INTCTL ABX1F405.201
& ,NPFT_TRIF !/ depending on whether TRIFFID is in use. ABX1F405.202
& ,CO2_DIM ! dimension for CO2 field to be passed down ACN1F405.7
LOGICAL BL_CTL1.100
& L_COMPRESS_SEAICE, ! Convert to sea_ice points within BL_CTL1.101
C ! BDY_LYR BL_CTL1.102
& LIST(ST_LEVELSDA) AJS1F401.255
& , SF225 ! local flag for 10m wind U-comp TJ181193.2
& , SF226 ! local flag for 10m wind V-comp TJ181193.3
& , SF236 ! local flag for 1.5T BL_CTL1.104
& , SF237 ! local flag for 1.5Q BL_CTL1.105
& , PLLTYPE(NTYPE) ! pseudolevel list for surface types ABX1F405.203
& , PLLPFT(NPFT) ! pseudolevel list for PFTs ABX1F405.204
& , PLLNIT(NTYPE-1) ! pseudolevel list for non-ice types ABX1F405.205
ABX1F405.206
BL_CTL1.106
*CALL C_ST_BDY AWO3F405.117
! AWO3F405.118
DATA L_COMPRESS_SEAICE /.TRUE./ BL_CTL1.107
BL_CTL1.108
CL BL_CTL1.109
CL--- SECTION 3 --- BOUNDARY LAYER & SURFACE ---------- BL_CTL1.110
CL BL_CTL1.111
CL SECTION 3.1 Initialisation BL_CTL1.112
CL BL_CTL1.113
! L_bl_lspice_if1: AYY1F404.47
IF (L_BL_LSPICE) THEN AYY1F404.48
! Prognostic cloud ice, BL scheme works on liquid water cloud only AYY1F404.49
DO J=1,Q_LEVELS AYY1F404.50
DO I=1,P_FIELD AYY1F404.51
CLOUD_FRAC_BL(I,J) = PDF_QC_OR_CF_LIQ(I,J) AYY1F404.52
END DO AYY1F404.53
END DO AYY1F404.54
ELSE AYY1F404.55
! Prognostic total water, BL scheme works with only cloud fraction AYY1F404.56
DO J=1,Q_LEVELS AYY1F404.57
DO I=1,P_FIELD AYY1F404.58
CLOUD_FRAC_BL(I,J) = CLOUD_FRACTION(I,J) AYY1F404.59
END DO AYY1F404.60
END DO AYY1F404.61
ENDIF ! L_bl_lspice_if1 AYY1F404.62
! AYY1F404.63
im_ident = atmos_im GDR4F305.7
im_index = internal_model_index(im_ident) GDR4F305.8
GDR4F305.9
FIRST_POINT=START_POINT_NO_HALO APBGF401.24
LAST_POINT=END_P_POINT_INC_HALO APBGF401.25
POINTS=LAST_POINT-FIRST_POINT+1 APBGF401.26
ROWS=POINTS/ROW_LENGTH APBGF401.27
JS = FIRST_POINT-1 ARB2F402.13
BL_CTL1.121
CL Set implied diagnostics flags BL_CTL1.122
SF225=SF(225,3).OR.SF(249,3) TJ181193.4
SF226=SF(226,3).OR.SF(249,3) TJ181193.5
SF236=SF(236,3).OR.SF(237,3).OR. BL_CTL1.123
& SF(242,3).OR.SF(243,3).OR.SF(244,3).OR.SF(245,3).OR.SF(247,3) RB200193.3
& .OR.SF(253,3) ! Needed for mist fraction at 1.5 m) APC3F304.6
& .OR.SF(248,3) ! Needed for fog fraction at 1.5 m) PC120793.8
& .OR.SF(250,3) ! Needed for dewpoint at 1.5 m ASW0F304.6
& .OR.SF(254,3) ! Needed for TL at 1.5 m APC5F400.3
SF237=SF(237,3).OR.SF(236,3).OR. BL_CTL1.125
& SF(242,3).OR.SF(243,3).OR.SF(244,3).OR.SF(245,3).OR.SF(247,3) RB200193.4
& .OR.SF(253,3) ! Needed for mist fraction at 1.5 m) APC3F304.7
& .OR.SF(248,3) ! Needed for fog fraction at 1.5 m) PC120793.9
& .OR.SF(250,3) ! Needed for dewpoint at 1.5 m ASW0F304.7
& .OR.SF(255,3) ! Needed for QT at 1.5 m APC5F400.4
BL_CTL1.127
CL Zero work array to prevent i/o problems with unaccessed polar rows BL_CTL1.128
BL_CTL1.129
DO I=1,INT3 BL_CTL1.130
STASHWORK(I)=0.0 BL_CTL1.131
END DO BL_CTL1.132
BL_CTL1.133
C Initialise output arrays to zero BL_CTL1.134
BL_CTL1.135
DO I=1,P_FIELD BL_CTL1.136
CANOPY_EVAPORATION(I)=0.0 BL_CTL1.137
SNOW_SUBLIMATION(I) = 0.0 BL_CTL1.138
SOIL_EVAPORATION(I) = 0.0 BL_CTL1.139
SURF_HT_FLUX(I) = 0.0 AJS1F401.256
SNOWMELT(I)=0.0 AJS1F400.217
ZERO_FIELD(I)=0.0 ! for input to TR_MIX AJS1F401.257
! Set up CO2 source field. Units in kg(CO2)/m2/s ACN1F405.8
CO2_FLUX(I) = 0.0 ACN1F405.9
LAND_CO2(I) = 0.0 ACN1F405.10
END DO BL_CTL1.140
IF ( LMOSES ) THEN AJS1F401.258
DO I=1,LAND_FIELD AJS1F401.259
DO J=1,SM_LEVELS AJS1F401.260
EXT(I,J)=0.0 AJS1F401.261
ENDDO AJS1F401.262
LAND_CO2_L(I) = 0.0 ACN1F405.11
ENDDO AJS1F401.263
ENDIF AJS1F401.264
C AJS1F401.265
C Set up pointers for D1 store for these arrays as SM_LEVELS=0 for Singl AJS1F401.266
C layer hydrology so JSTHU(1) will not exist. AJS1F401.267
C AJS1F401.268
IF (LSINGLE_HYDROL) THEN AJS1F401.269
STHU_PTR = 1 AJS1F401.270
STHF_PTR = 1 AJS1F401.271
ELSE AJS1F401.272
STHU_PTR = JSTHU(1) AJS1F401.273
STHF_PTR = JSTHF(1) AJS1F401.274
ENDIF AJS1F401.275
C AJX0F404.472
C Set up a single level array of convective cloud amount for use in AJX0F404.473
C EXCOEFF. AJX0F404.474
C AJX0F404.475
IF (L_3D_CCA) THEN AJX0F404.476
DO I=1,P_FIELD AJX0F404.477
IF (ID1(JCCB+I-1) .GT. 0.0) THEN AJX0F404.478
LEV=ID1(JCCB+I-1) AJX0F404.479
CCA(I)=D1(JCCA(LEV)+I-1) AJX0F404.480
ELSE AJX0F404.481
CCA(I)=0.0 AJX0F404.482
ENDIF AJX0F404.483
ENDDO AJX0F404.484
ELSE AJX0F404.485
DO I=1,P_FIELD AJX0F404.486
CCA(I)=D1(JCCA(1)+I-1) AJX0F404.487
ENDDO AJX0F404.488
ENDIF AJX0F404.489
! ABX1F405.207
! Set LAND_FIELD_TRIF and NPFT_TRIF according to TRIFFID on/off ABX1F405.208
! ABX1F405.209
IF (L_TRIFFID) THEN ABX1F405.210
LAND_FIELD_TRIF = LAND_FIELD ABX1F405.211
NPFT_TRIF = NPFT ABX1F405.212
ELSE ABX1F405.213
LAND_FIELD_TRIF = 1 ABX1F405.214
NPFT_TRIF = 1 ABX1F405.215
ENDIF ABX1F405.216
! ACN1F405.12
! set up CO2 field to be passed down ACN1F405.13
! ACN1F405.14
IF (L_CO2_INTERACTIVE) THEN ACN1F405.15
CO2_DIM = P_FIELD ACN1F405.16
ELSE ACN1F405.17
CO2_DIM = 1 ACN1F405.18
ENDIF ACN1F405.19
CL AJS1F401.285
CL SECTION 3.2 Call BL_INTCT to calculate and add boundary layer AJS1F401.286
CL increments AJS1F401.287
BL_CTL1.141
IF (LTIMER) THEN ASJ1F304.25
CALL TIMER('BL_INTCT',3) AJS1F400.219
END IF BL_CTL1.148
BL_CTL1.149
ASJ1F304.26
CL ********************************************************************* ASJ1F304.27
CL CALL THE INTERMEDIATE CONTROL LEVEL 'glued' to the BDY_LAYR version. AJS1F400.220
CL The arguments in the call include all those used in each version AJS1F400.221
CL ********************************************************************* ASJ1F304.31
ASJ1F304.32
CALL BL_INTCT( AJS1F400.222
BL_CTL1.151
C IN values defining field dimensions and subset to be processed : BL_CTL1.152
BL_CTL1.153
& P_FIELD,U_FIELD,LAND_FIELD,LAND_FIELD_TRIF,NPFT_TRIF, ABX1F405.217
& P_ROWS,FIRST_ROW,ROWS,ROW_LENGTH, AJS1F401.289
BL_CTL1.155
C IN values defining vertical grid of model atmosphere : BL_CTL1.156
BL_CTL1.157
& BL_LEVELS,P_LEVELS,A_LEVDEPC(JAK),A_LEVDEPC(JBK),AKH, BL_CTL1.158
& BKH,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK),D1(JP_EXNER(1)), BL_CTL1.159
BL_CTL1.160
C IN soil/vegetation/land surface data : BL_CTL1.161
BL_CTL1.162
& D1(JLAND),L_COMPRESS_SEAICE,LAND_LIST, AJS1F401.290
& ST_LEVELS,SM_LEVELS, AJS1F401.291
& D1(JCANHT),D1(JCANOPY_WATER), AJS1F401.292
& D1(JSURF_CAP),D1(JTHERM_CAP), GDR6F405.88
& D1(JTHERM_COND),D1(JLAI), GDR6F405.89
& A_LEVDEPC(JSOIL_THICKNESS),D1(JSNODEP), AJS1F401.295
& D1(JSURF_RESIST),D1(JROOT_DEPTH),D1(JSMC),D1(JVOL_SMC_CRIT), GDR6F405.90
& D1(JVOL_SMC_SAT),D1(JVOL_SMC_WILT),D1(JVEG_FRAC), GDR6F405.91
& D1(JZ0),D1(JOROG_SIL),L_Z0_OROG,D1(JOROG_HO2), AJS1F401.297
BL_CTL1.168
C IN sea/sea-ice data : BL_CTL1.169
BL_CTL1.170
& D1(JICE_THICKNESS),D1(JICE_FRACTION),D1(JU_SEA),D1(JV_SEA), BL_CTL1.171
BL_CTL1.172
C IN Cloud data : BL_CTL1.173
BL_CTL1.174
& CLOUD_FRAC_BL,D1(JQCF(1)),D1(JQCL(1)), AYY1F404.64
& CCA,ID1(JCCB),ID1(JCCT), AJX0F404.490
BL_CTL1.177
C IN everything not covered so far : BL_CTL1.178
BL_CTL1.179
& RADHEAT_RATE,RADHEAT_DIM1, ARN1F404.154
& CO2_MMR,PHOTOSYNTH_ACT_RAD,D1(JPSTAR), AJS1F401.298
& SURF_RADFLUX,SECS_PER_STEPim(atmos_im),L_RMBL, AYY1F404.65
& L_BL_LSPICE,L_MOM,L_MIXLEN, AYY1F404.66
BL_CTL1.181
C INOUT data : BL_CTL1.182
BL_CTL1.183
& D1(JGS),D1(JQ(1)),D1(STHF_PTR),D1(STHU_PTR),D1(JTHETA(1)), AJS1F401.300
& D1(J_DEEP_SOIL_TEMP(1)),D1(JTI),D1(JTSTAR), AJS1F400.225
& D1(JU(1)),D1(JV(1)),D1(JZ0), AJS1F400.226
BL_CTL1.186
C OUT Diagnostic not requiring STASH flags : BL_CTL1.187
BL_CTL1.188
& WORK1,WORK2, AJS1F400.227
& STASHWORK(SI(232,3,im_index)),WORK10, AJS1F401.301
& STASHWORK(SI(223,3,im_index)),STASHWORK(SI(217,3,im_index)), AJS1F401.302
& WORK7,STASHWORK(SI(228,3,im_index)),WORK8,WORK9, AJS1F401.303
& WORK4,WORK5, BL_CTL1.191
& STASHWORK(SI(208,3,im_index)),STASHWORK(SI(201,3,im_index)), GDR4F305.27
& STASHWORK(SI(219,3,im_index)), AJS1F401.304
& STASHWORK(SI(220,3,im_index)),WORK3, GDR4F305.29
& STASHWORK(SI(304,3,im_index)), ARN0F405.25
! OUT Diagnostic requiring STASH flags : ARN0F405.26
& EPOT,FSMC, ANG1F405.1
ANG1F405.2
! OUT diagnostic requiring STASH flags : ANG1F405.3
ANG1F405.4
& STASHWORK(SI(224,3,im_index)),STASHWORK(SI(235,3,im_index)), GDR4F305.30
& STASHWORK(SI(258,3,im_index)), AJS1F400.229
& STASHWORK(SI(234,3,im_index)),STASHWORK(SI(237,3,im_index)), GDR4F305.31
& STASHWORK(SI(236,3,im_index)),STASHWORK(SI(225,3,im_index)), GDR4F305.32
& STASHWORK(SI(226,3,im_index)), ANG1F405.7
ANG1F405.8
! IN STASH flags :- ANG1F405.9
ANG1F405.10
& SF(224,3),SF(235,3),SF(258,3), ANG1F405.11
& SF(234,3),SF237,SF236,SF225,SF226, AJS1F400.231
BL_CTL1.199
C OUT data required for tracer mixing : ASJ1F304.106
ASJ1F304.107
& RHO_ARESIST,ARESIST,RESIST_B, AJS1F401.305
& NRML, AJS1F400.232
AJS1F400.233
C OUT data required for 4D_var : AJS1F400.234
AJS1F400.235
& STASHWORK(SI(256,3,im_index)),STASHWORK(SI(257,3,im_index)), AJS1F400.236
ASJ1F304.109
C OUT data required elsewhere in UM system : BL_CTL1.200
BL_CTL1.201
& BL_TYPE_1,BL_TYPE_2,BL_TYPE_3,BL_TYPE_4,BL_TYPE_5,BL_TYPE_6, ARN0F405.27
& CANOPY_EVAPORATION,SNOW_SUBLIMATION, AJS1F401.306
& SOIL_EVAPORATION,EXT,SNOWMELT,SURF_HT_FLUX, AJS1F401.307
& D1(JZH),T1_SD,Q1_SD, AJS1F401.308
& ICODE, AJS1F400.240
ARE1F404.91
! Additional arguments for 7A boundary layer (MOSES II) ARE1F404.92
! IN ARE1F404.93
& L_PHENOL,L_TRIFFID,L_NEG_TSTAR, ABX1F405.218
& D1(JCANHT_PFT),D1(JCAN_WATER_NIT),D1(JCATCH_NIT), ARE1F404.95
& D1(JSOIL_CARB),D1(JLAI_PFT),D1(JFRAC_TYP), ARE1F404.96
& SNOW_FRAC,RAD_NO_SNOW,RAD_SNOW,D1(JTSNOW),D1(JZ0_TYP), ARE1F404.97
& D1(JCO2(1)),CO2_DIM,L_CO2_INTERACTIVE, ACN1F405.20
! INOUT ARE1F404.98
& D1(JTSTAR_TYP), ARE1F404.99
& D1(JG_LF_PFT_ACC),D1(JNPP_PFT_ACC), ARE1F404.100
& D1(JRSP_W_PFT_ACC),D1(JRSP_S_ACC), ARE1F404.101
! OUT ARE1F404.102
& ECAN_TILE,ESOIL_TILE,FTL_TILE, ARE1F404.103
& G_LEAF,GPP_FT,NPP_FT,RESP_P_FT,RESP_S,RESP_W_FT, ABX1F405.219
& RHO_ARESIST_TILE,ARESIST_TILE,RESIST_B_TILE, ARE1F404.105
& RIB_TILE,SNOW_SURF_HTF,SOIL_SURF_HTF, ARE1F404.106
& TILE_INDEX,TILE_PTS,TILE_FRAC, ABX1F405.220
BL_CTL1.204
C LOGICAL switch LTIMER ASJ1F304.111
ASJ1F304.112
& LTIMER) ASJ1F304.113
ASJ1F304.114
ASJ1F304.115
IF (LTIMER) THEN ASJ1F304.118
CALL TIMER('BL_INTCT',4) AJS1F400.241
END IF BL_CTL1.207
BL_CTL1.208
*IF DEF,MPP APB1F305.141
! Do a boundary swap on the U,V and THETA arrays that have just APB1F305.142
! been calculated APB1F305.143
CALL SWAPBOUNDS(D1(JU(1)),ROW_LENGTH,tot_P_ROWS, APBGF401.29
& EW_Halo,NS_Halo,BL_LEVELS) APBGF401.30
CALL SWAPBOUNDS(D1(JV(1)),ROW_LENGTH,tot_P_ROWS, APBGF401.31
& EW_Halo,NS_Halo,BL_LEVELS) APBGF401.32
CALL SWAPBOUNDS(D1(JTHETA(1)),ROW_LENGTH,tot_P_ROWS, APBGF401.33
& EW_Halo,NS_Halo,BL_LEVELS) APBGF401.34
CALL SWAPBOUNDS(D1(JQ(1)),ROW_LENGTH,tot_P_ROWS, ADR5F403.78
& EW_Halo,NS_Halo,BL_LEVELS) ADR5F403.79
CALL SWAPBOUNDS(T1_SD,ROW_LENGTH,tot_P_ROWS, ADR5F403.80
& EW_Halo,NS_Halo,1) ADR5F403.81
CALL SWAPBOUNDS(Q1_SD,ROW_LENGTH,tot_P_ROWS, ADR5F403.82
& EW_Halo,NS_Halo,1) ADR5F403.83
*ENDIF APB1F305.150
CL ********************************************************************* ASJ1F304.119
CL SECTION 3.3 Implicit mixing of tracers in boundary layer ASJ1F304.120
CL ********************************************************************* ASJ1F304.121
ASJ1F304.122
IF (LTIMER) THEN ASJ1F304.123
CALL TIMER('TR_MIX',3) ASJ1F304.124
END IF ASJ1F304.125
ASJ1F304.126
IF (L_BL_TRACER_MIX) THEN ASJ1F304.127
ASJ1F304.128
DO N_TRACER = 1,TR_VARS ASJ1F304.129
ASJ1F304.130
CALL TR_MIX ( ASJ1F304.131
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS ASJ1F304.132
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) ASJ1F304.133
& ,WORK4(P_FIELDDA+1),WORK4(1) ASJ1F304.134
& ,D1(JPSTAR) ASJ1F304.135
& ,SECS_PER_STEPim(atmos_im) ADR1F305.45
& ,TR_FLUX,D1(JTRACER(1,N_TRACER)) ASJ1F304.137
& ,ZERO_FIELD,ZERO_FIELD,DRYDEP_STR AJS1F401.309
& ,NRML,ICODE,LTIMER ASJ1F304.138
& ) ASJ1F304.139
ASJ1F304.140
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.304
ASJ1F304.141
IF (SF(99+N_TRACER,3)) THEN ASJ1F304.142
ASJ1F304.143
CALL COPYDIAG(STASHWORK(SI(99+N_TRACER,3,im_index)), GDR4F305.34
& TR_FLUX,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.305
& im_ident,3,99+N_TRACER, GPB1F403.306
*CALL ARGPPX GPB1F403.307
& ICODE,CMESSAGE) GPB1F403.308
GPB1F403.309
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.310
END IF ASJ1F304.146
ASJ1F304.147
ASJ1F304.151
END DO ! End of N_TRACER loop ASJ1F304.152
ENDIF ! End of L_BL_TRACER_MIX block ASJ1F304.153
ASJ1F304.154
CL ********************************************************************* ASJ1F304.155
CL SECTION 3.3.1 Implicit mixing of aerosol in boundary layer ASJ1F304.156
CL ********************************************************************* ASJ1F304.157
ASJ1F304.158
IF (L_MURK_ADVECT) THEN ASJ1F304.159
ASJ1F304.160
ASJ1F304.161
CALL TR_MIX ( ASJ1F304.162
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS ASJ1F304.163
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) ASJ1F304.164
& ,WORK4(P_FIELDDA+1),WORK4(1) ASJ1F304.165
& ,D1(JPSTAR) ASJ1F304.166
& ,SECS_PER_STEPim(atmos_im) ADR1F305.46
& ,TR_FLUX,D1(JMURK(1)) ASJ1F304.168
& ,ZERO_FIELD,ZERO_FIELD,DRYDEP_STR AJS1F401.310
& ,NRML,ICODE,LTIMER ASJ1F304.169
& ) ASJ1F304.170
ASJ1F304.171
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.311
ASJ1F304.172
IF (SF(129,3)) THEN ASJ1F304.173
ASJ1F304.174
CALL COPYDIAG(STASHWORK(SI(129,3,im_index)),TR_FLUX, GDR4F305.36
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.312
& im_ident,3,129, GPB1F403.313
*CALL ARGPPX GPB1F403.314
& ICODE,CMESSAGE) GPB1F403.315
GPB1F403.316
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.317
END IF ASJ1F304.177
ASJ1F304.178
ASJ1F304.182
ENDIF ! End of L_MURK_ADVECT block ASJ1F304.183
ASJ1F304.184
! ********************************************************************** AYY1F404.67
! SECTION 3.3.1a Implicit mixing of ice in boundary layer AYY1F404.68
! ********************************************************************** AYY1F404.69
! L_lspice_if2: AYY1F404.70
IF (L_LSPICE) THEN AYY1F404.71
CALL TR_MIX ( AYY1F404.72
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AYY1F404.73
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AYY1F404.74
& ,WORK4(P_FIELDDA+1),WORK4(1) AYY1F404.75
& ,D1(JPSTAR) AYY1F404.76
& ,SECS_PER_STEPim(atmos_im) AYY1F404.77
& ,QCF_FLUX,D1(JQCF(1)) AYY1F404.78
& ,ZERO_FIELD,ZERO_FIELD,DRYDEP_STR AYY1F404.79
& ,NRML,ICODE,LTIMER AYY1F404.80
& ) AYY1F404.81
! AYY1F404.82
IF (ICODE.GT.0) THEN AYY1F404.83
RETURN AYY1F404.84
ENDIF AYY1F404.85
ENDIF ! L_lspice_if2 AYY1F404.86
! AYY1F404.87
CL******************************************************************** AJS1F401.311
CL SECTION 3.3.2 Implicit mixing of SULPHUR CYCLE tracers in b.layer AJS1F401.312
CL including dry deposition and injection of emissions AJS1F401.313
CL Explicit addition of non_surface emissions AJS1F401.314
CL******************************************************************** AJS1F401.315
! AJS1F401.316
IF (L_SULPC_SO2) THEN ! SULPHUR CYCLE IS REQUIRED AJS1F401.317
! AJS1F401.318
IF (L_SO2_HILEM) THEN ! Add non-surface emissions AJS1F401.319
! AJS1F401.320
CALL TRSRCE( A_LEVDEPC(JDELTA_AK+SO2_HIGH_LEVEL-1), AJS1F401.321
& A_LEVDEPC(JDELTA_BK+SO2_HIGH_LEVEL-1), AJS1F401.322
& P_FIELD,P_FIELD, AJS1F401.323
& D1(JPSTAR), AJS1F401.324
& D1(JSO2(SO2_HIGH_LEVEL)), AJS1F401.325
& D1(JSO2_HILEM), AJS1F401.326
& SECS_PER_STEPim(atmos_im), AJS1F401.327
& I_HOUR, AJS1F401.328
& I_MINUTE, AJS1F401.329
& 0.0, !AMPlitude of diurnal var of emiss AJS1F401.330
& ICODE) AJS1F401.331
! AJS1F401.332
END IF AJS1F401.333
! AJS1F401.334
! Calculate STR_RESIST_B and STR_RESIST_S for dry deposition and AJS1F401.335
! output to STASH. AJS1F401.336
! AJS1F401.337
! For RESIST_B check to eliminate possible negative values AJS1F401.338
DO I=FIRST_POINT,LAST_POINT AJS1F401.339
IF (RESIST_B(I) .LT. 0.0) THEN AJS1F401.340
RESIST_B(I) = 0.0 AJS1F401.341
END IF AJS1F401.342
END DO AJS1F401.343
! AJS1F401.344
! For STR_RESIST_S values depend on surface type (land, sea, AJS1F401.345
! snow,ice) as well as tracer identity. AJS1F401.346
! AJS1F401.347
! First calculate stomatal resistance; initialise to zero, then fill AJS1F401.348
! available land point values. AJS1F401.349
! AJS1F401.350
DO I=1,P_FIELD AJS1F401.351
RESIST_S(I)=0.0 AJS1F401.352
DAMP_FACTOR(I) = 1.0 AWO3F405.12
END DO AJS1F401.353
! AJS1F401.354
DO I=1,LAND_FIELD AJS1F401.355
! AJS1F401.356
C Use JGS for interactive stomatal conductance (MOSES) or AJS1F401.357
C JVEG_FLDS(5) for old stomatal resistances, both on land points only AJS1F401.358
! AJS1F401.359
IF ( D1(JGS+I-1) .GT. COND_LIM) THEN AJS1F401.360
RESIST_S(LAND_LIST(I))= 1.0/D1(JGS+I-1) AJS1F401.361
ELSE AJS1F401.362
RESIST_S(LAND_LIST(I))=1.0/COND_LIM ! Avoid /0.0 AJS1F401.363
END IF AJS1F401.364
! AJS1F401.365
COMMENT OUT RESIST_S(LAND_LIST(I))= D1(JVEG_FLDS(5)+I-1) AJS1F401.366
! AJS1F401.367
! Reduce the surface resistance by up to two-thirds if AWO3F405.13
! the canopy is damp, because SO2 and NH3 both dissolve AWO3F405.14
! in the canopy water. (The value of 2/3 is empirical.) AWO3F405.15
! Two special cases need to be trapped here. The canopy AWO3F405.16
! capacity (JSURF_CAP) is zero at land ice points, so AWO3F405.17
! exclude these from the calculation. Also, there is a AWO3F405.18
! possibility that canopy water may exceed canopy capacity AWO3F405.19
! due to leaves having fallen, so take care of this too. AWO3F405.20
! Note that instead of applying DAMP_FACTOR here, we store AWO3F405.21
! it so that it can be applied later. This means that it AWO3F405.22
! does not automatically apply to all the species. AWO3F405.23
! AWO3F405.24
IF( (D1(JSURF_CAP+I-1) .GT. 0.01) .AND. AWO3F405.25
& (D1(JCANOPY_WATER+I-1) .GT. 0.0) ) THEN AWO3F405.26
! AWO3F405.27
IF( D1(JCANOPY_WATER+I-1) .LE. D1(JSURF_CAP+I-1) ) THEN AWO3F405.28
DAMP_FACTOR(LAND_LIST(I)) = 1.0 - 0.66667* AWO3F405.29
& ( D1(JCANOPY_WATER+I-1) / D1(JSURF_CAP+I-1) ) AWO3F405.30
ELSE AWO3F405.31
DAMP_FACTOR(LAND_LIST(I)) = 0.33333 AWO3F405.32
ENDIF AWO3F405.33
! AWO3F405.34
ENDIF AWO3F405.35
! AWO3F405.36
END DO AJS1F401.368
! AJS1F401.369
! **CODE FOR SO2** AJS1F401.370
! AJS1F401.371
! Note that RESIST_S = 0 over non-land points and Antarctica, so need AJS1F401.372
! to reset STR_RESIST_S for SO2 to suitable values over snow and ice AJS1F401.373
! (0 is acceptable over sea ). AJS1F401.374
! Where there is snow cover, calculate an approximate snow fraction AJS1F401.375
! for the grid box using the formula 1-exp(-ASNOW*SNODEP) AJS1F401.376
! (Note that for atmospheric model run there should not be any sea AJS1F401.377
! points with SNODEP.GT.0, and land_ice points should all have AJS1F401.378
! large values of SNODEP. Over Antarctica RESIST_S (for H2O) is 0 AJS1F401.379
! so STR_RESIST_S for SO2 has to be set separately to R_SNOW ) AJS1F401.380
! AJS1F401.381
DO I=FIRST_POINT,LAST_POINT AJS1F401.382
! AJS1F401.383
STR_RESIST_B(I)=RESB_SO2*RESIST_B(I) AJS1F401.384
STR_RESIST_S(I) = RESS_SO2*RESIST_S(I)*DAMP_FACTOR(I) AWO3F405.37
! AJS1F401.386
IF (D1(JSNODEP+I-1).GT.0.0 .AND. STR_RESIST_S(I).GT.0.0) THEN AJS1F401.387
SNOW_F=1.0-EXP(-ASNOW*D1(JSNODEP+I-1)) AJS1F401.388
STR_RESIST_S(I) = 1.0 / AJS1F401.389
& (SNOW_F/R_SNOW + (1.0-SNOW_F)/STR_RESIST_S(I)) AJS1F401.390
! AJS1F401.391
ELSE IF ((D1(JSNODEP+I-1).GT.0.0 .AND. RESIST_S(I).EQ.0.0) .OR. AJS1F401.392
& (D1(JICE_FRACTION+I-1).GT.0.0) ) THEN AJS1F401.393
STR_RESIST_S(I)=R_SNOW AJS1F401.394
! AJS1F401.395
END IF AJS1F401.396
! AJS1F401.397
! Calculate RES_FACTOR for SO2 to allow dry deposition AJS1F401.398
! AJS1F401.399
RES_FACTOR(I) = ARESIST(I) / AJS1F401.400
& (ARESIST(I)+ STR_RESIST_B(I)+STR_RESIST_S(I)) AJS1F401.401
! AJS1F401.402
END DO ! END I LOOP AJS1F401.403
! AJS1F401.404
! CALL TR_MIX FOR SO2 AJS1F401.405
! AJS1F401.406
IF (L_SO2_SURFEM) THEN ! mix in surface emissions AJS1F401.407
! AJS1F401.408
CALL TR_MIX( AJS1F401.409
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AJS1F401.410
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AJS1F401.411
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AJS1F401.412
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AJS1F401.413
& ,TR_FLUX,D1(JSO2(1)) AJS1F401.414
& ,D1(JSO2_EM),RES_FACTOR,DRYDEP_STR AJS1F401.415
& ,NRML AJS1F401.416
& ,ICODE,TIMER) AJS1F401.417
! AJS1F401.418
ELSE ! no surface emissions AJS1F401.419
! AJS1F401.420
CALL TR_MIX( AJS1F401.421
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AJS1F401.422
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AJS1F401.423
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AJS1F401.424
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AJS1F401.425
& ,TR_FLUX,D1(JSO2(1)) AJS1F401.426
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AJS1F401.427
& ,NRML AJS1F401.428
& ,ICODE,TIMER) AJS1F401.429
! AJS1F401.430
END IF AJS1F401.431
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.318
! AJS1F401.432
! WRITE TO STASH AJS1F401.433
! AJS1F401.434
IF(SF(270,3)) THEN ! write dry dep FLUX SO2 to stash AJS1F401.435
! Change sign of dry dep flux (otherwise negative) AJS1F401.436
DO I=FIRST_POINT,LAST_POINT AJS1F401.437
DRYDEP_STR(I) = -DRYDEP_STR(I) AJS1F401.438
END DO AJS1F401.439
! AJS1F401.440
CALL COPYDIAG(STASHWORK(SI(270,3,im_index)),DRYDEP_STR, AJS1F401.441
& FIRST_POINT,LAST_POINT, AJS1F401.442
& P_FIELD,ROW_LENGTH, GPB1F403.319
& im_ident,3,270, GPB1F403.320
*CALL ARGPPX GPB1F403.321
& ICODE,CMESSAGE) GPB1F403.322
GPB1F403.323
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.324
END IF AJS1F401.444
C AJS1F401.445
C AJS1F401.446
IF(SF(274,3).OR.SF(282,3)) THEN ! write Rb for SO2 to stash AWO1F404.147
CALL COPYDIAG(STASHWORK(SI(274,3,im_index)),STR_RESIST_B, AJS1F401.448
& FIRST_POINT,LAST_POINT, AJS1F401.449
& P_FIELD,ROW_LENGTH, GPB1F403.325
& im_ident,3,274, GPB1F403.326
*CALL ARGPPX GPB1F403.327
& ICODE,CMESSAGE) GPB1F403.328
GPB1F403.329
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.330
END IF AJS1F401.451
C AJS1F401.452
IF(SF(278,3).OR.SF(282,3)) THEN ! write Rs for SO2 to stash AWO1F404.148
CALL COPYDIAG(STASHWORK(SI(278,3,im_index)),STR_RESIST_S, AJS1F401.454
& FIRST_POINT,LAST_POINT, AJS1F401.455
& P_FIELD,ROW_LENGTH, GPB1F403.331
& im_ident,3,278, GPB1F403.332
*CALL ARGPPX GPB1F403.333
& ICODE,CMESSAGE) GPB1F403.334
GPB1F403.335
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.336
END IF AJS1F401.457
C AJS1F401.458
! ** FOR NH3 IF PRESENT ** AWO3F405.38
! AWO3F405.39
IF (L_SULPC_NH3) THEN AWO3F405.40
! AWO3F405.41
! Calculate RES_FACTOR for NH3 to allow dry deposition in same way AWO3F405.42
! as for SO2 (including code for snow and ice) AWO3F405.43
! AWO3F405.44
DO I=FIRST_POINT,LAST_POINT AWO3F405.45
! AWO3F405.46
STR_RESIST_B(I)=RESB_NH3 * RESIST_B(I) AWO3F405.47
STR_RESIST_S(I)=RESS_NH3 * RESIST_S(I)*DAMP_FACTOR(I) AWO3F405.48
! AWO3F405.49
IF (D1(JSNODEP+I-1).GT.0.0 .AND. STR_RESIST_S(I).GT.0.0) THEN AWO3F405.50
SNOW_F=1.0-EXP(-ASNOW*D1(JSNODEP+I-1)) AWO3F405.51
STR_RESIST_S(I) = 1.0 / AWO3F405.52
& (SNOW_F/R_SNOW + (1.0-SNOW_F)/STR_RESIST_S(I)) AWO3F405.53
! AWO3F405.54
ELSE IF ((D1(JSNODEP+I-1).GT.0.0 .AND. RESIST_S(I).EQ.0.0) .OR. AWO3F405.55
& (D1(JICE_FRACTION+I-1).GT.0.0) ) THEN AWO3F405.56
STR_RESIST_S(I)=R_SNOW AWO3F405.57
! AWO3F405.58
END IF AWO3F405.59
! AWO3F405.60
! Calculate RES_FACTOR for NH3 AWO3F405.61
! AWO3F405.62
RES_FACTOR(I) = ARESIST(I) / AWO3F405.63
& (ARESIST(I)+ STR_RESIST_B(I)+STR_RESIST_S(I)) AWO3F405.64
! AWO3F405.65
END DO ! END I LOOP AWO3F405.66
! AWO3F405.67
! CALL TR_MIX FOR NH3 AWO3F405.68
! AWO3F405.69
IF (L_NH3_EM) THEN ! mix in surface emissions AWO3F405.70
! AWO3F405.71
CALL TR_MIX( AWO3F405.72
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AWO3F405.73
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AWO3F405.74
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AWO3F405.75
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AWO3F405.76
& ,TR_FLUX,D1(JNH3(1)) AWO3F405.77
& ,D1(JNH3_EM),RES_FACTOR,DRYDEP_STR AWO3F405.78
& ,NRML AWO3F405.79
& ,ICODE,TIMER) AWO3F405.80
! AWO3F405.81
ELSE ! no surface emissions AWO3F405.82
! AWO3F405.83
CALL TR_MIX( AWO3F405.84
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AWO3F405.85
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AWO3F405.86
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AWO3F405.87
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AWO3F405.88
& ,TR_FLUX,D1(JNH3(1)) AWO3F405.89
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AWO3F405.90
& ,NRML AWO3F405.91
& ,ICODE,TIMER) AWO3F405.92
END IF AWO3F405.93
! AWO3F405.94
IF (ICODE .GT. 0) GOTO 9999 AWO3F405.95
! AWO3F405.96
! WRITE TO STASH AWO3F405.97
! AWO3F405.98
IF(SF(300,3)) THEN ! write dry dep FLUX NH3 to stash AWO3F405.99
! Change sign of dry dep flux (otherwise negative) AWO3F405.100
DO I=FIRST_POINT,LAST_POINT AWO3F405.101
DRYDEP_STR(I) = -DRYDEP_STR(I) AWO3F405.102
END DO AWO3F405.103
! AWO3F405.104
CALL COPYDIAG(STASHWORK(SI(300,3,im_index)),DRYDEP_STR, AWO3F405.105
& FIRST_POINT,LAST_POINT, AWO3F405.106
& P_FIELD,ROW_LENGTH, AWO3F405.107
& im_ident,3,300, AWO3F405.108
*CALL ARGPPX AWO3F405.109
& ICODE,CMESSAGE) AWO3F405.110
AWO3F405.111
IF (ICODE .GT. 0) GOTO 9999 AWO3F405.112
END IF AWO3F405.113
! AWO3F405.114
END IF ! END OF L_SULPC_NH3 BLOCK AWO3F405.115
! AWO3F405.116
! ** FOR SO4_AITKEN MODE ** AJS1F401.459
! AJS1F401.460
DO I=FIRST_POINT,LAST_POINT AJS1F401.461
! AJS1F401.462
STR_RESIST_B(I)=RESB_SO4_AIT * RESIST_B(I) AJS1F401.463
STR_RESIST_S(I)=RESS_SO4_AIT * RESIST_S(I) AJS1F401.464
! AJS1F401.465
RES_FACTOR(I) = ARESIST(I) / AJS1F401.466
& (ARESIST(I)+STR_RESIST_B(I)+STR_RESIST_S(I)) AJS1F401.467
! AJS1F401.468
END DO AJS1F401.469
! AJS1F401.470
! CALL TR_MIX FOR SO4_AIT AJS1F401.471
! AJS1F401.472
CALL TR_MIX( AJS1F401.473
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AJS1F401.474
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AJS1F401.475
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AJS1F401.476
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AJS1F401.477
& ,TR_FLUX,D1(JSO4_AITKEN(1)) AJS1F401.478
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AJS1F401.479
& ,NRML AJS1F401.480
& ,ICODE,TIMER) AJS1F401.481
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.337
! AJS1F401.482
! WRITE TO STASH AJS1F401.483
! AJS1F401.484
IF(SF(271,3)) THEN ! write dry dep flux SO4_AIT to stash AJS1F401.485
! Change sign of dry dep flux (otherwise negative) AJS1F401.486
DO I=FIRST_POINT,LAST_POINT AJS1F401.487
DRYDEP_STR(I) = -DRYDEP_STR(I) AJS1F401.488
END DO AJS1F401.489
! AJS1F401.490
CALL COPYDIAG(STASHWORK(SI(271,3,im_index)),DRYDEP_STR, AJS1F401.491
& FIRST_POINT,LAST_POINT, AJS1F401.492
& P_FIELD,ROW_LENGTH, GPB1F403.338
& im_ident,3,271, GPB1F403.339
*CALL ARGPPX GPB1F403.340
& ICODE,CMESSAGE) GPB1F403.341
GPB1F403.342
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.343
END IF AJS1F401.494
! AJS1F401.495
IF(SF(275,3).OR.SF(283,3)) THEN ! write Rb for SO4_AIT to stash AWO1F404.149
CALL COPYDIAG(STASHWORK(SI(275,3,im_index)),STR_RESIST_B, AJS1F401.497
& FIRST_POINT,LAST_POINT, AJS1F401.498
& P_FIELD,ROW_LENGTH, GPB1F403.344
& im_ident,3,275, GPB1F403.345
*CALL ARGPPX GPB1F403.346
& ICODE,CMESSAGE) GPB1F403.347
GPB1F403.348
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.349
END IF AJS1F401.500
! AJS1F401.501
IF(SF(279,3).OR.SF(283,3)) THEN ! write Rs for SO4_AIT to stash AWO1F404.150
CALL COPYDIAG(STASHWORK(SI(279,3,im_index)),STR_RESIST_S, AJS1F401.503
& FIRST_POINT,LAST_POINT, AJS1F401.504
& P_FIELD,ROW_LENGTH, GPB1F403.350
& im_ident,3,279, GPB1F403.351
*CALL ARGPPX GPB1F403.352
& ICODE,CMESSAGE) GPB1F403.353
GPB1F403.354
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.355
END IF AJS1F401.506
C AJS1F401.507
! AJS1F401.508
! ** FOR SO4_ACCU MODE ** AJS1F401.509
! AJS1F401.510
DO I=FIRST_POINT,LAST_POINT AJS1F401.511
! AJS1F401.512
STR_RESIST_B(I)=RESB_SO4_ACC * RESIST_B(I) AJS1F401.513
STR_RESIST_S(I)=RESS_SO4_ACC * RESIST_S(I) AJS1F401.514
! AJS1F401.515
RES_FACTOR(I) = ARESIST(I) / AJS1F401.516
& (ARESIST(I)+STR_RESIST_B(I)+STR_RESIST_S(I)) AJS1F401.517
! AJS1F401.518
END DO AJS1F401.519
! AJS1F401.520
! CALL TR_MIX FOR SO4_ACC AJS1F401.521
! AJS1F401.522
CALL TR_MIX( AJS1F401.523
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AJS1F401.524
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AJS1F401.525
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AJS1F401.526
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AJS1F401.527
& ,TR_FLUX,D1(JSO4_ACCU(1)) AJS1F401.528
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AJS1F401.529
& ,NRML AJS1F401.530
& ,ICODE,TIMER) AJS1F401.531
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.356
! AJS1F401.532
! WRITE TO STASH AJS1F401.533
! AJS1F401.534
IF(SF(272,3)) THEN ! write dry dep flux SO4_ACC to stash AJS1F401.535
CL Change sign of dry dep flux (otherwise negative) AJS1F401.536
DO I=FIRST_POINT,LAST_POINT AJS1F401.537
DRYDEP_STR(I) = -DRYDEP_STR(I) AJS1F401.538
END DO AJS1F401.539
C AJS1F401.540
CALL COPYDIAG(STASHWORK(SI(272,3,im_index)),DRYDEP_STR, AJS1F401.541
& FIRST_POINT,LAST_POINT, AJS1F401.542
& P_FIELD,ROW_LENGTH, GPB1F403.357
& im_ident,3,272, GPB1F403.358
*CALL ARGPPX GPB1F403.359
& ICODE,CMESSAGE) GPB1F403.360
GPB1F403.361
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.362
END IF AJS1F401.544
C AJS1F401.545
IF(SF(276,3).OR.SF(284,3)) THEN ! write Rb for SO4_ACC to stash AWO1F404.151
CALL COPYDIAG(STASHWORK(SI(276,3,im_index)),STR_RESIST_B, AJS1F401.547
& FIRST_POINT,LAST_POINT, AJS1F401.548
& P_FIELD,ROW_LENGTH, GPB1F403.363
& im_ident,3,276, GPB1F403.364
*CALL ARGPPX GPB1F403.365
& ICODE,CMESSAGE) GPB1F403.366
GPB1F403.367
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.368
END IF AJS1F401.550
C AJS1F401.551
IF(SF(280,3).OR.SF(284,3)) THEN ! write Rs for SO4_ACC to stash AWO1F404.152
CALL COPYDIAG(STASHWORK(SI(280,3,im_index)),STR_RESIST_S, AJS1F401.553
& FIRST_POINT,LAST_POINT, AJS1F401.554
& P_FIELD,ROW_LENGTH, GPB1F403.369
& im_ident,3,280, GPB1F403.370
*CALL ARGPPX GPB1F403.371
& ICODE,CMESSAGE) GPB1F403.372
GPB1F403.373
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.374
END IF AJS1F401.556
C AJS1F401.557
! AJS1F401.558
! ** FOR SO4_DISS MODE ** AJS1F401.559
! AJS1F401.560
DO I=FIRST_POINT,LAST_POINT AJS1F401.561
! AJS1F401.562
STR_RESIST_B(I)=RESB_SO4_DIS * RESIST_B(I) AJS1F401.563
STR_RESIST_S(I)=RESS_SO4_DIS * RESIST_S(I) AJS1F401.564
! AJS1F401.565
RES_FACTOR(I) = ARESIST(I) / AJS1F401.566
& (ARESIST(I)+STR_RESIST_B(I)+STR_RESIST_S(I)) AJS1F401.567
! AJS1F401.568
END DO AJS1F401.569
! AJS1F401.570
! CALL TR_MIX FOR SO4_DIS AJS1F401.571
! AJS1F401.572
CALL TR_MIX( AJS1F401.573
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AJS1F401.574
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AJS1F401.575
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AJS1F401.576
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AJS1F401.577
& ,TR_FLUX,D1(JSO4_DISS(1)) AJS1F401.578
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AJS1F401.579
& ,NRML AJS1F401.580
& ,ICODE,TIMER) AJS1F401.581
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.375
! AJS1F401.582
! WRITE TO STASH AJS1F401.583
! AJS1F401.584
IF(SF(273,3)) THEN ! write dry depos SO4_DIS to stash AJS1F401.585
CL Change sign of dry dep flux (otherwise negative) AJS1F401.586
DO I=FIRST_POINT,LAST_POINT AJS1F401.587
DRYDEP_STR(I) = -DRYDEP_STR(I) AJS1F401.588
END DO AJS1F401.589
C AJS1F401.590
CALL COPYDIAG(STASHWORK(SI(273,3,im_index)),DRYDEP_STR, AJS1F401.591
& FIRST_POINT,LAST_POINT, AJS1F401.592
& P_FIELD,ROW_LENGTH, GPB1F403.376
& im_ident,3,273, GPB1F403.377
*CALL ARGPPX GPB1F403.378
& ICODE,CMESSAGE) GPB1F403.379
GPB1F403.380
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.381
END IF AJS1F401.594
C AJS1F401.595
IF(SF(277,3).OR.SF(285,3)) THEN ! write Rb for SO4_DIS to stash AWO1F404.153
CALL COPYDIAG(STASHWORK(SI(277,3,im_index)),STR_RESIST_B, AJS1F401.597
& FIRST_POINT,LAST_POINT, AJS1F401.598
& P_FIELD,ROW_LENGTH, GPB1F403.382
& im_ident,3,277, GPB1F403.383
*CALL ARGPPX GPB1F403.384
& ICODE,CMESSAGE) GPB1F403.385
GPB1F403.386
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.387
END IF AJS1F401.600
C AJS1F401.601
IF(SF(281,3).OR.SF(285,3)) THEN ! write Rs for SO4_DIS to stash AWO1F404.154
CALL COPYDIAG(STASHWORK(SI(281,3,im_index)),STR_RESIST_S, AJS1F401.603
& FIRST_POINT,LAST_POINT, AJS1F401.604
& P_FIELD,ROW_LENGTH, GPB1F403.388
& im_ident,3,281, GPB1F403.389
*CALL ARGPPX GPB1F403.390
& ICODE,CMESSAGE) GPB1F403.391
GPB1F403.392
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.393
END IF AJS1F401.606
C AJS1F401.607
! AJS1F401.608
! ** FOR DMS IF PRESENT ** AJS1F401.609
! AJS1F401.610
IF (L_SULPC_DMS) THEN AJS1F401.611
! AJS1F401.612
! CALL TR_MIX FOR DMS AJS1F401.613
! AJS1F401.614
IF (L_DMS_EM) THEN ! mix in surface emissions AJS1F401.615
! AJS1F401.616
CALL TR_MIX( AJS1F401.617
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AJS1F401.618
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AJS1F401.619
& ,WORK4(P_FIELDDA+1),WORK4(1) AJS1F401.620
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AJS1F401.621
& ,TR_FLUX,D1(JDMS(1)) AJS1F401.622
& ,D1(JDMS_EM),ZERO_FIELD,DRYDEP_STR AJS1F401.623
& ,NRML AJS1F401.624
& ,ICODE,TIMER) AJS1F401.625
! AJS1F401.626
ELSE ! no surface DMS emissions AJS1F401.627
! AJS1F401.628
CALL TR_MIX( AJS1F401.629
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AJS1F401.630
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AJS1F401.631
& ,WORK4(P_FIELDDA+1),WORK4(1) AJS1F401.632
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AJS1F401.633
& ,TR_FLUX,D1(JDMS(1)) AJS1F401.634
& ,ZERO_FIELD,ZERO_FIELD,DRYDEP_STR AJS1F401.635
& ,NRML AJS1F401.636
& ,ICODE,TIMER) AJS1F401.637
! AJS1F401.638
END IF AJS1F401.639
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.394
! AJS1F401.640
END IF ! END L_SULPC_DMS BLOCK AJS1F401.641
! AJS1F401.642
C AJS1F401.643
CL WRITE MORE DIAGNOSTICS TO STASH AJS1F401.644
C AJS1F401.645
IF(SF(286,3).OR.SF(282,3).OR.SF(283,3).OR.SF(284,3) AWO1F404.155
& .OR.SF(285,3)) THEN ! write aerodyn res to stash AWO1F404.156
CALL COPYDIAG(STASHWORK(SI(286,3,im_index)),ARESIST, AJS1F401.647
& FIRST_POINT,LAST_POINT, AJS1F401.648
& P_FIELD,ROW_LENGTH, GPB1F403.395
& im_ident,3,286, GPB1F403.396
*CALL ARGPPX GPB1F403.397
& ICODE,CMESSAGE) GPB1F403.398
GPB1F403.399
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.400
END IF AJS1F401.650
C AJS1F401.651
C AJS1F401.652
CL calculate deposition velocity=1/(Ra+Rb+Rc) from existing STASH data AJS1F401.653
C AJS1F401.654
IF(SF(282,3)) THEN ! deposition velocity SO2 AJS1F401.655
DO I=1,P_FIELD AJS1F401.656
STASHWORK(SI(282,3,im_index)+I-1)=1.0/ AJS1F401.657
& ( STASHWORK(SI(286,3,im_index)+I-1) + AJS1F401.658
& STASHWORK(SI(274,3,im_index)+I-1) + AJS1F401.659
& STASHWORK(SI(278,3,im_index)+I-1) ) AJS1F401.660
END DO AJS1F401.661
END IF AJS1F401.662
C AJS1F401.663
IF(SF(283,3)) THEN ! deposition velocity SO4_AIT AJS1F401.664
DO I=1,P_FIELD AJS1F401.665
STASHWORK(SI(283,3,im_index)+I-1)=1.0/ AJS1F401.666
& ( STASHWORK(SI(286,3,im_index)+I-1) + AJS1F401.667
& STASHWORK(SI(275,3,im_index)+I-1) + AJS1F401.668
& STASHWORK(SI(279,3,im_index)+I-1) ) AJS1F401.669
END DO AJS1F401.670
END IF AJS1F401.671
C AJS1F401.672
IF(SF(284,3)) THEN ! deposition velocity SO4_ACC AJS1F401.673
DO I=1,P_FIELD AJS1F401.674
STASHWORK(SI(284,3,im_index)+I-1)=1.0/ AJS1F401.675
& ( STASHWORK(SI(286,3,im_index)+I-1) + AJS1F401.676
& STASHWORK(SI(276,3,im_index)+I-1) + AJS1F401.677
& STASHWORK(SI(280,3,im_index)+I-1) ) AJS1F401.678
END DO AJS1F401.679
END IF AJS1F401.680
C AJS1F401.681
IF(SF(285,3)) THEN ! deposition velocity SO4_DIS AJS1F401.682
DO I=1,P_FIELD AJS1F401.683
STASHWORK(SI(285,3,im_index)+I-1)=1.0/ AJS1F401.684
& ( STASHWORK(SI(286,3,im_index)+I-1) + AJS1F401.685
& STASHWORK(SI(277,3,im_index)+I-1) + AJS1F401.686
& STASHWORK(SI(281,3,im_index)+I-1) ) AJS1F401.687
END DO AJS1F401.688
END IF AJS1F401.689
C AJS1F401.690
CL End of STASH for Sulphur Cycle AJS1F401.691
C AJS1F401.692
END IF ! END OF L_SULPC_SO2 BLOCK AJS1F401.693
C AJS1F401.694
CL***************************************************************** AJS1F401.695
! AWO3F405.119
IF (L_SOOT) THEN AWO3F405.120
! AWO3F405.121
! If required, add high level soot emissions AWO3F405.122
! AWO3F405.123
IF (L_SOOT_HILEM) THEN AWO3F405.124
! AWO3F405.125
CALL TRSRCE( AWO3F405.126
& A_LEVDEPC(JDELTA_AK+SOOT_HIGH_LEVEL-1), AWO3F405.127
& A_LEVDEPC(JDELTA_BK+SOOT_HIGH_LEVEL-1), AWO3F405.128
& P_FIELD, AWO3F405.129
& P_FIELD, AWO3F405.130
& D1(JPSTAR), AWO3F405.131
& D1(JSOOT_NEW(SOOT_HIGH_LEVEL)), AWO3F405.132
& D1(JSOOT_HILEM), AWO3F405.133
& SECS_PER_STEPim(atmos_im), AWO3F405.134
& I_HOUR, AWO3F405.135
& I_MINUTE, AWO3F405.136
& 0.0, ! amplitude of diurnal variation of emissions AWO3F405.137
& ICODE AWO3F405.138
& ) AWO3F405.139
! AWO3F405.140
IF (ICODE.GT.0) THEN AWO3F405.141
CMESSAGE='Error in TRSRCE' AWO3F405.142
RETURN AWO3F405.143
ENDIF AWO3F405.144
! AWO3F405.145
END IF ! L_SOOT_HILEM condition AWO3F405.146
! AWO3F405.147
! AWO3F405.148
! For RESIST_B check to eliminate possible negative values AWO3F405.149
DO I=FIRST_POINT,LAST_POINT AWO3F405.150
IF (RESIST_B(I) .LT. 0.0) THEN AWO3F405.151
RESIST_B(I) = 0.0 AWO3F405.152
END IF AWO3F405.153
END DO AWO3F405.154
AWO3F405.155
! Initialise stomatal resistance to zero AWO3F405.156
! AWO3F405.157
DO I=1,P_FIELD AWO3F405.158
RESIST_S(I)=0.0 AWO3F405.159
END DO AWO3F405.160
! AWO3F405.161
! Do dry deposition of 3 soot variables AWO3F405.162
! AWO3F405.163
! Fresh soot: AWO3F405.164
!~~~~~~~~~~~~ AWO3F405.165
! Calculate resistance values: AWO3F405.166
DO I=FIRST_POINT,LAST_POINT AWO3F405.167
! AWO3F405.168
STR_RESIST_B(I)=RESB_FreshSoot * RESIST_B(I) AWO3F405.169
STR_RESIST_S(I)=RESS_Soot * RESIST_S(I) AWO3F405.170
! AWO3F405.171
RES_FACTOR(I) = ARESIST(I) / AWO3F405.172
& (ARESIST(I)+STR_RESIST_B(I)+STR_RESIST_S(I)) AWO3F405.173
! AWO3F405.174
END DO AWO3F405.175
! AWO3F405.176
IF (L_SOOT_SUREM) THEN AWO3F405.177
CALL TR_MIX( AWO3F405.178
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AWO3F405.179
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AWO3F405.180
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AWO3F405.181
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AWO3F405.182
& ,TR_FLUX,D1(JSOOT_NEW(1)) AWO3F405.183
& ,D1(JSOOT_EM),RES_FACTOR,DRYDEP_STR AWO3F405.184
& ,NRML AWO3F405.185
& ,ICODE,TIMER) AWO3F405.186
! AWO3F405.187
ELSE AWO3F405.188
CALL TR_MIX( AWO3F405.189
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AWO3F405.190
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AWO3F405.191
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AWO3F405.192
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AWO3F405.193
& ,TR_FLUX,D1(JSOOT_NEW(1)) AWO3F405.194
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AWO3F405.195
& ,NRML AWO3F405.196
& ,ICODE,TIMER) AWO3F405.197
ENDIF AWO3F405.198
IF (ICODE.GT.0) THEN AWO3F405.199
CMESSAGE='Error in TR_MIX' AWO3F405.200
RETURN AWO3F405.201
ENDIF AWO3F405.202
! AWO3F405.203
! WRITE TO STASH. AWO3F405.204
! AWO3F405.205
IF(SF(301,3)) THEN ! write dry dep flux to stash AWO3F405.206
! Change sign of dry dep flux (otherwise negative) AWO3F405.207
DO I=FIRST_POINT,LAST_POINT AWO3F405.208
DRYDEP_STR(I) = -DRYDEP_STR(I) AWO3F405.209
END DO AWO3F405.210
! AWO3F405.211
CALL COPYDIAG(STASHWORK(SI(301,3,im_index)),DRYDEP_STR, AWO3F405.212
& FIRST_POINT,LAST_POINT, AWO3F405.213
& P_FIELD,ROW_LENGTH, AWO3F405.214
& im_ident,3,301, AWO3F405.215
*CALL ARGPPX AWO3F405.216
& ICODE,CMESSAGE) AWO3F405.217
IF (ICODE.GT.0) THEN AWO3F405.218
CMESSAGE='Error in COPYDIAG' AWO3F405.219
RETURN AWO3F405.220
ENDIF AWO3F405.221
END IF AWO3F405.222
! AWO3F405.223
! Aged soot: AWO3F405.224
!~~~~~~~~~~~~ AWO3F405.225
! Calculate resistance values: AWO3F405.226
DO I=FIRST_POINT,LAST_POINT AWO3F405.227
! AWO3F405.228
STR_RESIST_B(I)=RESB_AgedSoot * RESIST_B(I) AWO3F405.229
STR_RESIST_S(I)=RESS_Soot * RESIST_S(I) AWO3F405.230
! AWO3F405.231
RES_FACTOR(I) = ARESIST(I) / AWO3F405.232
& (ARESIST(I)+STR_RESIST_B(I)+STR_RESIST_S(I)) AWO3F405.233
! AWO3F405.234
END DO AWO3F405.235
! AWO3F405.236
CALL TR_MIX( AWO3F405.237
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AWO3F405.238
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AWO3F405.239
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AWO3F405.240
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AWO3F405.241
& ,TR_FLUX,D1(JSOOT_AGD(1)) AWO3F405.242
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AWO3F405.243
& ,NRML AWO3F405.244
& ,ICODE,TIMER) AWO3F405.245
IF (ICODE.GT.0) THEN AWO3F405.246
CMESSAGE='Error in TR_MIX' AWO3F405.247
RETURN AWO3F405.248
ENDIF AWO3F405.249
! AWO3F405.250
! WRITE TO STASH. AWO3F405.251
! AWO3F405.252
IF(SF(302,3)) THEN ! write dry dep flux to stash AWO3F405.253
CL Change sign of dry dep flux (otherwise negative) AWO3F405.254
DO I=FIRST_POINT,LAST_POINT AWO3F405.255
DRYDEP_STR(I) = -DRYDEP_STR(I) AWO3F405.256
END DO AWO3F405.257
C AWO3F405.258
CALL COPYDIAG(STASHWORK(SI(302,3,im_index)),DRYDEP_STR, AWO3F405.259
& FIRST_POINT,LAST_POINT, AWO3F405.260
& P_FIELD,ROW_LENGTH, AWO3F405.261
& im_ident,3,302, AWO3F405.262
*CALL ARGPPX AWO3F405.263
& ICODE,CMESSAGE) AWO3F405.264
IF (ICODE.GT.0) THEN AWO3F405.265
CMESSAGE='Error in COPYDIAG' AWO3F405.266
RETURN AWO3F405.267
ENDIF AWO3F405.268
END IF AWO3F405.269
! AWO3F405.270
! Soot in cloud water (occult deposition). AWO3F405.271
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ AWO3F405.272
! Calculate resistance values: AWO3F405.273
DO I=FIRST_POINT,LAST_POINT AWO3F405.274
! AWO3F405.275
STR_RESIST_B(I)=RESB_SootInCloud * RESIST_B(I) AWO3F405.276
STR_RESIST_S(I)=RESS_Soot * RESIST_S(I) AWO3F405.277
! AWO3F405.278
RES_FACTOR(I) = ARESIST(I) / AWO3F405.279
& (ARESIST(I)+STR_RESIST_B(I)+STR_RESIST_S(I)) AWO3F405.280
! AWO3F405.281
END DO AWO3F405.282
! AWO3F405.283
CALL TR_MIX( AWO3F405.284
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS AWO3F405.285
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) AWO3F405.286
& ,WORK4(P_FIELDDA+1),RHO_ARESIST AWO3F405.287
& ,D1(JPSTAR),SECS_PER_STEPim(atmos_im) AWO3F405.288
& ,TR_FLUX,D1(JSOOT_CLD(1)) AWO3F405.289
& ,ZERO_FIELD,RES_FACTOR,DRYDEP_STR AWO3F405.290
& ,NRML AWO3F405.291
& ,ICODE,TIMER) AWO3F405.292
IF (ICODE.GT.0) THEN AWO3F405.293
CMESSAGE='Error in TR_MIX' AWO3F405.294
RETURN AWO3F405.295
ENDIF AWO3F405.296
! AWO3F405.297
! WRITE TO STASH. AWO3F405.298
! AWO3F405.299
IF(SF(303,3)) THEN ! write dry dep flux to stash AWO3F405.300
! Change sign of dry dep flux (otherwise negative) AWO3F405.301
DO I=FIRST_POINT,LAST_POINT AWO3F405.302
DRYDEP_STR(I) = -DRYDEP_STR(I) AWO3F405.303
END DO AWO3F405.304
! AWO3F405.305
CALL COPYDIAG(STASHWORK(SI(303,3,im_index)),DRYDEP_STR, AWO3F405.306
& FIRST_POINT,LAST_POINT, AWO3F405.307
& P_FIELD,ROW_LENGTH, AWO3F405.308
& im_ident,3,303, AWO3F405.309
*CALL ARGPPX AWO3F405.310
& ICODE,CMESSAGE) AWO3F405.311
IF (ICODE.GT.0) THEN AWO3F405.312
CMESSAGE='Error in COPYDIAG' AWO3F405.313
RETURN AWO3F405.314
ENDIF AWO3F405.315
END IF AWO3F405.316
! AWO3F405.317
END IF ! End of L_Soot test AWO3F405.318
! AWO3F405.319
AWO3F405.320
CL******************************************************************** ACN1F405.21
CL SECTION 3.3.3 Implicit mixing of CARBON CYCLE tracers in b.layer ACN1F405.22
CL ACN1F405.23
CL******************************************************************** ACN1F405.24
! ACN1F405.25
IF (L_CO2_INTERACTIVE) THEN ! interactive co2 required ACN1F405.26
ACN1F405.27
! add Land fluxes together ACN1F405.28
DO I=1,LAND_FIELD ACN1F405.29
LAND_CO2_L(I) = RESP_S(I) ! soil respiration ACN1F405.30
& - WORK8(I) ! NPP ACN1F405.31
ENDDO ACN1F405.32
! un-compress to full field ACN1F405.33
CALL FROM_LAND_POINTS(LAND_CO2,LAND_CO2_L, ACN1F405.34
& D1(JLAND),P_FIELD,LAND_FIELD) ACN1F405.35
ACN1F405.36
! Add up components of CO2_FLUX ACN1F405.37
ACN1F405.38
DO I=1,P_FIELD ACN1F405.39
! (i) CO2 emissions from ancillary file. ACN1F405.40
IF (L_CO2_EMITS) THEN ACN1F405.41
IF ( D1(J_CO2_EMITS+I-1) .ne. RMDI ) THEN ACN1F405.42
CO2_FLUX(I) = CO2_FLUX(I) + D1(J_CO2_EMITS+I-1) ACN1F405.43
ENDIF ! not missing data ACN1F405.44
ENDIF ! include emissions from ancillary ACN1F405.45
ACN1F405.46
! (ii) CO2 flux from ocean. (+ve implies air to sea) ACN1F405.47
IF ( D1(J_CO2FLUX+I-1) .ne. RMDI ) THEN ACN1F405.48
CO2_FLUX(I) = CO2_FLUX(I) - D1(J_CO2FLUX+I-1) ACN1F405.49
ENDIF ! not missing data ACN1F405.50
ACN1F405.51
! (iii) CO2 flux from land processes. (+ve implies biosphere to atmos) ACN1F405.52
IF ( LAND_CO2(I) .ne. RMDI ) THEN ACN1F405.53
CO2_FLUX(I) = CO2_FLUX(I) + LAND_CO2(I) ACN1F405.54
ENDIF ! not missing data ACN1F405.55
ACN1F405.56
ENDDO ! loop over P_FIELD ACN1F405.57
ACN1F405.58
ACN1F405.59
CL STASH diagnostics of land surface and total fluxes ACN1F405.60
C ACN1F405.61
C Item 326 "CO2 land surface flux" (kg/m2/s) ACN1F405.62
C ACN1F405.63
IF (SF(326,3)) THEN ACN1F405.64
CALL COPYDIAG(STASHWORK(SI(326,3,im_index)),LAND_CO2, ACN1F405.65
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ACN1F405.66
& im_ident,3,326, ACN1F405.67
*CALL ARGPPX ACN1F405.68
& ICODE,CMESSAGE) ACN1F405.69
ACN1F405.70
IF (ICODE .GT. 0) GOTO 9999 ACN1F405.71
END IF ACN1F405.72
ACN1F405.73
C ACN1F405.74
C Item 327 "CO2 total flux to atmosphere" (kg/m2/s) ACN1F405.75
C ACN1F405.76
IF (SF(327,3)) THEN ACN1F405.77
CALL COPYDIAG(STASHWORK(SI(327,3,im_index)),CO2_FLUX, ACN1F405.78
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ACN1F405.79
& im_ident,3,327, ACN1F405.80
*CALL ARGPPX ACN1F405.81
& ICODE,CMESSAGE) ACN1F405.82
ACN1F405.83
IF (ICODE .GT. 0) GOTO 9999 ACN1F405.84
END IF ACN1F405.85
ACN1F405.86
ACN1F405.87
! Call TR_MIX for CO2 tracer with CO2_FLUX as calculated above ACN1F405.88
! note: ZERO_FIELD passed in for RHOKH_1 as no deposition required ACN1F405.89
CALL TR_MIX ( ACN1F405.90
& P_FIELD,BL_LEVELS,FIRST_ROW,ROW_LENGTH,ROWS ACN1F405.91
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK) ACN1F405.92
& ,WORK4(P_FIELDDA+1),WORK4(1) ACN1F405.93
& ,D1(JPSTAR) ACN1F405.94
& ,SECS_PER_STEPim(atmos_im) ACN1F405.95
& ,TR_FLUX,D1(JCO2(1)) ACN1F405.96
& ,CO2_FLUX,ZERO_FIELD,DRYDEP_STR ACN1F405.97
& ,NRML,ICODE,LTIMER ACN1F405.98
& ) ACN1F405.99
ACN1F405.100
ENDIF ! L_CO2_INTERACTIVE ACN1F405.101
ASJ1F304.185
IF (LTIMER) THEN ASJ1F304.186
CALL TIMER('TR_MIX',4) ASJ1F304.187
END IF ASJ1F304.188
ASJ1F304.189
ASJ1F304.190
! If the mixed phase precipitation scheme is used then T and Q are ADM3F404.426
! required to contain T liquid and Q(vapour+liquid) but at this stage ADM3F404.427
! will actually contain T liquid ice and Q(vapour+liquid+ice) if ADM3F404.428
! L_BL_LSPICE is false. ADM3F404.429
IF (L_LSPICE .AND. (.NOT. L_BL_LSPICE)) THEN ADM3F404.430
! T and Q do not contain the correct values if L_BL_LSPICE is false and ADM3F404.431
! the mixed phase precipitation scheme is selected. Correct them so that ADM3F404.432
! T(liquid+ice) becomes T(liquid) and ADM3F404.433
! Q(vapour+liquid+ice) becomes Q(vapour+liquid). ADM3F404.434
CALL BL_LSP( P_FIELD,FIRST_ROW,ROW_LENGTH,ROWS,BL_LEVELS, ADM3F404.435
& D1(JQCF(1)),D1(JQ(1)),D1(JTHETA(1)) ) ADM3F404.436
END IF ADM3F404.437
! ADM3F404.438
*IF DEF,GLOBAL BL_CTL1.209
C Set TSTAR at poles to mean of surrounding rows BL_CTL1.210
BL_CTL1.211
*IF DEF,MPP APBGF401.35
IF (at_top_of_LPG) THEN APBGF401.36
*ENDIF APBGF401.37
DO I=1,ROW_LENGTH APBGF401.38
D1(JTSTAR+TOP_ROW_START+I-2)=0.0 APBGF401.39
ENDDO APBGF401.40
*IF DEF,MPP APBGF401.41
ENDIF APBGF401.42
APBGF401.43
IF (at_base_of_LPG) THEN APBGF401.44
*ENDIF APBGF401.45
DO I=1,ROW_LENGTH APBGF401.46
D1(JTSTAR+P_BOT_ROW_START+I-2)=0.0 APBGF401.47
ENDDO APBGF401.48
*IF DEF,MPP APBGF401.49
ENDIF APBGF401.50
*ENDIF APBGF401.51
CALL POLAR(D1(JTSTAR),D1(JTSTAR),D1(JTSTAR), APB2F401.91
*CALL ARGFLDPT APB2F401.92
& P_FIELD,P_FIELD,P_FIELD, APB2F401.93
& TOP_ROW_START+ROW_LENGTH, APB2F401.94
& P_BOT_ROW_START-ROW_LENGTH, APB2F401.95
& ROW_LENGTH,1) APB2F401.96
*ELSE RB070693.7
C Set TSTAR at N & S rows (not computed) to adjacent rows RB070693.8
RB070693.9
*IF DEF,MPP APBGF401.52
IF (at_top_of_LPG) THEN APBGF401.53
*ENDIF APBGF401.54
DO I=1,ROW_LENGTH APBGF401.55
D1(JTSTAR+TOP_ROW_START+I-2)= APBGF401.56
& D1(JTSTAR+TOP_ROW_START+ROW_LENGTH+I-2) APBGF401.57
ENDDO APBGF401.58
*IF DEF,MPP APBGF401.59
ENDIF APBGF401.60
APBGF401.61
IF (at_base_of_LPG) THEN APBGF401.62
*ENDIF APBGF401.63
DO I=1,ROW_LENGTH APBGF401.64
D1(JTSTAR+P_BOT_ROW_START+I-2)= APBGF401.65
& D1(JTSTAR+P_BOT_ROW_START-ROW_LENGTH+I-2) APBGF401.66
ENDDO APBGF401.67
*IF DEF,MPP APBGF401.68
ENDIF APBGF401.69
*ENDIF APBGF401.70
*ENDIF BL_CTL1.218
BL_CTL1.219
IF (LEMCORR) THEN ASJ1F304.191
C BL_CTL1.221
C ADD SURFACE SENSIBLE HEAT FLUX INTO DIABATIC HEATING BL_CTL1.222
C FOR USE IN ENERGY CORRECTION PROCEDURE BL_CTL1.223
C BL_CTL1.224
IF (LTIMER) THEN BL_CTL1.225
CALL TIMER('FLX_DIAG',3) BL_CTL1.226
END IF BL_CTL1.227
C BL_CTL1.228
CALL FLUX_DIAG(STASHWORK(SI(217,3,im_index)),COS_P_LATITUDE, APB5F401.135
& P_FIELD,FIRST_POINT,POINTS, APB5F401.136
& 1.0,SECS_PER_STEPim(atmos_im),D1(JNET_FLUX)) GSM3F404.32
C BL_CTL1.232
IF (LTIMER) THEN BL_CTL1.233
CALL TIMER('FLX_DIAG',4) BL_CTL1.234
END IF BL_CTL1.235
ENDIF ! LEMCORR ASJ1F304.192
BL_CTL1.237
C Item 241: BL_CTL1.238
C Require surface and boundary layer fluxes as amounts for ITEM 241 BL_CTL1.239
IF (SF(241,3)) THEN BL_CTL1.240
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APBGF401.71
STASHWORK(SI(241,3,im_index)+I-1)= GDR4F305.38
& STASHWORK(SI(223,3,im_index)+I-1)*SECS_PER_STEPim(a_im) ADR1F305.48
END DO BL_CTL1.244
ENDIF BL_CTL1.245
BL_CTL1.246
C Item 207: rostar*ch*surf_layer_wind_shear BL_CTL1.247
BL_CTL1.248
IF (SF(207,3)) THEN BL_CTL1.249
CALL COPYDIAG(STASHWORK(SI(207,3,im_index)),WORK4 GDR4F305.39
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.401
& im_ident,3,207, GPB1F403.402
*CALL ARGPPX GPB1F403.403
& ICODE,CMESSAGE) GPB1F403.404
GPB1F403.405
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.406
END IF BL_CTL1.252
BL_CTL1.253
C Item 206: rostar*cd*surf_layer_wind_shear BL_CTL1.254
BL_CTL1.255
IF (SF(206,3)) THEN BL_CTL1.256
CALL COPYDIAG(STASHWORK(SI(206,3,im_index)),WORK5, GDR4F305.40
& FIRST_POINT,LAST_POINT,U_FIELD,ROW_LENGTH, GPB1F403.407
& im_ident,3,206, GPB1F403.408
*CALL ARGPPX GPB1F403.409
& ICODE,CMESSAGE) GPB1F403.410
GPB1F403.411
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.412
END IF BL_CTL1.260
BL_CTL1.261
CL BL_CTL1.262
!L 3.3 Call GLUE_CLD to calculate cloud fraction and AYY2F400.108
CL cloud water/ice content. BL_CTL1.264
BL_CTL1.265
IF (LTIMER) THEN ASJ1F304.193
CALL TIMER('LS_CLD ',3) BL_CTL1.267
END IF BL_CTL1.268
BL_CTL1.269
*IF DEF,GLOBAL BL_CTL1.270
BL_CTL1.271
FIRST_POINT=FIRST_VALID_PT APBGF401.72
POINTS=LAST_P_VALID_PT-FIRST_POINT+1 APBGF401.73
JS=FIRST_POINT-1 APBGF401.74
BL_CTL1.275
*ENDIF BL_CTL1.276
! ---------------------------------------------------------------------- AYY1F404.88
! L_LSPICE = .FALSE. PDF_QC_OR_CF_LIQ = cloud PDF QC value, AYY1F404.89
! PDF_BS_OR_CF_ICE = cloud PDF bs value, AYY1F404.90
! L_LSPICE = .TRUE. PDF_QC_OR_CF_LIQ = liquid cloud fraction. AYY1F404.91
! PDF_BS_OR_CF_ICE = frozen cloud fraction. AYY1F404.92
! ---------------------------------------------------------------------- AYY1F404.93
CALL GLUE_CLD( AYY2F400.109
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),D1(JPSTAR+JS), BL_CTL1.279
& RHCRIT,BL_LEVELS,D1(JRHC(1)+JS), ASK1F405.226
& POINTS,P_FIELD,D1(JTHETA(1)+JS), BL_CTL1.281
& CLOUD_FRACTION(FIRST_POINT,1),D1(JQ(1)+JS),D1(JQCF(1)+JS), BL_CTL1.282
& D1(JQCL(1)+JS),PDF_QC_OR_CF_LIQ(FIRST_POINT,1), AYY1F404.94
& PDF_BS_OR_CF_ICE(FIRST_POINT,1),ICODE) AYY1F404.95
! AYY1F404.96
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.413
BL_CTL1.284
*IF DEF,GLOBAL BL_CTL1.285
BL_CTL1.286
FIRST_POINT=START_POINT_NO_HALO APBGF401.75
POINTS=END_P_POINT_NO_HALO-FIRST_POINT+1 APBGF401.76
JS=FIRST_POINT-1 APBGF401.77
BL_CTL1.290
*ENDIF BL_CTL1.291
BL_CTL1.292
IF (LTIMER) THEN ASJ1F304.194
CALL TIMER('LS_CLD ',4) BL_CTL1.294
END IF BL_CTL1.295
BL_CTL1.296
CL 3.4 Copy diagnostic information to D1 for STASH processing BL_CTL1.297
BL_CTL1.298
C Item 202 surface heat flux AJS1F401.696
AJS1F401.697
IF (SF(202,3)) THEN AJS1F401.698
AJS1F401.699
CALL COPYDIAG(STASHWORK(SI(202,3,im_index)),SURF_HT_FLUX, AJS1F401.700
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.414
& im_ident,3,202, GPB1F403.415
*CALL ARGPPX GPB1F403.416
& ICODE,CMESSAGE) GPB1F403.417
GPB1F403.418
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.419
AJS1F401.702
END IF AJS1F401.703
ARE1F405.17
C Item 314 surface net radiation ARE1F405.18
ARE1F405.19
IF (SF(314,3)) THEN ARE1F405.20
ARE1F405.21
CALL COPYDIAG(STASHWORK(SI(314,3,im_index)),SURF_RADFLUX, ARE1F405.22
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ARE1F405.23
& im_ident,3,314, ARE1F405.24
*CALL ARGPPX ARE1F405.25
& ICODE,CMESSAGE) ARE1F405.26
ARE1F405.27
IF (ICODE .GT. 0) GOTO 9999 ARE1F405.28
ARE1F405.29
END IF ARE1F405.30
AJS1F401.704
! Item 305 boundary layer type indicator 1: Stable boundary layer ARN0F405.28
ARN0F405.29
IF (SF(305,3)) THEN ARN0F405.30
ARN0F405.31
CALL COPYDIAG(STASHWORK(SI(305,3,im_index)),BL_TYPE_1, ARN0F405.32
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ARN0F405.33
& im_ident,3,305, ARN0F405.34
*CALL ARGPPX ARN0F405.35
& ICODE,CMESSAGE) ARN0F405.36
ARN0F405.37
IF (ICODE .GT. 0) GOTO 9999 ARN0F405.38
ARN0F405.39
END IF ARN0F405.40
ARN0F405.41
! Item 306 boundary layer indicator type 2: Sc over stable surface layer ARN0F405.42
ARN0F405.43
IF (SF(306,3)) THEN ARN0F405.44
ARN0F405.45
CALL COPYDIAG(STASHWORK(SI(306,3,im_index)),BL_TYPE_2, ARN0F405.46
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ARN0F405.47
& im_ident,3,306, ARN0F405.48
*CALL ARGPPX ARN0F405.49
& ICODE,CMESSAGE) ARN0F405.50
ARN0F405.51
IF (ICODE .GT. 0) GOTO 9999 ARN0F405.52
ARN0F405.53
END IF ARN0F405.54
ARN0F405.55
! Item 307 boundary layer type indicator 3: Well-mixed boundary layer ARN0F405.56
ARN0F405.57
IF (SF(307,3)) THEN ARN0F405.58
CALL COPYDIAG(STASHWORK(SI(307,3,im_index)),BL_TYPE_3, ARN0F405.59
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ARN0F405.60
& im_ident,3,307, ARN0F405.61
*CALL ARGPPX ARN0F405.62
& ICODE,CMESSAGE) ARN0F405.63
ARN0F405.64
IF (ICODE .GT. 0) GOTO 9999 ARN0F405.65
ARN0F405.66
END IF ARN0F405.67
ARN0F405.68
! Item 308 boundary layer type indicator 4: Decoupled Sc ARN0F405.69
! not overlying Cu ARN0F405.70
ARN0F405.71
IF (SF(308,3)) THEN ARN0F405.72
ARN0F405.73
CALL COPYDIAG(STASHWORK(SI(308,3,im_index)),BL_TYPE_4, ARN0F405.74
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ARN0F405.75
& im_ident,3,308, ARN0F405.76
*CALL ARGPPX ARN0F405.77
& ICODE,CMESSAGE) ARN0F405.78
ARN0F405.79
IF (ICODE .GT. 0) GOTO 9999 ARN0F405.80
ARN0F405.81
END IF ARN0F405.82
ARN0F405.83
! Item 309 boundary layer type indicator 5: Decoupled Sc ARN0F405.84
! overlying Cu ARN0F405.85
ARN0F405.86
IF (SF(309,3)) THEN ARN0F405.87
ARN0F405.88
CALL COPYDIAG(STASHWORK(SI(309,3,im_index)),BL_TYPE_5, ARN0F405.89
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ARN0F405.90
& im_ident,3,309, ARN0F405.91
*CALL ARGPPX ARN0F405.92
& ICODE,CMESSAGE) ARN0F405.93
ARN0F405.94
IF (ICODE .GT. 0) GOTO 9999 ARN0F405.95
ARN0F405.96
END IF ARN0F405.97
ARN0F405.98
! Item 310 boundary layer type indicator 6: Cumulus capped ARN0F405.99
! boundary layer ARN0F405.100
ARN0F405.101
IF (SF(310,3)) THEN ARN0F405.102
ARN0F405.103
CALL COPYDIAG(STASHWORK(SI(310,3,im_index)),BL_TYPE_6, ARN0F405.104
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ARN0F405.105
& im_ident,3,310, ARN0F405.106
*CALL ARGPPX ARN0F405.107
& ICODE,CMESSAGE) ARN0F405.108
ARN0F405.109
IF (ICODE .GT. 0) GOTO 9999 ARN0F405.110
ARN0F405.111
END IF ARN0F405.112
ARN0F405.113
C Item 229 soil evaporation BL_CTL1.299
BL_CTL1.300
IF (SF(229,3)) THEN BL_CTL1.301
BL_CTL1.302
CALL COPYDIAG(STASHWORK(SI(229,3,im_index)),SOIL_EVAPORATION, GDR4F305.41
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.420
& im_ident,3,229, GPB1F403.421
*CALL ARGPPX GPB1F403.422
& ICODE,CMESSAGE) GPB1F403.423
GPB1F403.424
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.425
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APBGF401.78
STASHWORK(SI(229,3,im_index)+I-1)= GDR4F305.42
& STASHWORK(SI(229,3,im_index)+I-1)*SECS_PER_STEPim(a_im) ADR1F305.50
END DO BL_CTL1.308
BL_CTL1.309
END IF BL_CTL1.310
BL_CTL1.311
C ITEM 312 POTENTIAL EVAPORATION - RATE ANG1F405.12
IF (SF(312,3)) THEN ANG1F405.13
CALL COPYDIAG(STASHWORK(SI(312,3,im_index)),EPOT, ANG1F405.14
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ANG1F405.15
& im_ident,3,312, ANG1F405.16
*CALL ARGPPX ANG1F405.17
& ICODE,CMESSAGE) ANG1F405.18
ANG1F405.19
IF (ICODE .GT. 0) GOTO 9999 ANG1F405.20
ANG1F405.21
END IF ANG1F405.22
ANG1F405.23
CL ITEM 311 POTENTIAL EVAPORATION - AMOUNT ANG1F405.24
IF (SF(311,3)) THEN ANG1F405.25
CALL COPYDIAG(STASHWORK(SI(311,3,im_index)),EPOT, ANG1F405.26
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ANG1F405.27
& im_ident,3,311, ANG1F405.28
*CALL ARGPPX ANG1F405.29
& ICODE,CMESSAGE) ANG1F405.30
ANG1F405.31
IF (ICODE .GT. 0) GOTO 9999 ANG1F405.32
DO I=FIRST_VALID_PT,LAST_P_VALID_PT ANG1F405.33
STASHWORK(SI(311,3,im_index)+I-1)= ANG1F405.34
& STASHWORK(SI(311,3,im_index)+I-1)*SECS_PER_STEPim(a_im) ANG1F405.35
END DO ANG1F405.36
ANG1F405.37
END IF ANG1F405.38
ANG1F405.39
CL ITEM 313 SOIL MOISTURE AVAILABILITY ANG1F405.40
IF (SF(313,3)) THEN ANG1F405.41
CALL FROM_LAND_POINTS(STASHWORK(SI(313,3,im_index)), ANG1F405.42
& FSMC,D1(JLAND),P_FIELD,LAND_FIELD) ANG1F405.43
ENDIF ANG1F405.44
C Item 230 canopy evaporation BL_CTL1.312
BL_CTL1.313
IF (SF(230,3)) THEN BL_CTL1.314
BL_CTL1.315
CALL COPYDIAG(STASHWORK(SI(230,3,im_index)),CANOPY_EVAPORATION, GDR4F305.43
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.426
& im_ident,3,230, GPB1F403.427
*CALL ARGPPX GPB1F403.428
& ICODE,CMESSAGE) GPB1F403.429
GPB1F403.430
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.431
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APBGF401.79
STASHWORK(SI(230,3,im_index)+I-1)= GDR4F305.44
& STASHWORK(SI(230,3,im_index)+I-1)*SECS_PER_STEPim(a_im) ADR1F305.51
END DO BL_CTL1.321
BL_CTL1.322
END IF BL_CTL1.323
BL_CTL1.324
C Item 231 snow sublimation BL_CTL1.325
BL_CTL1.326
IF (SF(231,3)) THEN BL_CTL1.327
BL_CTL1.328
CALL COPYDIAG(STASHWORK(SI(231,3,im_index)),SNOW_SUBLIMATION, GDR4F305.45
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.432
& im_ident,3,231, GPB1F403.433
*CALL ARGPPX GPB1F403.434
& ICODE,CMESSAGE) GPB1F403.435
GPB1F403.436
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.437
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APBGF401.80
STASHWORK(SI(231,3,im_index)+I-1)= GDR4F305.46
& STASHWORK(SI(231,3,im_index)+I-1)*SECS_PER_STEPim(a_im) ADR1F305.52
END DO BL_CTL1.334
BL_CTL1.335
END IF BL_CTL1.336
BL_CTL1.337
C Item 203 CD BL_CTL1.338
BL_CTL1.339
IF (SF(203,3)) THEN BL_CTL1.340
BL_CTL1.341
CALL COPYDIAG(STASHWORK(SI(203,3,im_index)),WORK1, GDR4F305.47
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.438
& im_ident,3,203, GPB1F403.439
*CALL ARGPPX GPB1F403.440
& ICODE,CMESSAGE) GPB1F403.441
GPB1F403.442
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.443
BL_CTL1.344
END IF BL_CTL1.345
BL_CTL1.346
C Item 204 CH BL_CTL1.347
BL_CTL1.348
IF (SF(204,3)) THEN BL_CTL1.349
BL_CTL1.350
CALL COPYDIAG(STASHWORK(SI(204,3,im_index)),WORK2, GDR4F305.48
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.444
& im_ident,3,204, GPB1F403.445
*CALL ARGPPX GPB1F403.446
& ICODE,CMESSAGE) GPB1F403.447
GPB1F403.448
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.449
BL_CTL1.353
END IF BL_CTL1.354
BL_CTL1.355
C Item 205 SURF_WINDSHEAR BL_CTL1.356
BL_CTL1.357
IF (SF(205,3)) THEN BL_CTL1.358
BL_CTL1.359
CALL COPYDIAG(STASHWORK(SI(205,3,im_index)),WORK3, GDR4F305.49
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.450
& im_ident,3,205, GPB1F403.451
*CALL ARGPPX GPB1F403.452
& ICODE,CMESSAGE) GPB1F403.453
GPB1F403.454
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.455
BL_CTL1.362
END IF BL_CTL1.363
PC120793.17
C Item 254 1.5 M TL APC5F400.5
APC5F400.6
IF (SF(254,3)) THEN APC5F400.7
APC5F400.8
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APBGF401.81
STASHWORK(SI(254,3,im_index)+I-1) = APC5F400.10
& STASHWORK(SI(236,3,im_index)+I-1) APC5F400.11
END DO APC5F400.12
APC5F400.13
END IF APC5F400.14
APC5F400.15
C Item 255 1.5 M QT APC5F400.16
APC5F400.17
IF (SF(255,3)) THEN APC5F400.18
APC5F400.19
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APBGF401.82
STASHWORK(SI(255,3,im_index)+I-1) = APC5F400.21
& STASHWORK(SI(237,3,im_index)+I-1) APC5F400.22
END DO APC5F400.23
APC5F400.24
END IF APC5F400.25
APC5F400.26
IF (SF(236,3).OR.SF(237,3).OR.SF(247,3).OR.SF(248,3).OR. APC0F405.5
& SF(242,3).OR.SF(243,3).OR.SF(244,3).OR.SF(245,3) ASW0F304.8
& .OR.SF(250,3).OR.SF(253,3)) APC0F405.6
& THEN PC120793.22
CL BL_CTL1.367
!L 3.5 SPECIAL CALL GLUE_CLD TO CONVERT 1.5M TL and QT to T and Q AYY2F400.112
CL CLOUD FRACTION AND WATER/ICE CONTENT ALSO DIAGNOSED AT 1.5M BL_CTL1.369
BL_CTL1.370
IF (LTIMER) THEN ASJ1F304.195
CALL TIMER('LS_CLD ',3) BL_CTL1.372
END IF BL_CTL1.373
! AYY1F404.103
! L_lspice_if3: AYY1F404.104
IF (L_LSPICE) THEN AYY1F404.105
! QCF should really be taken at 1.5m too for consistency. AYY1F404.106
DO I = 1, POINTS AYY1F404.107
WORK1(JS+I) = D1(JQCF(1)+JS+I) AYY1F404.108
END DO AYY1F404.109
END IF ! L_lspice_if3 AYY1F404.110
BL_CTL1.374
CALL GLUE_CLD(AK1P5M,BK1P5M, D1(JPSTAR+JS), AYY2F400.113
& RHCRIT,1,D1(JRHC(1)+JS), ASK1F405.227
& POINTS,P_FIELD, BL_CTL1.379
& STASHWORK(SI(236,3,im_index)+JS),WORK3(1+JS), GDR4F305.56
& STASHWORK(SI(237,3,im_index)+JS),WORK1(1+JS),WORK2(1+JS), GDR4F305.57
& WORK6(1+JS),WORK5(1+JS),ICODE) AYY2F400.114
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.470
BL_CTL1.382
IF (LTIMER) THEN ASJ1F304.196
CALL TIMER('LS_CLD ',4) BL_CTL1.384
END IF BL_CTL1.385
CL ITEM 250 Dewpoint at 1.5m ASW0F304.10
IF (SF(250,3)) THEN ASW0F304.11
CALL DEWPNT(STASHWORK(SI(237,3,im_index)+JS),D1(JPSTAR+JS), GDR4F305.59
& STASHWORK(SI(236,3,im_index)+JS), GDR4F305.60
& POINTS,WORK6(1+JS)) ASW0F304.14
CALL COPYDIAG(STASHWORK(SI(250,3,im_index)),WORK6 GDR4F305.61
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.471
& im_ident,3,250, GPB1F403.472
*CALL ARGPPX GPB1F403.473
& ICODE,CMESSAGE) GPB1F403.474
GPB1F403.475
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.476
ENDIF ASW0F304.17
BL_CTL1.386
CL ITEM 242 cloud fraction at 1.5m BL_CTL1.387
IF (SF(242,3)) THEN BL_CTL1.388
CALL COPYDIAG(STASHWORK(SI(242,3,im_index)),WORK3 GDR4F305.62
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.477
& im_ident,3,242, GPB1F403.478
*CALL ARGPPX GPB1F403.479
& ICODE,CMESSAGE) GPB1F403.480
GPB1F403.481
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.482
END IF BL_CTL1.391
BL_CTL1.392
CL ITEM 243 cloud liquid water at 1.5m BL_CTL1.393
IF (SF(243,3)) THEN BL_CTL1.394
CALL COPYDIAG(STASHWORK(SI(243,3,im_index)),WORK2 GDR4F305.63
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.483
& im_ident,3,243, GPB1F403.484
*CALL ARGPPX GPB1F403.485
& ICODE,CMESSAGE) GPB1F403.486
GPB1F403.487
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.488
END IF BL_CTL1.397
BL_CTL1.398
CL ITEM 244 cloud ice content at 1.5m BL_CTL1.399
IF (SF(244,3)) THEN BL_CTL1.400
CALL COPYDIAG(STASHWORK(SI(244,3,im_index)),WORK1 GDR4F305.64
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.489
& im_ident,3,244, GPB1F403.490
*CALL ARGPPX GPB1F403.491
& ICODE,CMESSAGE) GPB1F403.492
GPB1F403.493
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.494
END IF BL_CTL1.403
BL_CTL1.404
! From Version 4.5, VISBTY and FOG_FR based on T, Q, QCF, APC0F405.7
! so calls moved to after GLUE_CLD call APC0F405.8
RB200193.7
CL ITEM 247 visibility at 1.5m RB200193.8
IF (SF(247,3)) THEN RB200193.9
APC0F405.9
CALL VISBTY(AK1P5M,BK1P5M, D1(JPSTAR+JS), APC0F405.10
& STASHWORK(SI(236,3,im_index)+JS), ! Screen T APC0F405.11
& STASHWORK(SI(237,3,im_index)+JS), ! Screen Q APC0F405.12
& WORK2(1+JS),WORK1(1+JS), ! Screen Qcl, Qcf APC0F405.13
& D1(JMURK(1)+JS), ! Aerosol APC0F405.14
& 0.5,RHCRIT,L_MURK, ! 0.5 for median APC0F405.15
& POINTS,WORK3(1+JS)) APC0F405.16
APC0F405.17
CALL COPYDIAG(STASHWORK(SI(247,3,im_index)),WORK3 GDR4F305.71
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.495
& im_ident,3,247, GPB1F403.496
*CALL ARGPPX GPB1F403.497
& ICODE,CMESSAGE) GPB1F403.498
GPB1F403.499
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.500
END IF APC0F405.18
APC0F405.19
C Item 248 FOG FRACTION at 1.5 m APC0F405.20
IF (SF(248,3)) THEN APC0F405.21
CALL FOG_FR(AK1P5M,BK1P5M, D1(JPSTAR+JS), APC0F405.22
& RHCRIT,1, APC0F405.23
& POINTS,P_FIELD, APC0F405.24
& STASHWORK(SI(236,3,im_index)+JS),D1(JMURK(1)+JS),L_MURK, APC0F405.25
& STASHWORK(SI(237,3,im_index)+JS),WORK2(1+JS),WORK1(1+JS), APC0F405.26
& VISFOG,WORK3(1+JS),1, APC0F405.27
& ICODE) APC0F405.28
! APC0F405.29
IF (ICODE .GT. 0) GOTO 9999 APC0F405.30
APC0F405.31
CALL COPYDIAG(STASHWORK(SI(248,3,im_index)),WORK3 APC0F405.32
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, APC0F405.33
& im_ident,3,248, APC0F405.34
*CALL ARGPPX APC0F405.35
& ICODE,CMESSAGE) APC0F405.36
APC0F405.37
IF (ICODE .GT. 0) GOTO 9999 APC0F405.38
END IF APC0F405.39
APC0F405.40
C Item 253 MIST FRACTION at 1.5 m APC0F405.41
IF (SF(253,3)) THEN APC0F405.42
CALL FOG_FR(AK1P5M,BK1P5M, D1(JPSTAR+JS), APC0F405.43
& RHCRIT,1, APC0F405.44
& POINTS,P_FIELD, APC0F405.45
& STASHWORK(SI(236,3,im_index)+JS),D1(JMURK(1)+JS),L_MURK, APC0F405.46
& STASHWORK(SI(237,3,im_index)+JS),WORK2(1+JS),WORK1(1+JS), APC0F405.47
& VISMIST,WORK3(1+JS),1, APC0F405.48
& ICODE) APC0F405.49
! APC0F405.50
IF (ICODE .GT. 0) GOTO 9999 APC0F405.51
APC0F405.52
CALL COPYDIAG(STASHWORK(SI(253,3,im_index)),WORK3 APC0F405.53
& ,FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, APC0F405.54
& im_ident,3,253, APC0F405.55
*CALL ARGPPX APC0F405.56
& ICODE,CMESSAGE) APC0F405.57
APC0F405.58
IF (ICODE .GT. 0) GOTO 9999 APC0F405.59
END IF APC0F405.60
APC0F405.61
CL ITEM 245 relative humidity at 1.5m APC0F405.62
C re-use WORK3 for qsat at 1.5m APC0F405.63
IF (SF(245,3)) THEN APC0F405.64
CALL QSAT(WORK3,STASHWORK(SI(236,3,im_index)+JS), APC0F405.65
& D1(JPSTAR+JS),POINTS) APC0F405.66
DO I=1,POINTS APC0F405.67
STASHWORK(SI(245,3,im_index)+JS+I-1) = APC0F405.68
& STASHWORK(SI(237,3,im_index)+JS+I-1)/WORK3(I)*100. APC0F405.69
ENDDO APC0F405.70
END IF BL_CTL1.413
BL_CTL1.414
ENDIF !special call for 1.5m quantities BL_CTL1.415
BL_CTL1.416
CL ITEM 238 DEEP SOIL TEMPERATURES BL_CTL1.417
BL_CTL1.418
IF (SF(238,3)) THEN BL_CTL1.419
CALL SET_LEVELS_LIST(ST_LEVELS,LEN_STLIST, AJS1F401.705
& STLIST(1,STINDEX(1,238,3,im_index)), GDR4F305.11
& LIST,STASH_LEVELS,NUM_STASH_LEVELS+1,ICODE,CMESSAGE) BL_CTL1.421
IF (ICODE.GT.0) THEN BL_CTL1.422
RETURN BL_CTL1.423
END IF BL_CTL1.424
LEVEL_OUT=0 BL_CTL1.425
DO LEVEL=1,ST_LEVELS AJS1F401.706
IF (LIST(LEVEL)) THEN ASJ1F304.197
LEVEL_OUT=LEVEL_OUT+1 BL_CTL1.428
CALL FROM_LAND_POINTS ( GDR4F305.72
& STASHWORK(SI(238,3,im_index)+(LEVEL_OUT-1) GDR4F305.73
& *P_FIELD),D1(J_DEEP_SOIL_TEMP(LEVEL)),D1(JLAND), @DYALLOC.655
& P_FIELD,LAND_FIELD) BL_CTL1.431
END IF BL_CTL1.432
END DO BL_CTL1.433
END IF BL_CTL1.434
BL_CTL1.435
BL_CTL1.436
CL ITEM 287: CANOPY EVAPORATION ON NON-ICE S-TILES ABX1F405.221
ABX1F405.222
IF (SF(287,3)) THEN ABX1F405.223
CALL SET_PSEUDO_LIST(NTYPE-1,LEN_STLIST, ABX1F405.224
& STLIST(1,STINDEX(1,287,3,im_index)), ABX1F405.225
& PLLNIT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.226
& ICODE,CMESSAGE) ABX1F405.227
IF (ICODE.GT.0) THEN ABX1F405.228
RETURN ABX1F405.229
END IF ABX1F405.230
PSLEVEL_OUT=0 ABX1F405.231
DO PSLEVEL=1,NTYPE-1 ABX1F405.232
IF (PLLNIT(PSLEVEL)) THEN ABX1F405.233
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.234
CALL FROM_LAND_POINTS ( ABX1F405.235
& STASHWORK(SI(287,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.236
& *P_FIELD),ECAN_TILE(1,PSLEVEL), ABX1F405.237
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.238
END IF ABX1F405.239
END DO ABX1F405.240
END IF ABX1F405.241
ABX1F405.242
ABX1F405.243
CL ITEM 288: TRANSPIRATION + SOIL EVAPORATION ON NON-ICE S-TILES ABX1F405.244
ABX1F405.245
IF (SF(288,3)) THEN ABX1F405.246
CALL SET_PSEUDO_LIST(NTYPE-1,LEN_STLIST, ABX1F405.247
& STLIST(1,STINDEX(1,288,3,im_index)), ABX1F405.248
& PLLNIT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.249
& ICODE,CMESSAGE) ABX1F405.250
IF (ICODE.GT.0) THEN ABX1F405.251
RETURN ABX1F405.252
END IF ABX1F405.253
PSLEVEL_OUT=0 ABX1F405.254
DO PSLEVEL=1,NTYPE-1 ABX1F405.255
IF (PLLNIT(PSLEVEL)) THEN ABX1F405.256
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.257
CALL FROM_LAND_POINTS ( ABX1F405.258
& STASHWORK(SI(288,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.259
& *P_FIELD),ESOIL_TILE(1,PSLEVEL), ABX1F405.260
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.261
END IF ABX1F405.262
END DO ABX1F405.263
END IF ABX1F405.264
ABX1F405.265
ABX1F405.266
CL ITEM 289: GROSS PRIMARY PRODUCTIVITY ON PLANT FUNCTIONAL TYPES ABX1F405.267
ABX1F405.268
IF (SF(289,3)) THEN ABX1F405.269
CALL SET_PSEUDO_LIST(NPFT,LEN_STLIST, ABX1F405.270
& STLIST(1,STINDEX(1,289,3,im_index)), ABX1F405.271
& PLLPFT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.272
& ICODE,CMESSAGE) ABX1F405.273
IF (ICODE.GT.0) THEN ABX1F405.274
RETURN ABX1F405.275
END IF ABX1F405.276
PSLEVEL_OUT=0 ABX1F405.277
DO PSLEVEL=1,NPFT ABX1F405.278
IF (PLLPFT(PSLEVEL)) THEN ABX1F405.279
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.280
CALL FROM_LAND_POINTS ( ABX1F405.281
& STASHWORK(SI(289,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.282
& *P_FIELD),GPP_FT(1,PSLEVEL), ABX1F405.283
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.284
END IF ABX1F405.285
END DO ABX1F405.286
END IF ABX1F405.287
ABX1F405.288
ABX1F405.289
CL ITEM 290: SURFACE SENSIBLE HEAT FLUX ON S-TILES ABX1F405.290
ABX1F405.291
IF (SF(290,3)) THEN ABX1F405.292
CALL SET_PSEUDO_LIST(NTYPE,LEN_STLIST, ABX1F405.293
& STLIST(1,STINDEX(1,290,3,im_index)), ABX1F405.294
& PLLTYPE,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.295
& ICODE,CMESSAGE) ABX1F405.296
IF (ICODE.GT.0) THEN ABX1F405.297
RETURN ABX1F405.298
END IF ABX1F405.299
PSLEVEL_OUT=0 ABX1F405.300
DO PSLEVEL=1,NTYPE ABX1F405.301
IF (PLLTYPE(PSLEVEL)) THEN ABX1F405.302
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.303
CALL FROM_LAND_POINTS ( ABX1F405.304
& STASHWORK(SI(290,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.305
& *P_FIELD),FTL_TILE(1,PSLEVEL), ABX1F405.306
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.307
END IF ABX1F405.308
END DO ABX1F405.309
END IF ABX1F405.310
ABX1F405.311
ABX1F405.312
CL ITEM 291: NET PRIMARY PRODUCTIVITY ON PLANT FUNCTIONAL TYPES ABX1F405.313
ABX1F405.314
IF (SF(291,3)) THEN ABX1F405.315
CALL SET_PSEUDO_LIST(NPFT,LEN_STLIST, ABX1F405.316
& STLIST(1,STINDEX(1,291,3,im_index)), ABX1F405.317
& PLLPFT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.318
& ICODE,CMESSAGE) ABX1F405.319
IF (ICODE.GT.0) THEN ABX1F405.320
RETURN ABX1F405.321
END IF ABX1F405.322
PSLEVEL_OUT=0 ABX1F405.323
DO PSLEVEL=1,NPFT ABX1F405.324
IF (PLLPFT(PSLEVEL)) THEN ABX1F405.325
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.326
CALL FROM_LAND_POINTS ( ABX1F405.327
& STASHWORK(SI(291,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.328
& *P_FIELD),NPP_FT(1,PSLEVEL), ABX1F405.329
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.330
END IF ABX1F405.331
END DO ABX1F405.332
END IF ABX1F405.333
ABX1F405.334
ABX1F405.335
CL ITEM 292: PLANT RESPIRATION ON PLANT FUNCTIONAL TYPES ABX1F405.336
ABX1F405.337
IF (SF(292,3)) THEN ABX1F405.338
CALL SET_PSEUDO_LIST(NPFT,LEN_STLIST, ABX1F405.339
& STLIST(1,STINDEX(1,292,3,im_index)), ABX1F405.340
& PLLPFT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.341
& ICODE,CMESSAGE) ABX1F405.342
IF (ICODE.GT.0) THEN ABX1F405.343
RETURN ABX1F405.344
END IF ABX1F405.345
PSLEVEL_OUT=0 ABX1F405.346
DO PSLEVEL=1,NPFT ABX1F405.347
IF (PLLPFT(PSLEVEL)) THEN ABX1F405.348
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.349
CALL FROM_LAND_POINTS ( ABX1F405.350
& STASHWORK(SI(292,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.351
& *P_FIELD),RESP_P_FT(1,PSLEVEL), ABX1F405.352
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.353
END IF ABX1F405.354
END DO ABX1F405.355
END IF ABX1F405.356
ABX1F405.357
ABX1F405.358
CL ITEM 293: SOIL RESPIRATION ABX1F405.359
ABX1F405.360
IF (SF(293,3)) THEN ABX1F405.361
CALL FROM_LAND_POINTS ( ABX1F405.362
& STASHWORK(SI(293,3,im_index)),RESP_S, ABX1F405.363
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.364
END IF ABX1F405.365
ABX1F405.366
ABX1F405.367
CL ITEM 294: BULK RICHARDSON NUMBER ON S-TILES ABX1F405.368
ABX1F405.369
IF (SF(294,3)) THEN ABX1F405.370
CALL SET_PSEUDO_LIST(NTYPE,LEN_STLIST, ABX1F405.371
& STLIST(1,STINDEX(1,294,3,im_index)), ABX1F405.372
& PLLTYPE,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.373
& ICODE,CMESSAGE) ABX1F405.374
IF (ICODE.GT.0) THEN ABX1F405.375
RETURN ABX1F405.376
END IF ABX1F405.377
PSLEVEL_OUT=0 ABX1F405.378
DO PSLEVEL=1,NTYPE ABX1F405.379
IF (PLLTYPE(PSLEVEL)) THEN ABX1F405.380
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.381
CALL FROM_LAND_POINTS ( ABX1F405.382
& STASHWORK(SI(294,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.383
& *P_FIELD),RIB_TILE(1,PSLEVEL), ABX1F405.384
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.385
END IF ABX1F405.386
END DO ABX1F405.387
END IF ABX1F405.388
ABX1F405.389
ABX1F405.390
CL ITEM 295: FRACTIONAL SNOW COVER ABX1F405.391
ABX1F405.392
IF (SF(295,3)) THEN ABX1F405.393
CALL FROM_LAND_POINTS ( ABX1F405.394
& STASHWORK(SI(295,3,im_index)),SNOW_FRAC, ABX1F405.395
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.396
END IF ABX1F405.397
ABX1F405.398
ABX1F405.399
CL ITEM 315: SNOW-ADJUSTED TILE FRACTIONS ABX1F405.400
ABX1F405.401
IF (SF(315,3)) THEN ABX1F405.402
CALL SET_PSEUDO_LIST(NTYPE,LEN_STLIST, ABX1F405.403
& STLIST(1,STINDEX(1,315,3,im_index)), ABX1F405.404
& PLLTYPE,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.405
& ICODE,CMESSAGE) ABX1F405.406
IF (ICODE.GT.0) THEN ABX1F405.407
RETURN ABX1F405.408
END IF ABX1F405.409
PSLEVEL_OUT=0 ABX1F405.410
DO PSLEVEL=1,NTYPE ABX1F405.411
IF (PLLTYPE(PSLEVEL)) THEN ABX1F405.412
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.413
CALL FROM_LAND_POINTS ( ABX1F405.414
& STASHWORK(SI(315,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.415
& *P_FIELD),TILE_FRAC(1,PSLEVEL), ABX1F405.416
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.417
END IF ABX1F405.418
END DO ABX1F405.419
END IF ABX1F405.420
ABX1F405.421
ABX1F405.422
CL ITEM 316: SURFACE TEMPERATURE ON TILES ABX1F405.423
ABX1F405.424
IF (SF(316,3)) THEN ABX1F405.425
CALL SET_PSEUDO_LIST(NTYPE,LEN_STLIST, ABX1F405.426
& STLIST(1,STINDEX(1,316,3,im_index)), ABX1F405.427
& PLLTYPE,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.428
& ICODE,CMESSAGE) ABX1F405.429
IF (ICODE.GT.0) THEN ABX1F405.430
RETURN ABX1F405.431
END IF ABX1F405.432
PSLEVEL_OUT=0 ABX1F405.433
DO PSLEVEL=1,NTYPE ABX1F405.434
IF (PLLTYPE(PSLEVEL)) THEN ABX1F405.435
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.436
CALL FROM_LAND_POINTS ( ABX1F405.437
& STASHWORK(SI(316,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.438
& *P_FIELD),D1(JTSTAR_TYP+((PSLEVEL-1)*LAND_FIELD)), ABX1F405.439
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.440
END IF ABX1F405.441
END DO ABX1F405.442
END IF ABX1F405.443
ABX1F405.444
ABX1F405.445
CL ITEM 317: UNDERLYING TILE FRACTIONS ABX1F405.446
ABX1F405.447
IF (SF(317,3)) THEN ABX1F405.448
CALL SET_PSEUDO_LIST(NTYPE,LEN_STLIST, ABX1F405.449
& STLIST(1,STINDEX(1,317,3,im_index)), ABX1F405.450
& PLLTYPE,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.451
& ICODE,CMESSAGE) ABX1F405.452
IF (ICODE.GT.0) THEN ABX1F405.453
RETURN ABX1F405.454
END IF ABX1F405.455
PSLEVEL_OUT=0 ABX1F405.456
DO PSLEVEL=1,NTYPE ABX1F405.457
IF (PLLTYPE(PSLEVEL)) THEN ABX1F405.458
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.459
CALL FROM_LAND_POINTS ( ABX1F405.460
& STASHWORK(SI(317,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.461
& *P_FIELD),D1(JFRAC_TYP+((PSLEVEL-1)*LAND_FIELD)), ABX1F405.462
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.463
END IF ABX1F405.464
END DO ABX1F405.465
END IF ABX1F405.466
ABX1F405.467
ABX1F405.468
CL ITEM 318: LEAF AREA INDEX ON PLANT FUNCTIONAL TYPES ABX1F405.469
ABX1F405.470
IF (SF(318,3)) THEN ABX1F405.471
CALL SET_PSEUDO_LIST(NPFT,LEN_STLIST, ABX1F405.472
& STLIST(1,STINDEX(1,318,3,im_index)), ABX1F405.473
& PLLPFT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.474
& ICODE,CMESSAGE) ABX1F405.475
IF (ICODE.GT.0) THEN ABX1F405.476
RETURN ABX1F405.477
END IF ABX1F405.478
PSLEVEL_OUT=0 ABX1F405.479
DO PSLEVEL=1,NPFT ABX1F405.480
IF (PLLPFT(PSLEVEL)) THEN ABX1F405.481
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.482
CALL FROM_LAND_POINTS ( ABX1F405.483
& STASHWORK(SI(318,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.484
& *P_FIELD),D1(JLAI_PFT+((PSLEVEL-1)*LAND_FIELD)), ABX1F405.485
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.486
END IF ABX1F405.487
END DO ABX1F405.488
END IF ABX1F405.489
ABX1F405.490
ABX1F405.491
CL ITEM 319: CANOPY HEIGHT ON PLANT FUNCTIONAL TYPES ABX1F405.492
ABX1F405.493
IF (SF(319,3)) THEN ABX1F405.494
CALL SET_PSEUDO_LIST(NPFT,LEN_STLIST, ABX1F405.495
& STLIST(1,STINDEX(1,319,3,im_index)), ABX1F405.496
& PLLPFT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.497
& ICODE,CMESSAGE) ABX1F405.498
IF (ICODE.GT.0) THEN ABX1F405.499
RETURN ABX1F405.500
END IF ABX1F405.501
PSLEVEL_OUT=0 ABX1F405.502
DO PSLEVEL=1,NPFT ABX1F405.503
IF (PLLPFT(PSLEVEL)) THEN ABX1F405.504
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.505
CALL FROM_LAND_POINTS ( ABX1F405.506
& STASHWORK(SI(319,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.507
& *P_FIELD),D1(JCANHT_PFT+((PSLEVEL-1)*LAND_FIELD)), ABX1F405.508
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.509
END IF ABX1F405.510
END DO ABX1F405.511
END IF ABX1F405.512
ABX1F405.513
ABX1F405.514
CL ITEM 320: SOIL CARBON CONTENT ABX1F405.515
ABX1F405.516
IF (SF(320,3)) THEN ABX1F405.517
CALL FROM_LAND_POINTS ( ABX1F405.518
& STASHWORK(SI(320,3,im_index)),D1(JSOIL_CARB), ABX1F405.519
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.520
END IF ABX1F405.521
ABX1F405.522
ABX1F405.523
CL ITEM 321: CANOPY WATER CONTENT ON NON-ICE TILES ABX1F405.524
ABX1F405.525
IF (SF(321,3)) THEN ABX1F405.526
CALL SET_PSEUDO_LIST(NTYPE-1,LEN_STLIST, ABX1F405.527
& STLIST(1,STINDEX(1,321,3,im_index)), ABX1F405.528
& PLLNIT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.529
& ICODE,CMESSAGE) ABX1F405.530
IF (ICODE.GT.0) THEN ABX1F405.531
RETURN ABX1F405.532
END IF ABX1F405.533
PSLEVEL_OUT=0 ABX1F405.534
DO PSLEVEL=1,NTYPE-1 ABX1F405.535
IF (PLLNIT(PSLEVEL)) THEN ABX1F405.536
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.537
CALL FROM_LAND_POINTS ( ABX1F405.538
& STASHWORK(SI(321,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.539
& *P_FIELD),D1(JCAN_WATER_NIT+((PSLEVEL-1)*LAND_FIELD)), ABX1F405.540
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.541
END IF ABX1F405.542
END DO ABX1F405.543
END IF ABX1F405.544
ABX1F405.545
ABX1F405.546
CL ITEM 322: CANOPY CAPACITY ON NON-ICE TILES ABX1F405.547
ABX1F405.548
IF (SF(322,3)) THEN ABX1F405.549
CALL SET_PSEUDO_LIST(NTYPE-1,LEN_STLIST, ABX1F405.550
& STLIST(1,STINDEX(1,322,3,im_index)), ABX1F405.551
& PLLNIT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.552
& ICODE,CMESSAGE) ABX1F405.553
IF (ICODE.GT.0) THEN ABX1F405.554
RETURN ABX1F405.555
END IF ABX1F405.556
PSLEVEL_OUT=0 ABX1F405.557
DO PSLEVEL=1,NTYPE-1 ABX1F405.558
IF (PLLNIT(PSLEVEL)) THEN ABX1F405.559
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.560
CALL FROM_LAND_POINTS ( ABX1F405.561
& STASHWORK(SI(322,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.562
& *P_FIELD),D1(JCATCH_NIT+((PSLEVEL-1)*LAND_FIELD)), ABX1F405.563
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.564
END IF ABX1F405.565
END DO ABX1F405.566
END IF ABX1F405.567
ABX1F405.568
ABX1F405.569
CL ITEM 323: SNOW TEMPERATURE ABX1F405.570
ABX1F405.571
IF (SF(323,3)) THEN ABX1F405.572
CALL FROM_LAND_POINTS ( ABX1F405.573
& STASHWORK(SI(323,3,im_index)),D1(JTSNOW), ABX1F405.574
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.575
END IF ABX1F405.576
ABX1F405.577
ABX1F405.578
CL ITEM 324: ROUGHNESS LENGTH OF BASE TILES ABX1F405.579
ABX1F405.580
IF (SF(324,3)) THEN ABX1F405.581
CALL SET_PSEUDO_LIST(NTYPE,LEN_STLIST, ABX1F405.582
& STLIST(1,STINDEX(1,324,3,im_index)), ABX1F405.583
& PLLTYPE,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.584
& ICODE,CMESSAGE) ABX1F405.585
IF (ICODE.GT.0) THEN ABX1F405.586
RETURN ABX1F405.587
END IF ABX1F405.588
PSLEVEL_OUT=0 ABX1F405.589
DO PSLEVEL=1,NTYPE ABX1F405.590
IF (PLLTYPE(PSLEVEL)) THEN ABX1F405.591
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.592
CALL FROM_LAND_POINTS ( ABX1F405.593
& STASHWORK(SI(324,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.594
& *P_FIELD),D1(JZ0_TYP+((PSLEVEL-1)*LAND_FIELD)), ABX1F405.595
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.596
END IF ABX1F405.597
END DO ABX1F405.598
END IF ABX1F405.599
ABX1F405.600
ABX1F405.601
CL ITEM 325: LEAF TURNOVER RATE ON PLANT FUNCTIONAL TYPES ABX1F405.602
ABX1F405.603
IF (SF(325,3)) THEN ABX1F405.604
CALL SET_PSEUDO_LIST(NPFT,LEN_STLIST, ABX1F405.605
& STLIST(1,STINDEX(1,325,3,im_index)), ABX1F405.606
& PLLPFT,STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO, ABX1F405.607
& ICODE,CMESSAGE) ABX1F405.608
IF (ICODE.GT.0) THEN ABX1F405.609
RETURN ABX1F405.610
END IF ABX1F405.611
PSLEVEL_OUT=0 ABX1F405.612
DO PSLEVEL=1,NPFT ABX1F405.613
IF (PLLPFT(PSLEVEL)) THEN ABX1F405.614
PSLEVEL_OUT=PSLEVEL_OUT+1 ABX1F405.615
CALL FROM_LAND_POINTS ( ABX1F405.616
& STASHWORK(SI(325,3,im_index)+(PSLEVEL_OUT-1) ABX1F405.617
& *P_FIELD),G_LEAF(1,PSLEVEL), ABX1F405.618
& D1(JLAND),P_FIELD,LAND_FIELD) ABX1F405.619
END IF ABX1F405.620
END DO ABX1F405.621
END IF ABX1F405.622
ABX1F405.623
ABX1F405.624
C Item 239 Cloud water after boundary layer BL_CTL1.437
BL_CTL1.438
IF (SF(239,3)) THEN ASJ1F304.198
BL_CTL1.440
CALL COPYDIAG_3D(STASHWORK(SI(239,3,im_index)),D1(JQCL(1)), GDR4F305.74
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, BL_CTL1.442
& P_LEVELS,STLIST(1,STINDEX(1,239,3,im_index)),LEN_STLIST, GDR4F305.12
& STASH_LEVELS,NUM_STASH_LEVELS+1, BL_CTL1.444
& im_ident,3,239, GPB1F403.501
*CALL ARGPPX GPB1F403.502
& ICODE,CMESSAGE) BL_CTL1.445
BL_CTL1.446
IF (ICODE.GT.0) THEN BL_CTL1.447
RETURN BL_CTL1.448
END IF BL_CTL1.449
BL_CTL1.450
END IF BL_CTL1.451
BL_CTL1.452
C Item 240 Cloud ice after boundary layer BL_CTL1.453
BL_CTL1.454
IF (SF(240,3)) THEN ASJ1F304.199
BL_CTL1.456
CALL COPYDIAG_3D(STASHWORK(SI(240,3,im_index)),D1(JQCF(1)), GDR4F305.75
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, BL_CTL1.458
& P_LEVELS,STLIST(1,STINDEX(1,240,3,im_index)),LEN_STLIST, GDR4F305.13
& STASH_LEVELS,NUM_STASH_LEVELS+1, BL_CTL1.460
& im_ident,3,240, GPB1F403.503
*CALL ARGPPX GPB1F403.504
& ICODE,CMESSAGE) BL_CTL1.461
BL_CTL1.462
IF (ICODE.GT.0) THEN BL_CTL1.463
RETURN BL_CTL1.464
END IF BL_CTL1.465
BL_CTL1.466
END IF BL_CTL1.467
BL_CTL1.468
CL ITEM 251 silhouette area of orography per unit area ASJ1F304.200
IF (SF(251,3)) THEN ASJ1F304.201
CALL FROM_LAND_POINTS(STASHWORK(SI(251,3,im_index)), GDR4F305.78
& D1(JOROG_SIL),D1(JLAND),P_FIELD,LAND_FIELD) GDR4F305.79
ENDIF ASJ1F304.204
ASJ1F304.205
CL ITEM 252 half of peak to trough height ASJ1F304.206
IF (SF(252,3)) THEN ASJ1F304.207
CALL FROM_LAND_POINTS(STASHWORK(SI(252,3,im_index)), GDR4F305.80
& D1(JOROG_HO2),D1(JLAND),P_FIELD,LAND_FIELD) GDR4F305.81
ENDIF AJS1F401.707
AJS1F401.708
C AJS1F401.709
CL ITEM 259 Canopy Conductance AJS1F401.710
IF (SF(259,3)) THEN AJS1F401.711
CALL FROM_LAND_POINTS(STASHWORK(SI(259,3,im_index)), AJS1F401.712
& D1(JGS),D1(JLAND),P_FIELD,LAND_FIELD) AJS1F401.713
ENDIF AJS1F401.714
C AJS1F401.715
C ITEM 260 Transpiration required as amounts AJS1F401.716
C AJS1F401.717
IF (SF(260,3)) THEN AJS1F401.718
DO I=FIRST_VALID_PT,LAST_P_VALID_PT GPB1F403.505
STASHWORK(SI(260,3,im_index)+I-1)= AJS1F401.720
& WORK10(I)*SECS_PER_STEPim(a_im) AJS1F401.721
END DO AJS1F401.722
ENDIF AJS1F401.723
C AJS1F401.724
CL ITEM 261 Gross Primary Productivity AJS1F401.725
IF (SF(261,3)) THEN AJS1F401.726
CALL FROM_LAND_POINTS(STASHWORK(SI(261,3,im_index)), AJS1F401.727
& WORK7,D1(JLAND),P_FIELD,LAND_FIELD) AJS1F401.728
ENDIF AJS1F401.729
AJS1F401.730
CL ITEM 262 Net Primary Productivity AJS1F401.731
IF (SF(262,3)) THEN AJS1F401.732
CALL FROM_LAND_POINTS(STASHWORK(SI(262,3,im_index)), AJS1F401.733
& WORK8,D1(JLAND),P_FIELD,LAND_FIELD) AJS1F401.734
ENDIF AJS1F401.735
C AJS1F401.736
CL ITEM 263 Plant Respiration AJS1F401.737
IF (SF(263,3)) THEN AJS1F401.738
CALL FROM_LAND_POINTS(STASHWORK(SI(263,3,im_index)), AJS1F401.739
& WORK9,D1(JLAND),P_FIELD,LAND_FIELD) AJS1F401.740
ENDIF AJS1F401.741
AJS1F401.742
CL ITEM 264 leaf area index AJS1F401.743
IF (SF(264,3)) THEN AJS1F401.744
CALL FROM_LAND_POINTS(STASHWORK(SI(264,3,im_index)), AJS1F401.745
& D1(JLAI),D1(JLAND),P_FIELD,LAND_FIELD) AJS1F401.746
ENDIF AJS1F401.747
C AJS1F401.748
CL ITEM 265 canopy height AJS1F401.749
IF (SF(265,3)) THEN AJS1F401.750
CALL FROM_LAND_POINTS(STASHWORK(SI(265,3,im_index)), AJS1F401.751
& D1(JCANHT),D1(JLAND),P_FIELD,LAND_FIELD) AJS1F401.752
ENDIF ASJ1F304.210
ASJ1F304.211
CL Rate-equivalents of items 229, 230, 231 and 260 ABX1F405.625
C ABX1F405.626
C Item 296 "soil evaporation" (includes transpiration") rate (kg/m2/s) ABX1F405.627
C ABX1F405.628
IF (SF(296,3)) THEN ABX1F405.629
ABX1F405.630
CALL COPYDIAG(STASHWORK(SI(296,3,im_index)),SOIL_EVAPORATION, ABX1F405.631
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ABX1F405.632
& im_ident,3,296, ABX1F405.633
*CALL ARGPPX ABX1F405.634
& ICODE,CMESSAGE) ABX1F405.635
ABX1F405.636
IF (ICODE .GT. 0) GOTO 9999 ABX1F405.637
ABX1F405.638
END IF ABX1F405.639
C ABX1F405.640
C Item 297 canopy evaporation rate (kg/m2/s) ABX1F405.641
C ABX1F405.642
IF (SF(297,3)) THEN ABX1F405.643
ABX1F405.644
CALL COPYDIAG(STASHWORK(SI(297,3,im_index)),CANOPY_EVAPORATION, ABX1F405.645
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ABX1F405.646
& im_ident,3,297, ABX1F405.647
*CALL ARGPPX ABX1F405.648
& ICODE,CMESSAGE) ABX1F405.649
ABX1F405.650
IF (ICODE .GT. 0) GOTO 9999 ABX1F405.651
ABX1F405.652
END IF ABX1F405.653
C ABX1F405.654
C Item 298 snow sublimation rate (kg/m2/s) ABX1F405.655
C ABX1F405.656
IF (SF(298,3)) THEN ABX1F405.657
ABX1F405.658
CALL COPYDIAG(STASHWORK(SI(298,3,im_index)),SNOW_SUBLIMATION, ABX1F405.659
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ABX1F405.660
& im_ident,3,298, ABX1F405.661
*CALL ARGPPX ABX1F405.662
& ICODE,CMESSAGE) ABX1F405.663
ABX1F405.664
IF (ICODE .GT. 0) GOTO 9999 ABX1F405.665
ABX1F405.666
END IF ABX1F405.667
C ABX1F405.668
C ITEM 299 Transpiration rate (kg/m2/s) ABX1F405.669
C ABX1F405.670
IF (SF(299,3)) THEN ABX1F405.671
DO I=FIRST_VALID_PT,LAST_P_VALID_PT ABX1F405.672
STASHWORK(SI(299,3,im_index)+I-1)= ABX1F405.673
& WORK10(I) ABX1F405.674
END DO ABX1F405.675
ENDIF ABX1F405.676
C ABX1F405.677
CL Extend remaining diagnostic information to full horizontal field BL_CTL1.475
BL_CTL1.476
CALL EXTDIAG(STASHWORK,SI(1,3,im_index),SF(1,3),201,NITEMS, GDR4F305.82
& INT3,ROW_LENGTH, BL_CTL1.478
& STLIST,LEN_STLIST,STINDEX(1,1,3,im_index),2,STASH_LEVELS, GDR4F305.14
& NUM_STASH_LEVELS+1, STASH_PSEUDO_LEVELS, BL_CTL1.480
& NUM_STASH_PSEUDO, GPB1F403.1279
& im_ident,3, GPB1F403.1280
*CALL ARGPPX GPB1F403.1281
& ICODE,CMESSAGE) GPB1F403.1282
BL_CTL1.482
IF (ICODE.GT.0) THEN ASJ1F304.212
RETURN BL_CTL1.484
ENDIF BL_CTL1.485
BL_CTL1.486
*IF DEF,GLOBAL BL_CTL1.487
BL_CTL1.488
CL ITEM 219 X component surface and BL wind stress BL_CTL1.489
CL ITEM 220 Y component surface and BL wind stress BL_CTL1.490
CL Call POLAR_UV if either X,Y components requested for each level BL_CTL1.491
IF (SF(219,3).OR.SF(220,3)) THEN ASJ1F304.213
CALL POLAR_UV(STASHWORK(SI(219,3,im_index)), APB2F401.227
& STASHWORK(SI(220,3,im_index)), APB2F401.228
& ROW_LENGTH,U_FIELD,BL_LEVELS, APB2F401.229
*CALL ARGFLDPT APB2F401.230
& COS_LONGITUDE,SIN_LONGITUDE) APB2F401.231
END IF BL_CTL1.499
CL ITEMS 225,226 X and Y 10 M wind BL_CTL1.500
CL Call POLAR_UV if both X,Y components requested BL_CTL1.501
CL and compute 10m windspeed from 2 components if requested TJ181193.7
IF (SF(225,3).AND.SF(226,3) ) THEN ASJ1F304.214
CALL POLAR_UV(STASHWORK(SI(225,3,im_index)), GDR4F305.85
& STASHWORK(SI(226,3,im_index)), GDR4F305.86
& ROW_LENGTH,U_FIELD,1, APB2F401.232
*CALL ARGFLDPT APB2F401.233
& COS_LONGITUDE,SIN_LONGITUDE) APB2F401.234
END IF BL_CTL1.506
BL_CTL1.507
*ENDIF BL_CTL1.508
TJ181193.8
CL ITEM 249 10m wind speed - NB: dependent on components 225 and 226 TJ181193.9
IF (SF(225,3).AND.SF(226,3).AND.SF(249,3)) THEN ASJ1F304.215
DO I=FIRST_VALID_PT,LAST_U_VALID_PT APBGF401.83
STASHWORK(SI(249,3,im_index)+I-1) = GDR4F305.88
& SQRT ( STASHWORK(SI(225,3,im_index)+I-1) * GDR4F305.89
& STASHWORK(SI(225,3,im_index)+I-1) + GDR4F305.90
& STASHWORK(SI(226,3,im_index)+I-1) * GDR4F305.91
& STASHWORK(SI(226,3,im_index)+I-1) ) GDR4F305.92
ENDDO TJ181193.15
END IF TJ181193.16
BL_CTL1.509
IF (LTIMER) THEN ASJ1F304.216
CALL TIMER('STASH ',3) BL_CTL1.511
END IF BL_CTL1.512
BL_CTL1.513
CALL STASH(a_sm,a_im,3,STASHWORK, GKR0F305.909
*CALL ARGSIZE @DYALLOC.658
*CALL ARGD1 @DYALLOC.659
*CALL ARGDUMA @DYALLOC.660
*CALL ARGDUMO @DYALLOC.661
*CALL ARGDUMW GKR1F401.191
*CALL ARGSTS @DYALLOC.662
*CALL ARGPPX GKR0F305.910
& ICODE,CMESSAGE) @DYALLOC.666
BL_CTL1.515
IF (LTIMER) THEN ASJ1F304.217
CALL TIMER('STASH ',4) BL_CTL1.517
END IF BL_CTL1.518
BL_CTL1.519
C ----------------------------------------------------- BL_CTL1.520
BL_CTL1.521
9999 CONTINUE GPB1F403.506
RETURN BL_CTL1.522
END BL_CTL1.523
BL_CTL1.524
*ENDIF BL_CTL1.525