SUBROUTINE ATM_PHYS( 1,76@DYALLOC.327
& P_FIELDDA,LAND_FIELDDA,SM_LEVELSDA, AJS1F401.174
& TILE_FIELDDA, ARE1F404.16
& ROW_LENGTHDA,P_LEVELSDA,Q_LEVELSDA,BL_LEVELSDA, ARN1F404.81
& L_RADHEAT,RADHEAT_DIM1, ARN1F404.82
*CALL ARGSIZE 
@DYALLOC.329
*CALL ARGD1 @DYALLOC.330
*CALL ARGDUMA @DYALLOC.331
*CALL ARGDUMO @DYALLOC.332
*CALL ARGDUMW GKR1F401.172
*CALL ARGSTS @DYALLOC.333
*CALL ARGPTRA @DYALLOC.334
*CALL ARGPTRO @DYALLOC.335
*CALL ARGCONA @DYALLOC.336
*CALL ARGCNVI RB300993.3
*CALL ARGPPX GKR0F305.888
*CALL ARGFLDPT APB1F401.7
*IF DEF,FRADIO GGH3F401.3
& RADINCS, @DYALLOC.338
*ENDIF @DYALLOC.339
& ICODE,CMESSAGE,WRITD1_TEST) GSS1F304.1184
ATMPHY1.34
IMPLICIT NONE ATMPHY1.35
ATMPHY1.36
*CALL CMAXSIZE @DYALLOC.340
*CALL CSUBMODL GSS1F305.920
*CALL TYPSIZE @DYALLOC.341
*CALL TYPD1 @DYALLOC.342
*CALL TYPDUMA @DYALLOC.343
*CALL TYPDUMO @DYALLOC.344
*CALL TYPDUMW GKR1F401.173
*CALL TYPSTS @DYALLOC.345
*CALL TYPPTRA @DYALLOC.346
*CALL TYPPTRO @DYALLOC.347
*CALL TYPCONA @DYALLOC.348
*CALL TYPCNVI RB300993.4
*CALL PPXLOOK GKR0F305.889
! All TYPFLDPT arguments are intent IN APB1F401.8
*CALL TYPFLDPT APB1F401.9
*IF DEF,FRADIO GGH3F401.4
*CALL CRADINCS @DYALLOC.350
*ENDIF @DYALLOC.351
INTEGER ! Extra copies of lengths for @DYALLOC.352
& P_FIELDDA, ! dynamic allocation: P_FIELD @DYALLOC.353
& SM_LEVELSDA, ! dynamic allocation: SM_LEVELS AJS1F401.176
& LAND_FIELDDA, ! dynamic allocation: LAND_FIELD AJS1F401.177
& TILE_FIELDDA, ! and LAND_FIELD for tiled diags ARE1F404.17
& ROW_LENGTHDA, ! and ROW_LENGTH @DYALLOC.354
& P_LEVELSDA, ! and P_LEVELS @DYALLOC.355
& Q_LEVELSDA, ! and Q_LEVELS @DYALLOC.356
& BL_LEVELSDA, ! and BL_LEVELS ARN1F404.83
& RADHEAT_DIM1, ! Required for array dimensions ARN1F404.84
! ! for RADHEAT ARN1F404.85
& ICODE ! Return code : 0 Normal exit ATMPHY1.41
! : >0 Error condition GSS1F304.1185
CHARACTER*80 CMESSAGE TS150793.15
ATMPHY1.45
LOGICAL L_RADHEAT ! Flag for version of Section 3. ARN1F404.86
*CALL CHSUNITS RS030293.94
*CALL CCONTROL ATMPHY1.46
*CALL CPHYSCON @DYALLOC.357
*CALL CTIME ATMPHY1.51
*CALL CHISTORY GDR3F305.7
*CALL C_GLOBAL GSS1F304.1186
*CALL C_WRITD GSS1F304.1187
*CALL CRUNTIMC ADR1F305.33
*CALL NSTYPES ARE1F404.18
ATMPHY1.53
CL Locally dynamically allocated work area for interfacing between ATMPHY1.54
CL sections ATMPHY1.55
ATMPHY1.56
REAL ATMPHY1.57
& WORK1(P_FIELDDA,Q_LEVELSDA), @DYALLOC.358
& WORK2(P_FIELDDA), @DYALLOC.359
& WORK3(P_FIELDDA), @DYALLOC.360
& WORK4(P_FIELDDA), @DYALLOC.361
& WORK5(P_FIELDDA), @DYALLOC.362
& WORK6(P_FIELDDA), @DYALLOC.363
& WORK7(P_FIELDDA), @DYALLOC.364
& WORK8(P_FIELDDA), ARN2F304.227
& WORK9(P_FIELDDA), ARN2F304.228
& WORK10(P_FIELDDA) ARN2F304.229
& ,WORK11(P_FIELDDA) AJS1F401.178
& ,WORK12(P_FIELDDA) AJS1F401.179
& ,WORK13(LAND_FIELDDA,SM_LEVELSDA) ! AJS1F401.180
& ,WORK14(P_FIELDDA) ! AJS1F401.181
& ,WORK15(P_FIELDDA) ! AJS1F401.182
& ,LSCLD_AREA(P_FIELDDA,Q_LEVELSDA) ASK1F405.98
! Cloud area in layer ASK1F405.99
& ,WORKB(P_FIELDDA,Q_LEVELSDA) ! Qc from Sec9 to Sec4 AYY2F400.71
! when Sec9.2A (=> Sec4.3A) is chosen CFL from Sec9 to Sec4 AYY1F404.5
& ,WORKC(P_FIELDDA,Q_LEVELSDA) ! bs from Sec9 to Sec4 AYY2F400.72
! when Sec9.2A (=> Sec4.3A) is chosen CFF from Sec9 to Sec4 AYY1F404.6
& ,WORKF(RADHEAT_DIM1,BL_LEVELSDA) ARN1F404.87
! ! Radiative heating rates in the ARN1F404.88
! ! bottom BL_LEVELS layers ARN1F404.89
! ! from Secs. 1 & 2 or 9 to Sec.3 ARN1F404.90
ATMPHY1.66
REAL ARE2F404.3
& RAD_NO_SNOW(P_FIELDDA) ! Surface net radiation, snow-free ARE2F404.4
C ! fraction of gridbox ARE2F404.5
& ,RAD_SNOW(P_FIELDDA) ! Surface net radiation, snow-covered ARE2F404.6
C ! fraction of gridbox ARE2F404.7
ARE2F404.8
ATMPHY1.67
REAL ARE1F404.19
& ECAN_TILE(TILE_FIELDDA,NTYPE-1)! Canopy evaporation from ARE1F404.20
! ! snow-free land tiles ARE1F404.21
& ,SNOW_FRAC(TILE_FIELDDA) ! Fraction of snow cover. ARE1F404.22
& ,SOIL_SURF_HTF(TILE_FIELDDA)! Net downward surface heat flux ARE1F404.23
! ! (W/m2) - snow-free land. ARE1F404.24
& ,SNOW_SURF_HTF(TILE_FIELDDA)! Net downward surface heat flux ARE1F404.25
! ! (W/m2) - snow. ARE1F404.26
ARE1F404.27
INTEGER ADB1F401.1
& TILE_PTS(NTYPE) ! Number of land points which ARE1F404.28
! ! include the nth surface type. ARE1F404.29
& ,TILE_INDEX(TILE_FIELDDA,NTYPE) ARE1F404.30
! ! Indices of land points which ARE1F404.31
! ! include the nth surface type. ARE1F404.32
ARE1F404.33
INTEGER ARE1F404.34
& SULP_DIM1,SULP_DIM2 ! Required for array dimensions in RAD_C ADB1F401.2
& ,CO2_DIM1, CO2_DIM2 ! Req'd for array dims in RAD_CTL ACN2F405.21
& ,LSPICE_DIM1,LSPICE_DIM2 ! Required for ADM0F405.305
! array dimensions in LSPP_CT1 ADM0F405.306
& ,SOOT_DIM1,SOOT_DIM2 ! Required for ALR3F405.1
! array dimensions in RAD_CTL ALR3F405.2
& ,QTOT_DIM1,QTOT_DIM2 ! array dimensions for LSPP_CT1 ALR3F405.3
INTEGER ATMPHY1.68
& TOT_LEVELS ! Required for dimensioning workspace in CLD_CTL @DYALLOC.366
& ,len_mom ! Required for array dimensions in CONV_CTL API2F400.4
& , NLALBS ! Required for array dimensions in & below AWI1F403.117
& , W1236_DIM ! RAD_CTL AWI1F403.118
& , SAL_DIM ! Required for array dimensions in & below RAD_CT ARE2F404.9
INTEGER ! Required for array dimension in CONV_CTL AWO5F401.3
& TRAY_LEN AWO5F401.4
& ,NTRA_FLD !local counter for no. of tracers AWO5F405.17
! AWO5F401.5
ATMPHY1.70
REAL ATMPHY1.73
& N_POLAR_VALUES(ROW_LENGTHDA,P_LEVELSDA+3*Q_LEVELSDA), @DYALLOC.367
& S_POLAR_VALUES(ROW_LENGTHDA,P_LEVELSDA+3*Q_LEVELSDA) @DYALLOC.368
ATMPHY1.76
ATMPHY1.77
C*L external subroutine calls ATMPHY1.78
ATMPHY1.79
EXTERNAL CLD_CTL, ATMPHY1.80
& ENG_MASS_DIAG,CAL_ENG_MASS_CORR,ADD_ENG_CORR,ENG_CTL, GSS1F304.1188
& TIMER,VDF_CTL,GWAV_CTL,RAD_CTL,BL_CTL, ATMPHY1.84
& LSPP_CTL,CONV_CTL,HYDR_CTL,POLAR,STASH ATMPHY1.85
&, CHEM_CTL,DUMPCTL GKR4F403.176
ATMPHY1.86
C* ATMPHY1.87
C Local variables ATMPHY1.88
ATMPHY1.89
ATMPHY1.90
INTEGER DMS_LEN ! Size of DMS array AWO1F401.7
REAL COZENANG(P_FIELDDA) ! COS ZENITH ANGLE AWO1F401.8
INTEGER ATMPHY1.91
& ICON, ! Loop counter for section 5 - convection GSS1F304.1190
& I, ATMPHY1.93
& J, AJS1F401.183
& L, ARE1F404.35
& N, ARE1F404.36
& FIRST_POINT, ATMPHY1.97
& LAST_POINT, ATMPHY1.98
& I1, ATMPHY1.99
& I2, ATMPHY1.100
& K,II,IIQCL,IIQCF,ITOLQ,ITOLQCL,ITOLQCF, ATD1F400.90
& IQNEG(P_FIELDDA),IQCLNEG(P_FIELDDA),IQCFNEG(P_FIELDDA), ATD1F400.91
& LEVEL, ATMPHY1.101
& IM_IDENT, ! internal model identifier GRB4F305.18
& IM_INDEX, ! internal model index for STASH arrays GRB4F305.19
& STASHLEN ! Length of STASHWORK needed by current section ATMPHY1.102
& ,A_STEP GDR5F305.15
*IF DEF,GLOBAL,AND,DEF,MPP APB1F305.7
INTEGER I_off APB1F305.8
*ENDIF APB1F305.9
REAL ATMPHY1.104
& SNOWDEPTH, ARE1F404.37
& TOT_MASS_FINAL, ATMPHY1.105
& TOT_ENERGY_FINAL, ATMPHY1.106
& PART_TOT_MASS ATMPHY1.107
ATMPHY1.109
REAL ATMPHY1.110
& PU,PL ATMPHY1.111
*CALL P_EXNERC ATMPHY1.112
*CALL C_SOILH ARE1F404.38
ATMPHY1.113
INTEGER ABX1F404.278
& PHENOL_CALL ! indicates whether phenology is to be called ABX1F404.279
&,TRIFFID_CALL ! indicates whether TRIFFID is to be called ABX1F404.280
&,NSTEP_TRIF ! Number of atmospheric timesteps between calls to ABX1F404.281
C ! TRIFFID vegetation model. ABX1F404.282
ABX1F404.283
A_STEP = STEPim(atmos_im) GDR5F305.16
GDR5F305.17
im_ident = atmos_im GRB4F305.20
im_index = internal_model_index(im_ident) GRB4F305.21
GRB4F305.22
CL Internal structure including subroutine calls: ATMPHY1.114
CL set pointer shift and length for physics calculations ATMPHY1.115
CL exclude all except one polar point and to exclude N-S boundary rows ATMPHY1.116
CL in limited area model. ATMPHY1.117
!L WARNING: On current model grid, POLAR points pose problems for u-, v- AYY2F400.73
!L and momentum- related variables and many physics schemes AYY2F400.74
!L only operate over interior rows for this reason. Schemes AYY2F400.75
!L with purely thermodynamic variables can be calculated at all AYY2F400.76
!L points, eg. LS_CLD, but may not be. Users concerned about AYY2F400.77
!L behaviour at polar points should check inside individual AYY2F400.78
!L control subroutines for indexing and are advised to seek AYY2F400.79
!L advice before attempting changes in this area. AYY2F400.80
ATMPHY1.118
FIRST_POINT=FIRST_VALID_PT APB1F401.10
LAST_POINT=LAST_P_VALID_PT APB1F401.11
ATMPHY1.121
ATMPHY1.122
*IF DEF,A03_7A ARE1F404.39
C---------------------------------------------------------------------- ARE1F404.40
C Diagnose fractional snow cover for MOSES II ARE1F404.41
C---------------------------------------------------------------------- ARE1F404.42
DO L=1,TILE_FIELDDA ARE1F404.43
SNOW_FRAC(L) = 0. ARE1F404.44
SNOWDEPTH = D1(JSNODEP+LAND_LIST(L)-1) ARE1F404.45
IF ( SNOWDEPTH .GT. 0. ) THEN ARE1F404.46
SNOW_FRAC(L) = MIN ( 1. , SNOWDEPTH / (RHO_SNOW*DEFF_SNOW) ) ARE1F404.47
SNOW_FRAC(L) = MAX ( SNOW_FRAC(L), 1E-3 ) ARE1F404.48
ENDIF ARE1F404.49
ENDDO ARE1F404.50
ARE1F404.51
*ENDIF ARE1F404.52
CL -- SECTION 9 -- ENERGY ADJUSTMENT AND CLOUD AMOUNT CALCULATIONS --- ATMPHY1.123
CL local workspace definitions ATMPHY1.124
CL WORK1 holds cloud amount ATMPHY1.125
CL WORK6 holds surface net down radiation flux (at radiation timesteps). ATMPHY1.126
CL WORK15 holds total downward surface shortwave (band 1) AJS1F401.184
! WORKB holds Qc, approximate gridbox mean deviation from saturation, AYY1F404.7
! When 2A version chosen, holds CFL Liquid cloud fraction. AYY1F404.8
! WORKC holds maximum moisture fluctuation in-cloud bs, AYY1F404.9
! When 2A version chosen, holds CFF Frozen cloud fraction. AYY1F404.10
!! WORKF holds radiative heating rates for the bottom BL_LEVELS layers ARN1F404.91
CL ATMPHY1.127
ATMPHY1.128
ATMPHY1.130
C Convert potential temperature to temperature ATMPHY1.131
ATMPHY1.132
DO LEVEL=1,P_LEVELS ATMPHY1.133
! Fujitsu vectorization directive GRB0F405.18
!OCL NOVREC GRB0F405.19
DO I=FIRST_POINT,LAST_POINT ATMPHY1.134
PU=D1(JPSTAR+I-1)*BKH(LEVEL+1) + AKH(LEVEL+1) ATMPHY1.135
PL=D1(JPSTAR+I-1)*BKH(LEVEL) + AKH(LEVEL) ATMPHY1.136
D1(JTHETA(LEVEL)+I-1)=D1(JTHETA(LEVEL)+I-1)* ATMPHY1.137
& P_EXNER_C( D1(JP_EXNER(LEVEL+1)+I-1),D1(JP_EXNER(LEVEL)+I-1), ATMPHY1.138
& PU,PL,KAPPA ) ATMPHY1.139
END DO ATMPHY1.140
END DO ATMPHY1.141
ATMPHY1.142
C Set length of STASHWORK array for CLD_CTL, which may be used for ATMPHY1.143
C Section 9 diagnostics in all timesteps and Section 1 ones if the ATMPHY1.144
C timestep is not a full SW timestep. ATMPHY1.145
ATMPHY1.146
IF ( L_SW_RADIATE ) THEN ATMPHY1.147
STASHLEN = STASH_MAXLEN(9,im_index) GRB4F305.23
ELSE ATMPHY1.149
STASHLEN = MAX(STASH_MAXLEN(1,im_index), GRB4F305.24
& STASH_MAXLEN(9,im_index)) GRB4F305.25
ENDIF ATMPHY1.151
TOT_LEVELS = P_LEVELS+3*Q_LEVELS ! Used for dimensioning workspace @DYALLOC.369
ATMPHY1.152
IF(LTIMER) THEN ATMPHY1.153
CALL TIMER('CLD_CTL ',3) ATMPHY1.154
END IF ATMPHY1.155
ATMPHY1.156
CALL CLD_CTL(WORK1,WORK6,WORK15,LSCLD_AREA ASK1F405.100
& ,RAD_NO_SNOW,RAD_SNOW,SNOW_FRAC ARE2F404.10
& ,WORKB,WORKC,N_POLAR_VALUES,S_POLAR_VALUES AJS1F401.186
& ,WORKF,BL_LEVELS,L_RADHEAT,RADHEAT_DIM1 ARN1F404.92
& ,P_FIELD,P_LEVELS,Q_LEVELS,ROW_LENGTH,TOT_LEVELS,STASHLEN, AYY2F400.84
*CALL ARGSIZE @DYALLOC.372
*CALL ARGD1 @DYALLOC.373
*CALL ARGDUMA @DYALLOC.374
*CALL ARGDUMO @DYALLOC.375
*CALL ARGDUMW GKR1F401.174
*CALL ARGSTS @DYALLOC.376
*CALL ARGPTRA @DYALLOC.377
*CALL ARGPTRO @DYALLOC.378
*CALL ARGCONA @DYALLOC.379
*CALL ARGPPX GKR0F305.890
*CALL ARGFLDPT APBHF401.1
*IF DEF,FRADIO GGH3F401.5
& RADINCS, @DYALLOC.381
*ENDIF @DYALLOC.382
& COZENANG, AWO1F401.9
& ICODE,CMESSAGE) @DYALLOC.383
IF (L_WRIT_PHY .AND. GSS1F304.1192
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1193
GSS1F304.1194
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1195
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1196
GSS1F304.1197
CALL DUMPCTL ( GKR4F403.177
*CALL ARGSIZE GKR4F403.178
*CALL ARGD1 GKR4F403.179
*CALL ARGDUMA GKR4F403.180
*CALL ARGDUMO GKR4F403.181
*CALL ARGDUMW GKR4F403.182
*CALL ARGCONA GKR4F403.183
*CALL ARGPTRA GKR4F403.184
*CALL ARGSTS GKR4F403.185
*CALL ARGPPX GKR4F403.186
& atmos_sm,0,.TRUE.,'af_cld_ctl',a_step, GIE1F405.5
& ICODE,CMESSAGE) GKR4F403.188
GSS1F304.1199
END IF GSS1F304.1200
GSS1F304.1201
END IF GSS1F304.1202
TJ270193.77
IF(LTIMER) THEN ATMPHY1.161
CALL TIMER('CLD_CTL ',4) ATMPHY1.162
END IF ATMPHY1.163
ATMPHY1.164
IF(ICODE.GT.0) RETURN ATMPHY1.165
ATMPHY1.166
ATMPHY1.167
IF (LEMCORR) THEN GSS1F304.1203
GSM3F404.20
IF (LFLUX_RESET) THEN GSM3F404.21
! Reinitialise net flux field at beginning of period GSM3F404.22
DO I=1,P_FIELD GSM3F404.23
D1(JNET_FLUX+I-1)=0.0 GSM3F404.24
ENDDO GSM3F404.25
ENDIF GSM3F404.26
GSM3F404.27
GSS1F304.1204
IF(LTIMER) THEN ATMPHY1.169
CALL TIMER('ADJ_ENGY',3) ATMPHY1.170
END IF ATMPHY1.171
ATMPHY1.172
CALL ADD_ENG_CORR(A_REALHD(21),D1(JTHETA(1)),P_FIELD,P_FIELD, ATMPHY1.173
& P_LEVELS,SECS_PER_STEPim(atmos_im), ADR1F305.34
& A_REALHD(19),A_REALHD(18)) ADR1F305.35
TJ201093.5
CALL ENG_CTL(STASH_MAXLEN(14,im_index),A_REALHD(21), GRB4F305.26
*CALL ARGSIZE TJ201093.7
*CALL ARGD1 TJ201093.8
*CALL ARGDUMA TJ201093.9
*CALL ARGDUMO TJ201093.10
*CALL ARGDUMW GKR1F401.175
*CALL ARGSTS TJ201093.11
*CALL ARGPTRA TJ201093.12
*CALL ARGPTRO TJ201093.13
*CALL ARGCONA TJ201093.14
*CALL ARGPPX GKR0F305.891
& ICODE,CMESSAGE) TJ201093.15
TJ201093.16
IF (ICODE.GT.0) THEN TJ201093.17
RETURN TJ201093.18
ENDIF TJ201093.19
ATMPHY1.176
IF(LTIMER) THEN ATMPHY1.177
CALL TIMER('ADJ_ENGY',4) ATMPHY1.178
END IF ATMPHY1.179
ATMPHY1.181
END IF ! LEMCORR GSS1F304.1205
ATMPHY1.184
C ----------------------------------------------------- ATMPHY1.185
ATMPHY1.186
C --- SECTION 1+2 RADIATION ------------------------------------ ATMPHY1.187
ATMPHY1.188
CL Local workspace allocation ATMPHY1.189
CL WORK1 holds cloud amount ATMPHY1.190
CL WORK2 holds sine of true latitude ATMPHY1.191
CL WORK3 holds fraction of time a point is sunlit ATMPHY1.192
CL WORK4 holds the cosine of the solar zenith angle (zero at night). WI200893.38
CL WORK5 holds net downward solar flux at the top of the atmosphere. ATMPHY1.194
CL WORK6 holds surface net down radiation flux ATMPHY1.195
CL WORK7 holds list of daylight points ATMPHY1.196
CL WORK8 holds a logical switch defining daylight points ATMPHY1.197
CL WORK15 holds total downward surface shortwave (band 1) AJS1F401.187
!! WORKF holds radiative heating rates for bottom BL_LEVELS layers ARN1F404.93
ATMPHY1.198
IF(L_SW_RADIATE.OR.L_LW_RADIATE) THEN ATMPHY1.199
C Set length of STASHWORK array for sections 1&2 ATMPHY1.200
ATMPHY1.201
STASHLEN=MAX(STASH_MAXLEN(1,im_index),STASH_MAXLEN(2,im_index)) GRB4F305.27
ATMPHY1.203
ATMPHY1.204
! Set dimensions of _SULPHATE arrays for passing to RAD_CTL ADB1F401.3
! (avoids wasting space if aerosol not required) ADB1F401.4
IF (L_USE_SULPC_DIRECT .OR. L_USE_SULPC_INDIRECT_SW AAJ1F404.7
& .OR. L_USE_SULPC_INDIRECT_LW) THEN AAJ1F404.8
SULP_DIM1 = P_FIELDDA ADB1F401.6
SULP_DIM2 = P_LEVELSDA ADB1F401.7
ELSE ADB1F401.8
SULP_DIM1 = 1 ADB1F401.9
SULP_DIM2 = 1 ADB1F401.10
END IF ADB1F401.11
! ACN2F405.22
! Similarly for carbon cycle ACN2F405.23
IF (L_CO2_INTERACTIVE) THEN ACN2F405.24
CO2_DIM1 = P_FIELDDA ACN2F405.25
CO2_DIM2 = P_LEVELSDA ACN2F405.26
ELSE ACN2F405.27
CO2_DIM1 = 1 ACN2F405.28
CO2_DIM2 = 1 ACN2F405.29
END IF ACN2F405.30
AWI1F403.119
! Set dimensions of soot arrays for passing to RAD_CTL ALR3F405.4
! (avoids wasting space if soot not required) ALR3F405.5
IF (L_USE_SOOT_DIRECT) THEN ALR3F405.6
SOOT_DIM1 = P_FIELDDA ALR3F405.7
SOOT_DIM2 = P_LEVELSDA ALR3F405.8
ELSE ALR3F405.9
SOOT_DIM1 = 1 ALR3F405.10
SOOT_DIM2 = 1 ALR3F405.11
END IF ALR3F405.12
! Similar for land surface albedos - different values are needed for AWI1F403.120
! direct & diffuse sunlight if the HadCM2 approximate treatment of AWI1F403.121
! sulphate aerosol is being used: AWI1F403.122
IF ( L_H2_SULPH ) THEN AWI1F403.123
NLALBS = 2 AWI1F403.124
ELSE AWI1F403.125
NLALBS = 1 AWI1F403.126
ENDIF AWI1F403.127
AWI1F403.128
! And if in addition this diagnostic is requested, extra workspace AWI1F403.129
! must be defined in & below RAD_CTL AWI1F403.130
IF ( SF(236,1) ) THEN AWI1F403.131
W1236_DIM = P_FIELD AWI1F403.132
ELSE AWI1F403.133
W1236_DIM = 1 AWI1F403.134
ENDIF AWI1F403.135
ARE2F404.11
! Extra workspace required if prognostic snow albedo scheme is used ARE2F404.12
IF ( L_SNOW_ALBEDO ) THEN ARE2F404.13
SAL_DIM = P_FIELD ARE2F404.14
ELSE ARE2F404.15
SAL_DIM = 1 ARE2F404.16
ENDIF ARE2F404.17
! ADB1F401.12
IF(LTIMER) THEN ATMPHY1.205
CALL TIMER('RAD_CTL',3) ATMPHY1.206
END IF ATMPHY1.207
ATMPHY1.208
CALL RAD_CTL(WORK1,WORK2,WORK3,WORK4,WORK5,WORK6,WORK7,WORK8, ATMPHY1.209
& LSCLD_AREA, ASK1F405.101
& RAD_NO_SNOW,RAD_SNOW,SNOW_FRAC, ARE2F404.18
& WORK15,WORKF, ARN1F404.94
& P_FIELD,P_LEVELS,Q_LEVELS,OZONE_LEVELS,CLOUD_LEVELS, ARN1F404.95
& BL_LEVELS,L_RADHEAT,RADHEAT_DIM1, ARN1F404.96
& H_SWBANDS, STASHLEN, CO2_DIM1, CO2_DIM2, ACN2F405.31
& SULP_DIM1, SULP_DIM2, SOOT_DIM1, SOOT_DIM2, ALR3F405.13
& NLALBS, W1236_DIM, SAL_DIM, ALR3F405.14
*CALL ARGSIZE @DYALLOC.386
*CALL ARGD1 @DYALLOC.387
*CALL ARGDUMA @DYALLOC.388
*CALL ARGDUMO @DYALLOC.389
*CALL ARGDUMW GKR1F401.176
*CALL ARGSTS @DYALLOC.390
*CALL ARGPTRA @DYALLOC.391
*CALL ARGPTRO @DYALLOC.392
*CALL ARGCONA @DYALLOC.393
*CALL ARGPPX GKR0F305.892
*CALL ARGFLDPT APBBF401.1
*IF DEF,FRADIO GGH3F401.6
& RADINCS, @DYALLOC.395
*ENDIF @DYALLOC.396
& ICODE,CMESSAGE) @DYALLOC.397
ATMPHY1.211
DO I=1,P_FIELD ! SAVE WORK4, WHICH IS RETURNED BY RADCNTL AWO1F401.10
COZENANG(I)=WORK4(I) AWO1F401.11
ENDDO AWO1F401.12
IF (L_WRIT_PHY .AND. GSS1F304.1206
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1207
TJ270193.81
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1208
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1209
GSS1F304.1210
CALL DUMPCTL ( GKR4F403.189
*CALL ARGSIZE GKR4F403.190
*CALL ARGD1 GKR4F403.191
*CALL ARGDUMA GKR4F403.192
*CALL ARGDUMO GKR4F403.193
*CALL ARGDUMW GKR4F403.194
*CALL ARGCONA GKR4F403.195
*CALL ARGPTRA GKR4F403.196
*CALL ARGSTS GKR4F403.197
*CALL ARGPPX GKR4F403.198
& atmos_sm,0,.TRUE.,'af_rad_ctl',a_step, GIE1F405.6
& ICODE,CMESSAGE) GKR4F403.200
GSS1F304.1212
END IF GSS1F304.1213
GSS1F304.1214
END IF GSS1F304.1215
GSS1F304.1216
IF(LTIMER) THEN ATMPHY1.212
CALL TIMER('RAD_CTL',4) ATMPHY1.213
END IF ATMPHY1.214
ATMPHY1.215
ATMPHY1.216
IF(ICODE.GT.0) RETURN ATMPHY1.217
END IF ATMPHY1.218
C ------------------------------------------------------------ ATMPHY1.220
ATMPHY1.221
CL--- SECTION 3 --- BOUNDARY LAYER & SURFACE ---------- ATMPHY1.222
ATMPHY1.223
CL WORK1 holds cloud amount ATMPHY1.224
CL WORK2 holds snow sublimation ATMPHY1.225
CL WORK3 holds canopy evaporation ATMPHY1.226
CL WORK4 holds soil evaporation ATMPHY1.227
CL WORK6 holds surface net down radiation flux ATMPHY1.228
CL WORK9 holds fluctuations in T1 ARN2F304.230
CL WORK10 holds fluctuations in Q1 ARN2F304.231
CL WORK5,7,8 used as workspace in boundary layer routine ATMPHY1.229
CL WORK12 holds snowmelt AJS1F400.190
CL WORK13 holds extraction of moisture AJS1F401.189
CL WORK14 holds surface heat flux AJS1F401.190
CL WORK15 holds total downward surface shortwave (band 1) AJS1F401.191
! WORKB holds Qc, approximate gridbox mean deviation from saturation, AYY1F404.11
! When 2A cloud scheme chosen, holds CFL Liquid cloud fraction. AYY1F404.12
! WORKC holds maximum moisture fluctuation in-cloud bs, AYY1F404.13
! When 2A cloud scheme chosen, holds CFF Frozen cloud fraction. AYY1F404.14
!! WORKF holds radiative heating rates for the bottom BL_LEVELS layers ARN1F404.97
AJS1F401.192
AJS1F401.193
! Initialise temperature and moisture fluctuations passed from BL to ARR0F403.13
! convection in WORK9,WORK10 arrays to avoid uninitialised data being ARR0F403.14
! accessed in convection. If the fluctuations are calculated ARR0F403.15
! consistently in SF_EXCH within BL, this initialisation should not be ARR0F403.16
! needed, but MPP halos complicate the issue. ARR0F403.17
DO I=1,P_FIELD ARR0F403.18
WORK9(I)=0.0 ARR0F403.19
WORK10(I)=0.0 ARR0F403.20
ENDDO ARR0F403.21
ATMPHY1.230
IF(LTIMER) THEN ATMPHY1.231
CALL TIMER('BL_CTL',5) GPB1F401.23
CALL TIMER('BL_CTL ',3) TS150793.16
END IF ATMPHY1.233
ATMPHY1.234
CALL BL_CTL(WORK1,WORK2,WORK12,WORK3,WORK13,WORK4, AJS1F401.194
& WORK14,WORK6,WORK9,WORK10,WORK5, AJS1F401.195
& WORK7,WORK8,WORK15,WORKB,WORKC, AJS1F401.196
& WORKF,RADHEAT_DIM1, ARN1F404.98
& P_FIELD,Q_LEVELS,BL_LEVELS, AJS1F401.197
& ST_LEVELS,SM_LEVELS,STASH_MAXLEN(3,im_index), AJS1F401.198
& LAND_FIELD, AJS1F401.199
& TILE_FIELDDA,TILE_PTS,TILE_INDEX, ARE1F404.53
& RAD_NO_SNOW,RAD_SNOW,SNOW_FRAC, ARE1F404.54
& ECAN_TILE,SNOW_SURF_HTF,SOIL_SURF_HTF, ARE1F404.55
*CALL ARGSIZE @DYALLOC.399
*CALL ARGD1 @DYALLOC.400
*CALL ARGDUMA @DYALLOC.401
*CALL ARGDUMO @DYALLOC.402
*CALL ARGDUMW GKR1F401.177
*CALL ARGSTS @DYALLOC.403
*CALL ARGPTRA @DYALLOC.404
*CALL ARGPTRO @DYALLOC.405
*CALL ARGCONA @DYALLOC.406
*CALL ARGPPX GKR0F305.893
*CALL ARGFLDPT APBGF401.18
& ICODE,CMESSAGE) @DYALLOC.407
ATMPHY1.238
IF (L_WRIT_PHY .AND. GSS1F304.1217
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1218
TJ270193.85
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1219
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1220
GSS1F304.1221
CALL DUMPCTL ( GKR4F403.201
*CALL ARGSIZE GKR4F403.202
*CALL ARGD1 GKR4F403.203
*CALL ARGDUMA GKR4F403.204
*CALL ARGDUMO GKR4F403.205
*CALL ARGDUMW GKR4F403.206
*CALL ARGCONA GKR4F403.207
*CALL ARGPTRA GKR4F403.208
*CALL ARGSTS GKR4F403.209
*CALL ARGPPX GKR4F403.210
& atmos_sm,0,.TRUE.,'af_bl_ctl_',a_step, GIE1F405.7
& ICODE,CMESSAGE) GKR4F403.212
GSS1F304.1223
END IF GSS1F304.1224
GSS1F304.1225
END IF GSS1F304.1226
GSS1F304.1227
IF(LTIMER) THEN ATMPHY1.239
CALL TIMER('BL_CTL ',4) TS150793.17
CALL TIMER('BL_CTL',6) GPB1F401.24
END IF ATMPHY1.241
ATMPHY1.242
IF(ICODE.GT.0) THEN ATMPHY1.243
RETURN ATMPHY1.244
END IF ATMPHY1.245
ATMPHY1.246
CL WORK2,WORK3,WORK4 carried forward to Hydrology ATMPHY1.247
CL WORK9,WORK10 carried forward to convection ARN2F304.234
ATMPHY1.248
! AWO1F401.13
!--------------------------------------------------------------------- AWO1F401.14
! AWO1F401.15
!------------ SECTION 17 SULPHUR CYCLE CHEMISTRY ------------------- AWO1F401.16
! AWO1F401.17
! Call to CHEM_CTL if Sulphur Cycle or Soot have been requested ALR2F405.1
! AWO1F401.19
IF (L_SULPC_SO2 .OR. L_SOOT) THEN ALR2F405.2
! AWO1F401.21
IF (LTIMER) THEN AWO1F401.22
CALL TIMER('CHEM_CTL',3) AWO1F401.23
END IF AWO1F401.24
! AWO1F401.25
IF (L_SULPC_DMS) THEN AWO1F401.26
DMS_LEN=P_FIELD*P_LEVELS AWO1F401.27
ELSE AWO1F401.28
DMS_LEN=1 AWO1F401.29
END IF ! END L_SULPC_DMS IF AWO1F401.30
! AWO1F401.31
! AWO1F401.32
CALL CHEM_CTL(WORK1, ! Cloud fraction AWO1F401.33
& DMS_LEN, AWO1F401.34
& Q_LEVELS,P_LEVELS,P_FIELD,ROW_LENGTH, AWO1F401.35
& COZENANG,STASH_MAXLEN(17,im_index), AWO1F401.36
*CALL ARGSIZE AWO1F401.37
*CALL ARGD1 AWO1F401.38
*CALL ARGDUMA AWO1F401.39
*CALL ARGDUMO AWO1F401.40
*CALL ARGSTS AWO1F401.41
*CALL ARGPTRA AWO1F401.42
*CALL ARGPTRO AWO1F401.43
*CALL ARGCONA AWO1F401.44
*CALL ARGPPX AWO1F401.45
*CALL ARGFLDPT AWO1F401.46
& ICODE,CMESSAGE) AWO1F401.47
! AWO1F401.48
IF(LTIMER) THEN AWO1F401.49
CALL TIMER('CHEM_CTL',4) AWO1F401.50
END IF AWO1F401.51
! AWO1F401.52
IF(ICODE.GT.0) THEN AWO1F401.53
RETURN AWO1F401.54
END IF AWO1F401.55
! AWO1F401.56
ENDIF ! End of L_SULPC_SO2 or L_SOOT test ALR2F405.3
! AWO1F401.58
C ----------------------------------------------------- ATMPHY1.249
ATMPHY1.250
CL--- SECTION 4 --- STRATIFORM PRECIPITATION ---------- ATMPHY1.251
ATMPHY1.252
CL local workspace definitions ATMPHY1.253
CL WORK1 holds cloud amount ATMPHY1.254
CL WORK5 holds large scale rain ATMPHY1.255
CL WORK6 holds large scale snow ATMPHY1.256
! WORKB holds Qc, approximate gridbox mean deviation from saturation, AYY1F404.15
! When 2A cloud scheme chosen, holds CFL Liquid cloud fraction. AYY1F404.16
! WORKC holds maximum moisture fluctuation in-cloud bs, AYY1F404.17
! When 2A cloud scheme chosen, holds CFF Frozen cloud fraction. AYY1F404.18
! AYY1F404.19
! Set dimensions of QTOTAL array, required only for S Cycle or Soot AWO4F405.1
IF (L_SULPC_SO2 .OR. L_SOOT) THEN AWO4F405.2
QTOT_DIM1 = P_FIELDDA AWO4F405.3
QTOT_DIM2 = Q_LEVELSDA AWO4F405.4
ELSE AWO4F405.5
QTOT_DIM1 = 1 AWO4F405.6
QTOT_DIM2 = 1 AWO4F405.7
END IF AWO4F405.8
! AWO4F405.9
! Only allow dynamic allocation of full space for arrays for 3D ADM0F405.307
! precipitation diagnostics if they are being used. Otherwise save space ADM0F405.308
! and give them a minimum size of 1 by 1. ADM0F405.309
IF ( SF(222,4) .OR. SF(223,4) .OR. SF(224,4) .OR. SF(225,4) ) THEN ADM0F405.310
LSPICE_DIM1 = P_FIELDDA ADM0F405.311
LSPICE_DIM2 = Q_LEVELSDA ADM0F405.312
ELSE ADM0F405.313
LSPICE_DIM1 = 1 ADM0F405.314
LSPICE_DIM2 = 1 ADM0F405.315
END IF ADM0F405.316
! ADM0F405.317
IF(LTIMER) THEN ATMPHY1.259
CALL TIMER('LSPP_CTL',3) ATMPHY1.260
END IF ATMPHY1.261
ATMPHY1.262
CALL LSPP_CTL(WORK1,WORK5,WORK6,WORKB,WORKC, AYY2F400.90
& P_FIELD,Q_LEVELS,STASH_MAXLEN(4,im_index), GRB4F305.29
& QTOT_DIM1,QTOT_DIM2, AWO4F405.10
& LSPICE_DIM1,LSPICE_DIM2, ADM0F405.318
*CALL ARGSIZE @DYALLOC.410
*CALL ARGD1 @DYALLOC.411
*CALL ARGDUMA @DYALLOC.412
*CALL ARGDUMO @DYALLOC.413
*CALL ARGDUMW GKR1F401.178
*CALL ARGSTS @DYALLOC.414
*CALL ARGPTRA @DYALLOC.415
*CALL ARGPTRO @DYALLOC.416
*CALL ARGCONA @DYALLOC.417
*CALL ARGPPX GKR0F305.894
*CALL ARGFLDPT APBCF401.1
& ICODE,CMESSAGE) ATMPHY1.264
ATMPHY1.265
IF (L_WRIT_PHY .AND. GSS1F304.1228
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1229
TJ270193.89
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1230
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1231
GSS1F304.1232
CALL DUMPCTL ( GKR4F403.213
*CALL ARGSIZE GKR4F403.214
*CALL ARGD1 GKR4F403.215
*CALL ARGDUMA GKR4F403.216
*CALL ARGDUMO GKR4F403.217
*CALL ARGDUMW GKR4F403.218
*CALL ARGCONA GKR4F403.219
*CALL ARGPTRA GKR4F403.220
*CALL ARGSTS GKR4F403.221
*CALL ARGPPX GKR4F403.222
& atmos_sm,0,.TRUE.,'af_lsppctl',a_step, GIE1F405.8
& ICODE,CMESSAGE) GKR4F403.224
GSS1F304.1234
END IF GSS1F304.1235
GSS1F304.1236
END IF GSS1F304.1237
GSS1F304.1238
IF(LTIMER) THEN ATMPHY1.266
CALL TIMER('LSPP_CTL',4) ATMPHY1.267
END IF ATMPHY1.268
ATMPHY1.269
IF(ICODE.GT.0) THEN ATMPHY1.270
RETURN ATMPHY1.271
END IF ATMPHY1.272
ATMPHY1.273
CL convert temperature to potential temperature ATMPHY1.274
ATMPHY1.275
DO LEVEL=1,P_LEVELS ATMPHY1.276
! Fujitsu vectorization directive GRB0F405.20
!OCL NOVREC GRB0F405.21
DO I=FIRST_POINT,LAST_POINT ATMPHY1.277
PU=D1(JPSTAR+I-1)*BKH(LEVEL+1) + AKH(LEVEL+1) ATMPHY1.278
PL=D1(JPSTAR+I-1)*BKH(LEVEL) + AKH(LEVEL) ATMPHY1.279
D1(JTHETA(LEVEL)+I-1)=D1(JTHETA(LEVEL)+I-1)/ ATMPHY1.280
& P_EXNER_C( D1(JP_EXNER(LEVEL+1)+I-1),D1(JP_EXNER(LEVEL)+I-1), ATMPHY1.281
& PU,PL,KAPPA ) ATMPHY1.282
END DO ATMPHY1.283
END DO ATMPHY1.284
ATMPHY1.285
ATMPHY1.286
C ----------------------------------------------------- ATMPHY1.287
ATMPHY1.288
CL --- SECTION 5 --- CONVECTION ------------------------ ATMPHY1.289
ATMPHY1.290
CL local workspace definitions ATMPHY1.291
CL WORK1 holds dtheta/dt ATMPHY1.292
CL WORK5 holds large scale rain (input for diagnostic purposes) TJ241193.4
CL WORK6 holds large scale snow (input for diagnostic purposes) TJ241193.5
CL WORK7 holds CON_RAIN ATMPHY1.293
CL WORK8 holds CON_SNOW ATMPHY1.294
CL WORK9 holds fluctuations in T1 from boundary layer ARN2F304.235
CL WORK10 holds fluctuations in Q1 from boundary layer ARN2F304.236
ATMPHY1.295
ATMPHY1.296
IF (A_CONV_STEP .EQ. 0) THEN ! Skip CONV_CTL if convection GSS1F304.1239
DO ICON = 1,P_FIELDDA ! calling frequency is zero GSS1F304.1240
WORK7(ICON) = 0.0 GSS1F304.1241
WORK8(ICON) = 0.0 GSS1F304.1242
END DO GSS1F304.1243
ELSE GSS1F304.1244
GSS1F304.1245
IF(LTIMER) THEN ATMPHY1.297
CALL TIMER('CONVECT',5) GPB1F401.25
CALL TIMER('CONV_CTL',3) ATMPHY1.298
END IF ATMPHY1.299
ATMPHY1.300
! set up array dimension size for convective momentum transport API2F400.5
! arrays in CONV_CTL. If convective momentum transports are not API2F400.6
! required, set dimension to 1 to reduce memory useage. API2F400.7
IF(L_MOM)THEN API2F400.8
len_mom=P_FIELD API4F401.3
ELSE API2F400.10
len_mom=1 API2F400.11
END IF API2F400.12
! AWO5F401.6
! Set up array dimensions for total tracer array (free + sulphur cycle AWO5F401.7
! tracers) so that convective transport of all tracers is done AWO5F401.8
! AWO5F401.9
IF ( (L_SULPC_SO2 .OR. L_SOOT .OR. L_CO2_INTERACTIVE) .AND. AWO5F405.18
& (TR_VARS.GE.1) .AND. AWO5F405.19
& (TR_LEVELS .NE. P_LEVELS) ) THEN ! exit AWO5F401.11
WRITE(6,*) 'TR_LEVELS .NE. P_LEVELS, CANNOT CALL CONV_CT1' AWO5F401.12
RETURN AWO5F401.13
END IF AWO5F401.14
IF ( (L_CO2_INTERACTIVE) .AND. (TR_VARS.GE.1) .AND. ACN2F405.32
& (TR_LEVELS .NE. P_LEVELS) ) THEN ! exit ACN2F405.33
WRITE(6,*) 'TR_LEVELS .NE. P_LEVELS, CANNOT CALL CONV_CT1' ACN2F405.34
RETURN ACN2F405.35
END IF ACN2F405.36
! ACN2F405.37
! AWO5F401.15
IF (L_SULPC_SO2 .OR. L_SOOT .OR. L_CO2_INTERACTIVE) THEN AWO5F405.20
NTRA_FLD = 0 !Initialise to zero AWO5F405.21
! AWO5F405.22
IF (L_SULPC_SO2) THEN AWO5F405.23
NTRA_FLD = NTRA_FLD + 4 !Add SO2 + 3 SO4 modes AWO5F405.24
IF (L_SULPC_NH3) THEN AWO5F405.25
NTRA_FLD = NTRA_FLD + 1 !Add NH3 field AWO5F405.26
END IF AWO5F405.27
IF (L_SULPC_DMS) THEN AWO5F405.28
NTRA_FLD = NTRA_FLD + 1 !Add DMS field AWO5F405.29
END IF AWO5F405.30
END IF AWO5F405.31
! AWO5F405.32
IF (L_SOOT) THEN AWO5F405.33
NTRA_FLD = NTRA_FLD + 3 !Add 3 modes of soot AWO5F405.34
END IF AWO5F405.35
! AWO5F405.36
IF (L_CO2_INTERACTIVE) THEN AWO5F405.37
NTRA_FLD = NTRA_FLD + 1 !Add CO2 field AWO5F405.38
END IF AWO5F405.39
! AWO5F405.40
TRAY_LEN = P_FIELD * P_LEVELS * (NTRA_FLD+TR_VARS) AWO5F405.41
! AWO5F405.42
ELSE AWO5F401.22
IF (TR_VARS .EQ. 0) THEN AWO5F401.23
TRAY_LEN = P_FIELD ! consistent with CONVECT AWO5F401.24
ELSE AWO5F401.25
TRAY_LEN = P_FIELD*TR_LEVELS*TR_VARS AWO5F401.26
ENDIF AWO5F401.27
ENDIF AWO5F401.28
! AWO5F401.29
CALL CONV_CTL(WORK1,WORK7,WORK8, RB300993.5
& WORK5,WORK6, TJ241193.6
& WORK9,WORK10,P_FIELD,P_LEVELS,Q_LEVELS,len_mom, API2F400.13
& TRAY_LEN, AWO5F401.30
& MPARWTR,ANVIL_FACTOR,TOWER_FACTOR,UD_FACTOR, AJX3F405.146
& STASH_MAXLEN(5,im_index), GRB4F305.31
*CALL ARGSIZE @DYALLOC.422
*CALL ARGD1 @DYALLOC.423
*CALL ARGDUMA @DYALLOC.424
*CALL ARGDUMO @DYALLOC.425
*CALL ARGDUMW GKR1F401.179
*CALL ARGSTS @DYALLOC.426
*CALL ARGPTRA @DYALLOC.427
*CALL ARGPTRO @DYALLOC.428
*CALL ARGCONA @DYALLOC.429
*CALL ARGCNVI RB300993.6
*CALL ARGPPX GKR0F305.895
*CALL ARGFLDPT APBDF401.1
& ICODE,CMESSAGE) ATMPHY1.302
ATMPHY1.303
IF (L_WRIT_PHY .AND. GSS1F304.1246
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1247
GSS1F304.1248
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1249
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1250
GSS1F304.1251
CALL DUMPCTL ( GKR4F403.225
*CALL ARGSIZE GKR4F403.226
*CALL ARGD1 GKR4F403.227
*CALL ARGDUMA GKR4F403.228
*CALL ARGDUMO GKR4F403.229
*CALL ARGDUMW GKR4F403.230
*CALL ARGCONA GKR4F403.231
*CALL ARGPTRA GKR4F403.232
*CALL ARGSTS GKR4F403.233
*CALL ARGPPX GKR4F403.234
& atmos_sm,0,.TRUE.,'af_convctl',a_step, GIE1F405.9
& ICODE,CMESSAGE) GKR4F403.236
GSS1F304.1253
END IF GSS1F304.1254
GSS1F304.1255
END IF GSS1F304.1256
TJ270193.93
IF(LTIMER) THEN ATMPHY1.304
CALL TIMER('CONV_CTL',4) ATMPHY1.305
CALL TIMER('CONVECT',6) GPB1F401.26
END IF ATMPHY1.306
ATMPHY1.307
IF(ICODE.GT.0) THEN ATMPHY1.308
RETURN ATMPHY1.309
END IF ATMPHY1.310
ATMPHY1.311
END IF ! End of 'skip CONV_CTL' option GSS1F304.1257
GSS1F304.1258
C ----------------------------------------------------- ATMPHY1.312
ATMPHY1.313
CL ----------- SECTION 8 - HYDROLOGY ------------------ ATMPHY1.314
ATMPHY1.315
CL local workspace definitions ATMPHY1.316
CL WORK2 holds snow sublimation ATMPHY1.317
CL WORK3 holds canopy evaporation ATMPHY1.318
CL WORK4 holds surface evaporation AJS1F401.200
CL WORK5 holds large scale rain ATMPHY1.320
CL WORK6 holds large scale snow ATMPHY1.321
CL WORK7 holds convective rain ATMPHY1.322
CL WORK8 holds convective snow ATMPHY1.323
CL WORK12 holds snow melt AJS1F401.201
CL WORK13 holds extraction AJS1F401.202
CL WORK14 holds surface heat flux AJS1F401.203
ATMPHY1.325
IF(LTIMER) THEN ATMPHY1.326
CALL TIMER('HYDR_CTL',3) ATMPHY1.327
END IF ATMPHY1.328
ATMPHY1.329
CALL HYDR_CTL(WORK2,WORK12,WORK3,WORK13, AJS1F401.204
& WORK4,WORK14,WORK5,WORK6, AJS1F401.205
& WORK7,WORK8,LAND_FIELD,STASH_MAXLEN(8,im_index), AJS1F400.196
& ST_LEVELS,SM_LEVELS, AJS1F401.206
& TILE_FIELDDA,TILE_PTS,TILE_INDEX, ARE1F404.56
& ECAN_TILE,SNOW_FRAC,SOIL_SURF_HTF,SNOW_SURF_HTF, ARE1F404.57
*CALL ARGSIZE @DYALLOC.431
*CALL ARGD1 @DYALLOC.432
*CALL ARGDUMA @DYALLOC.433
*CALL ARGDUMO @DYALLOC.434
*CALL ARGDUMW GKR1F401.180
*CALL ARGSTS @DYALLOC.435
*CALL ARGPTRA @DYALLOC.436
*CALL ARGPTRO @DYALLOC.437
*CALL ARGCONA @DYALLOC.438
*CALL ARGPPX GKR0F305.896
*CALL ARGFLDPT APBFF401.1
& ICODE,CMESSAGE) @DYALLOC.439
ATMPHY1.332
IF(LTIMER) THEN ATMPHY1.333
CALL TIMER('HYDR_CTL',4) ATMPHY1.334
END IF ATMPHY1.335
ATMPHY1.336
IF(ICODE.GT.0) THEN ATMPHY1.337
RETURN ATMPHY1.338
END IF ATMPHY1.339
ATMPHY1.340
C ----------------------------------------------------- ATMPHY1.341
ATMPHY1.342
IF (L_WRIT_PHY .AND. GDR8F405.74
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GDR8F405.75
GDR8F405.76
IF (A_STEP.EQ.T_WRITD1_START .OR. GDR8F405.77
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GDR8F405.78
GDR8F405.79
CALL DUMPCTL ( GDR8F405.80
*CALL ARGSIZE GDR8F405.81
*CALL ARGD1 GDR8F405.82
*CALL ARGDUMA GDR8F405.83
*CALL ARGDUMO GDR8F405.84
*CALL ARGDUMW GDR8F405.85
*CALL ARGCONA GDR8F405.86
*CALL ARGPTRA GDR8F405.87
*CALL ARGSTS GDR8F405.88
*CALL ARGPPX GDR8F405.89
& atmos_sm,0,.TRUE.,'af_hydrctl',a_step, GDR8F405.90
& ICODE,CMESSAGE) GDR8F405.91
GDR8F405.92
END IF GDR8F405.93
GDR8F405.94
END IF GDR8F405.95
ATMPHY1.343
C --- SECTION 7 --- VERTICAL DIFFUSION ---------------- ATMPHY1.344
*IF -DEF,A07_0A ATMPHY1.345
CL Skip section 7 if zero coefficient of diffusion ATMPHY1.346
IF(VERTICAL_DIFFUSION.GT.0.0) THEN ADR1F305.36
ATMPHY1.348
ATMPHY1.349
IF(LTIMER) THEN ATMPHY1.350
CALL TIMER('VDF_CTL ',3) ATMPHY1.351
END IF ATMPHY1.352
ATMPHY1.353
CALL VDF_CTL(U_FIELD,P_LEVELS,STASH_MAXLEN(7,im_index), GRB4F305.33
*CALL ARGSIZE @DYALLOC.441
*CALL ARGD1 @DYALLOC.442
*CALL ARGDUMA @DYALLOC.443
*CALL ARGDUMO @DYALLOC.444
*CALL ARGDUMW GKR1F401.181
*CALL ARGSTS @DYALLOC.445
*CALL ARGPTRA @DYALLOC.446
*CALL ARGPTRO @DYALLOC.447
*CALL ARGCONA @DYALLOC.448
*CALL ARGPPX GKR0F305.897
*CALL ARGFLDPT APBHF401.75
& ICODE,CMESSAGE) @DYALLOC.449
ATMPHY1.355
IF (L_WRIT_PHY .AND. GSS1F304.1259
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1260
TJ270193.97
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1261
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1262
GSS1F304.1263
CALL DUMPCTL ( GKR4F403.237
*CALL ARGSIZE GKR4F403.238
*CALL ARGD1 GKR4F403.239
*CALL ARGDUMA GKR4F403.240
*CALL ARGDUMO GKR4F403.241
*CALL ARGDUMW GKR4F403.242
*CALL ARGCONA GKR4F403.243
*CALL ARGPTRA GKR4F403.244
*CALL ARGSTS GKR4F403.245
*CALL ARGPPX GKR4F403.246
& atmos_sm,0,.TRUE.,'af_vdf_ctl',a_step, GIE1F405.10
& ICODE,CMESSAGE) GKR4F403.248
GSS1F304.1265
END IF GSS1F304.1266
GSS1F304.1267
END IF GSS1F304.1268
GSS1F304.1269
IF(LTIMER) THEN ATMPHY1.356
CALL TIMER('VDF_CTL ',4) ATMPHY1.357
END IF ATMPHY1.358
ATMPHY1.359
IF(ICODE.GT.0) THEN ATMPHY1.360
RETURN ATMPHY1.361
END IF ATMPHY1.362
ATMPHY1.363
ENDIF ! non-zero diffusion coefficent ATMPHY1.364
*ENDIF ATMPHY1.365
C ----------------------------------------------------- ATMPHY1.366
ATMPHY1.367
ATMPHY1.368
C --- SECTION 6 --- GRAVITY WAVE DRAG ----------------- ATMPHY1.369
*IF -DEF,A06_0A ATMPHY1.370
CL Skip section 6 if zero coefficient for gravity wave stress ATMPHY1.371
IF(KAY_GWAVE.GT.0.0) THEN ADR1F305.37
ATMPHY1.373
ATMPHY1.374
CL Calculate index of land points ATMPHY1.375
CL Index is relative to FIRST_POINT ATMPHY1.376
ATMPHY1.377
ATMPHY1.378
IF(LTIMER) THEN ATMPHY1.379
CALL TIMER('GWAV_CTL',3) ATMPHY1.380
END IF ATMPHY1.381
ATMPHY1.382
CALL GWAV_CTL(P_FIELD,P_LEVELS,STASH_MAXLEN(6,im_index), GRB4F305.34
*CALL ARGSIZE @DYALLOC.451
*CALL ARGD1 @DYALLOC.452
*CALL ARGDUMA @DYALLOC.453
*CALL ARGDUMO @DYALLOC.454
*CALL ARGDUMW GKR1F401.182
*CALL ARGSTS @DYALLOC.455
*CALL ARGPTRA @DYALLOC.456
*CALL ARGPTRO @DYALLOC.457
*CALL ARGCONA @DYALLOC.458
*CALL ARGPPX GKR0F305.898
*CALL ARGFLDPT APBEF401.1
& ICODE,CMESSAGE) @DYALLOC.459
TJ270193.98
IF (L_WRIT_PHY .AND. GSS1F304.1270
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1271
ATMPHY1.384
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1272
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1273
GSS1F304.1274
CALL DUMPCTL ( GKR4F403.249
*CALL ARGSIZE GKR4F403.250
*CALL ARGD1 GKR4F403.251
*CALL ARGDUMA GKR4F403.252
*CALL ARGDUMO GKR4F403.253
*CALL ARGDUMW GKR4F403.254
*CALL ARGCONA GKR4F403.255
*CALL ARGPTRA GKR4F403.256
*CALL ARGSTS GKR4F403.257
*CALL ARGPPX GKR4F403.258
& atmos_sm,0,.TRUE.,'af_gwavctl',a_step, GIE1F405.11
& ICODE,CMESSAGE) GKR4F403.260
GSS1F304.1276
END IF GSS1F304.1277
GSS1F304.1278
END IF GSS1F304.1279
GSS1F304.1280
IF(LTIMER) THEN ATMPHY1.385
CALL TIMER('GWAV_CTL',4) ATMPHY1.386
END IF ATMPHY1.387
ATMPHY1.388
IF(ICODE.GT.0) THEN ATMPHY1.389
RETURN ATMPHY1.390
END IF ATMPHY1.391
ATMPHY1.392
ENDIF ! non-zero coefficent for gravity wave stress ATMPHY1.393
*ENDIF ATMPHY1.394
C ----------------------------------------------------- ATMPHY1.395
ATMPHY1.396
*IF -DEF,A19_0A ABX1F404.284
CL -- SECTION 19 -- VEGETATION DYNAMICS ------------------------------- ABX1F404.285
CL ABX1F404.286
C----------------------------------------------------------------------- ABX1F404.287
C Increment counter for number of atmosphere timesteps since last ABX1F404.288
C call to TRIFFID vegetation model ABX1F404.289
C----------------------------------------------------------------------- ABX1F404.290
A_INTHD(23) = A_INTHD(23) + 1 ABX1F404.291
ABX1F404.292
C----------------------------------------------------------------------- ABX1F404.293
C If leaf phenology is activated, check whether the atmosphere model ABX1F404.294
C has run an integer number of phenology calling periods. ABX1F404.295
C----------------------------------------------------------------------- ABX1F404.296
PHENOL_CALL=1 ABX1F404.297
TRIFFID_CALL=1 ABX1F404.298
IF (L_PHENOL) THEN ABX1F404.299
PHENOL_CALL = MOD ( FLOAT(A_STEP),(FLOAT(PHENOL_PERIOD)* ABX1F404.300
& (86400.0/SECS_PER_STEPim(atmos_im))) ) ABX1F404.301
ENDIF ABX1F404.302
ABX1F404.303
IF (L_TRIFFID) THEN ABX1F404.304
NSTEP_TRIF=INT(86400.0*A_INTHD(22)/SECS_PER_STEPim(atmos_im)) ABX1F404.305
IF (A_INTHD(23).EQ.NSTEP_TRIF) THEN ABX1F404.306
TRIFFID_CALL=0 ABX1F404.307
ENDIF ABX1F404.308
ENDIF ABX1F404.309
ABX1F404.310
IF ((PHENOL_CALL.EQ.0).OR.(TRIFFID_CALL.EQ.0)) THEN ABX1F404.311
ABX1F404.312
CALL VEG_CTL(P_FIELD,LAND_FIELD,A_STEP,STASH_MAXLEN(3,im_index), ABX1F405.974
*CALL ARGSIZE ABX1F404.314
*CALL ARGD1 ABX1F404.315
*CALL ARGDUMA ABX1F404.316
*CALL ARGDUMO ABX1F404.317
*CALL ARGDUMW ABX1F404.318
*CALL ARGSTS ABX1F404.319
*CALL ARGPTRA ABX1F404.320
*CALL ARGPTRO ABX1F404.321
*CALL ARGCONA ABX1F404.322
*CALL ARGPPX ABX1F404.323
*CALL ARGFLDPT ABX1F404.324
& ICODE,CMESSAGE) ABX1F404.325
ABX1F404.326
ENDIF ABX1F404.327
ABX1F404.328
*ENDIF ABX1F404.329
CL------ SECTION 16 DIAGNOSE ENERGY AND OTHER PHYSICS DIAGNOSTICS ---- ATMPHY1.397
ATMPHY1.398
IF (LEMCORR) THEN GSS1F304.1281
GSS1F304.1282
IF(LENERGY)THEN ATMPHY1.400
C ATMPHY1.401
C SET UP POINTER TO FIRST POINT NEEDED TO P GRID FOR ATMPHY1.402
C CALCULATION ATMPHY1.403
C ATMPHY1.404
C ATMPHY1.406
C CONVERT THETA TO TL (OR T) ATMPHY1.407
C ATMPHY1.408
IF (P_LEVELS.EQ.Q_LEVELS) THEN ATMPHY1.409
C ATMPHY1.410
DO J=1,P_LEVELS ATMPHY1.411
! Fujitsu vectorization directive GRB0F405.22
!OCL NOVREC GRB0F405.23
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB1F401.12
PU=D1(JPSTAR+I-1)*BKH(J+1) + AKH(J+1) ATMPHY1.413
PL=D1(JPSTAR+I-1)*BKH(J) + AKH(J) ATMPHY1.414
D1(JTHETA(J)+I-1)=D1(JTHETA(J)+I-1)* ATMPHY1.415
& P_EXNER_C( D1(JP_EXNER(J+1)+I-1),D1(JP_EXNER(J)+I-1), ATMPHY1.416
& PU,PL,KAPPA ) - ATMPHY1.417
& ((LC*D1(JQCL(J)+I-1) + ATMPHY1.418
& (LC+LF)*D1(JQCF(J)+I-1))/CP) ATMPHY1.419
END DO ATMPHY1.420
END DO ATMPHY1.421
C ATMPHY1.422
ELSE ATMPHY1.423
C ATMPHY1.424
DO J=1,Q_LEVELS ATMPHY1.425
! Fujitsu vectorization directive GRB0F405.24
!OCL NOVREC GRB0F405.25
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB1F401.13
PU=D1(JPSTAR+I-1)*BKH(J+1) + AKH(J+1) ATMPHY1.427
PL=D1(JPSTAR+I-1)*BKH(J) + AKH(J) ATMPHY1.428
D1(JTHETA(J)+I-1)=D1(JTHETA(J)+I-1)* ATMPHY1.429
& P_EXNER_C( D1(JP_EXNER(J+1)+I-1),D1(JP_EXNER(J)+I-1), ATMPHY1.430
& PU,PL,KAPPA ) - ATMPHY1.431
& ((LC*D1(JQCL(J)+I-1) + ATMPHY1.432
& (LC+LF)*D1(JQCF(J)+I-1))/CP) ATMPHY1.433
END DO ATMPHY1.434
END DO ATMPHY1.435
C ATMPHY1.436
DO J=Q_LEVELS+1,P_LEVELS ATMPHY1.437
! Fujitsu vectorization directive GRB0F405.26
!OCL NOVREC GRB0F405.27
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB1F401.14
PU=D1(JPSTAR+I-1)*BKH(J+1) + AKH(J+1) ATMPHY1.439
PL=D1(JPSTAR+I-1)*BKH(J) + AKH(J) ATMPHY1.440
D1(JTHETA(J)+I-1)=D1(JTHETA(J)+I-1)* ATMPHY1.441
& P_EXNER_C( D1(JP_EXNER(J+1)+I-1),D1(JP_EXNER(J)+I-1), ATMPHY1.442
& PU,PL,KAPPA ) ATMPHY1.443
END DO ATMPHY1.444
END DO ATMPHY1.445
C ATMPHY1.446
END IF ATMPHY1.447
C ATMPHY1.448
C ZERO FINAL TOTAL ENERGY AND MASS BEFORE CALCULATION ATMPHY1.449
C ATMPHY1.450
TOT_ENERGY_FINAL = 0.0 ATMPHY1.451
TOT_MASS_FINAL = 0.0 ATMPHY1.452
PART_TOT_MASS = 0.0 ATMPHY1.453
C ATMPHY1.454
C CALCULATE MODIFIED TOTAL ENERGY AND MASS OF ATMOSPHERE ATMPHY1.455
C ATMPHY1.456
IF(LTIMER)THEN ATMPHY1.457
CALL TIMER('EM_DIAG ',3) ATMPHY1.458
END IF ATMPHY1.459
C ATMPHY1.460
CALL ENG_MASS_DIAG (D1(JTHETA(1)),D1(JU(1)),D1(JV(1)), ATMPHY1.461
& COS_P_LATITUDE,COS_U_LATITUDE,P_FIELD, ATMPHY1.462
& U_FIELD,ROW_LENGTH,P_ROWS, APB5F401.1
& A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK), ATMPHY1.464
& A_LEVDEPC(JAK),A_LEVDEPC(JBK), ATMPHY1.465
& TOT_ENERGY_FINAL,TOT_MASS_FINAL, ATMPHY1.466
& PART_TOT_MASS,P_LEVELS,D1(JPSTAR), APB5F401.2
*CALL ARGFLDPT APB5F401.3
& LLINTS,LWHITBROM) APB5F401.4
C ATMPHY1.468
IF(LTIMER)THEN ATMPHY1.469
CALL TIMER('EM_DIAG ',4) ATMPHY1.470
END IF ATMPHY1.471
C ATMPHY1.472
C CALCULATE ENERGY CORRECTION AND CORRECT PSTAR ATMPHY1.473
C ATMPHY1.474
IF(LTIMER)THEN ATMPHY1.475
CALL TIMER('CEM_CORR',3) ATMPHY1.476
END IF ATMPHY1.477
C ATMPHY1.478
! Set A_REALHD to globally summed net energy flux GSM3F404.28
CALL DO_SUMS(D1(JNET_FLUX),P_FIELD,ROW_LENGTH+1, GSM3F404.29
& P_FIELD-ROW_LENGTH,1,A_REALHD(18)) GSM3F404.30
CALL CAL_ENG_MASS_CORR (A_REALHD(18),A_REALHD(20), ATMPHY1.479
& TOT_ENERGY_FINAL,A_REALHD(19), ATMPHY1.480
& TOT_MASS_FINAL,PART_TOT_MASS, ATMPHY1.481
& P_FIELD,P_FIELD,A_REALHD(21), ATMPHY1.482
& D1(JPSTAR), APB5F401.5
*CALL ARGFLDPT APB5F401.6
& A_REALHD(1),A_REALHD(2)) APB5F401.7
C ATMPHY1.484
IF(LTIMER)THEN ATMPHY1.485
CALL TIMER('CEM_CORR',4) ATMPHY1.486
END IF ATMPHY1.487
C ATMPHY1.488
C SWAP MODIFIED TOTAL ENERGY AND TOTAL MASS OF ATMOSPHERE ATMPHY1.489
C ATMPHY1.490
A_REALHD(19) = TOT_MASS_FINAL ATMPHY1.491
A_REALHD(20) = TOT_ENERGY_FINAL ATMPHY1.492
C ATMPHY1.493
C ZERO ACCUMLATED DIABATIC FLUXES ATMPHY1.494
C ATMPHY1.495
A_REALHD(18) = 0.0 ATMPHY1.496
C ATMPHY1.497
C CONVERT TL (OR T) TO THETA ATMPHY1.498
C ATMPHY1.499
IF (P_LEVELS.EQ.Q_LEVELS) THEN ATMPHY1.500
C ATMPHY1.501
DO J=1,P_LEVELS ATMPHY1.502
! Fujitsu vectorization directive GRB0F405.28
!OCL NOVREC GRB0F405.29
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB1F401.15
PU=D1(JPSTAR+I-1)*BKH(J+1) + AKH(J+1) ATMPHY1.504
PL=D1(JPSTAR+I-1)*BKH(J) + AKH(J) ATMPHY1.505
D1(JTHETA(J)+I-1) = (D1(JTHETA(J)+I-1) + ((LC*D1(JQCL(J)+I-1)+ ATMPHY1.506
& (LC+LF)*D1(JQCF(J)+I-1))/CP)) / ATMPHY1.507
& P_EXNER_C( D1(JP_EXNER(J+1)+I-1),D1(JP_EXNER(J)+I-1), ATMPHY1.508
& PU,PL,KAPPA ) ATMPHY1.509
END DO ATMPHY1.510
END DO ATMPHY1.511
C ATMPHY1.512
ELSE ATMPHY1.513
C ATMPHY1.514
DO J=1,Q_LEVELS ATMPHY1.515
! Fujitsu vectorization directive GRB0F405.30
!OCL NOVREC GRB0F405.31
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB1F401.16
PU=D1(JPSTAR+I-1)*BKH(J+1) + AKH(J+1) ATMPHY1.517
PL=D1(JPSTAR+I-1)*BKH(J) + AKH(J) ATMPHY1.518
D1(JTHETA(J)+I-1) = (D1(JTHETA(J)+I-1) + ((LC*D1(JQCL(J)+I-1)+ ATMPHY1.519
& (LC+LF)*D1(JQCF(J)+I-1))/CP)) / ATMPHY1.520
& P_EXNER_C( D1(JP_EXNER(J+1)+I-1),D1(JP_EXNER(J)+I-1), ATMPHY1.521
& PU,PL,KAPPA ) ATMPHY1.522
END DO ATMPHY1.523
END DO ATMPHY1.524
C ATMPHY1.525
DO J=Q_LEVELS+1,P_LEVELS ATMPHY1.526
! Fujitsu vectorization directive GRB0F405.32
!OCL NOVREC GRB0F405.33
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB1F401.17
PU=D1(JPSTAR+I-1)*BKH(J+1) + AKH(J+1) ATMPHY1.528
PL=D1(JPSTAR+I-1)*BKH(J) + AKH(J) ATMPHY1.529
D1(JTHETA(J)+I-1) = D1(JTHETA(J)+I-1) / ATMPHY1.530
& P_EXNER_C( D1(JP_EXNER(J+1)+I-1),D1(JP_EXNER(J)+I-1), ATMPHY1.531
& PU,PL,KAPPA ) ATMPHY1.532
END DO ATMPHY1.533
END DO ATMPHY1.534
C ATMPHY1.535
END IF ATMPHY1.536
C ATMPHY1.537
END IF ATMPHY1.538
C ATMPHY1.539
END IF ! LEMCORR GSS1F304.1285
ATMPHY1.541
*IF DEF,GLOBAL ATMPHY1.542
IF (L_LSPICE) THEN ADM2F404.269
! Polar updating isn't working. Don't try it at all. ADM2F404.270
ELSE ADM2F404.271
ATMPHY1.543
CL Calculate average increments at points next to poles ATMPHY1.544
ATMPHY1.545
DO LEVEL=1,P_LEVELS ATMPHY1.546
ATMPHY1.547
*IF DEF,MPP APB1F401.18
IF (at_top_of_LPG) THEN APB1F401.19
*ENDIF APB1F401.20
DO I=1,ROW_LENGTH APB1F401.21
N_POLAR_VALUES(I,LEVEL)= APB1F401.22
& D1(JTHETA(LEVEL)+TOP_ROW_START+ROW_LENGTH+I-2)- APB1F401.23
& N_POLAR_VALUES(I,LEVEL) APB1F401.24
ENDDO APB1F401.25
*IF DEF,MPP APB1F401.26
ENDIF APB1F401.27
APB1F401.28
IF (at_base_of_LPG) THEN APB1F401.29
*ENDIF APB1F401.30
DO I=1,ROW_LENGTH APB1F401.31
S_POLAR_VALUES(I,LEVEL)= APB1F401.32
& D1(JTHETA(LEVEL)+P_BOT_ROW_START-ROW_LENGTH+I-2)- APB1F401.33
& S_POLAR_VALUES(I,LEVEL) APB1F401.34
ENDDO APB1F401.35
*IF DEF,MPP APB1F401.36
ENDIF APB1F401.37
*ENDIF APB1F401.38
ENDDO APB2F401.62
ATMPHY1.556
IF(LTIMER) THEN ATMPHY1.557
CALL TIMER('POLAR ',3) TS150793.18
END IF ATMPHY1.559
ATMPHY1.560
C Call POLAR to update the polar value of THETA. ATMPHY1.561
ATMPHY1.562
CALL POLAR(D1(JTHETA(1)),N_POLAR_VALUES(1,1),S_POLAR_VALUES(1,1), APB2F401.63
*CALL ARGFLDPT APB2F401.64
& P_FIELD,ROW_LENGTH,ROW_LENGTH,1,1,ROW_LENGTH, APB2F401.65
& P_LEVELS) APB2F401.66
ATMPHY1.566
IF(LTIMER) THEN ATMPHY1.567
CALL TIMER('POLAR ',4) TS150793.19
END IF ATMPHY1.569
ATMPHY1.570
ATMPHY1.572
DO LEVEL=1,Q_LEVELS ATMPHY1.573
ATMPHY1.574
*IF DEF,MPP APB1F401.39
IF (at_top_of_LPG) THEN APB1F401.40
*ENDIF APB1F401.41
DO I=1,ROW_LENGTH APB1F401.42
N_POLAR_VALUES(I,LEVEL+P_LEVELS)= APB1F401.43
& D1(JQ(LEVEL)+TOP_ROW_START+ROW_LENGTH+I-2)- APB1F401.44
& N_POLAR_VALUES(I,LEVEL+P_LEVELS) APB1F401.45
N_POLAR_VALUES(I,LEVEL+P_LEVELS+Q_LEVELS)= APB1F401.46
& D1(JQCL(LEVEL)+TOP_ROW_START+ROW_LENGTH+I-2)- APB1F401.47
& N_POLAR_VALUES(I,LEVEL+P_LEVELS+Q_LEVELS) APB1F401.48
N_POLAR_VALUES(I,LEVEL+P_LEVELS+2*Q_LEVELS)= APB1F401.49
& D1(JQCF(LEVEL)+TOP_ROW_START+ROW_LENGTH+I-2)- APB1F401.50
& N_POLAR_VALUES(I,LEVEL+P_LEVELS+2*Q_LEVELS) APB1F401.51
ENDDO APB1F401.52
*IF DEF,MPP APB1F401.53
ENDIF APB1F401.54
APB1F401.55
IF (at_base_of_LPG) THEN APB1F401.56
*ENDIF APB1F401.57
DO I=1,ROW_LENGTH APB1F401.58
S_POLAR_VALUES(I,LEVEL+P_LEVELS)= APB1F401.59
& D1(JQ(LEVEL)+P_BOT_ROW_START-ROW_LENGTH+I-2)- APB1F401.60
& S_POLAR_VALUES(I,LEVEL+P_LEVELS) APB1F401.61
S_POLAR_VALUES(I,LEVEL+P_LEVELS+Q_LEVELS)= APB1F401.62
& D1(JQCL(LEVEL)+P_BOT_ROW_START-ROW_LENGTH+I-2)- APB1F401.63
& S_POLAR_VALUES(I,LEVEL+P_LEVELS+Q_LEVELS) APB1F401.64
S_POLAR_VALUES(I,LEVEL+P_LEVELS+2*Q_LEVELS)= APB1F401.65
& D1(JQCF(LEVEL)+P_BOT_ROW_START-ROW_LENGTH+I-2)- APB1F401.66
& S_POLAR_VALUES(I,LEVEL+P_LEVELS+2*Q_LEVELS) APB1F401.67
ENDDO APB1F401.68
*IF DEF,MPP APB1F401.69
ENDIF APB1F401.70
*ENDIF APB1F401.71
ENDDO APB2F401.67
ATMPHY1.595
IF(LTIMER) THEN ATMPHY1.596
CALL TIMER('POLAR ',3) TS150793.20
END IF ATMPHY1.598
ATMPHY1.599
! Call POLAR to update the polar value of Q. APB2F401.68
APB2F401.69
CALL POLAR(D1(JQ(1)),N_POLAR_VALUES(1,P_LEVELS+1), APB2F401.70
& S_POLAR_VALUES(1,P_LEVELS+1), APB2F401.71
*CALL ARGFLDPT APB2F401.72
& P_FIELD,ROW_LENGTH,ROW_LENGTH,1,1,ROW_LENGTH, APB2F401.73
& Q_LEVELS) APB2F401.74
APB2F401.75
! Call POLAR to update the polar value of QCL. APB2F401.76
APB2F401.77
CALL POLAR(D1(JQCL(1)),N_POLAR_VALUES(1,P_LEVELS+Q_LEVELS+1), APB2F401.78
& S_POLAR_VALUES(1,P_LEVELS+Q_LEVELS+1), APB2F401.79
*CALL ARGFLDPT APB2F401.80
& P_FIELD,ROW_LENGTH,ROW_LENGTH,1,1,ROW_LENGTH, APB2F401.81
& Q_LEVELS) APB2F401.82
APB2F401.83
! Call POLAR to update the polar value of QCF. APB2F401.84
APB2F401.85
CALL POLAR(D1(JQCF(1)),N_POLAR_VALUES(1,P_LEVELS+2*Q_LEVELS+1), APB2F401.86
& S_POLAR_VALUES(1,P_LEVELS+2*Q_LEVELS+1), APB2F401.87
*CALL ARGFLDPT APB2F401.88
& P_FIELD,ROW_LENGTH,ROW_LENGTH,1,1,ROW_LENGTH, APB2F401.89
& Q_LEVELS) APB2F401.90
IF(LTIMER) THEN ATMPHY1.618
CALL TIMER('POLAR ',4) TS150793.21
END IF ATMPHY1.620
ATMPHY1.621
ATMPHY1.623
! End if for L_LSPICE ADM2F404.272
END IF ADM2F404.273
*ENDIF ATMPHY1.624
ATMPHY1.625
IF(L_TRACER_THETAL_QT)THEN ATD1F400.92
C IF TRACER ADVECTION CHECK FOR NEGATIVE Q AFTER PHYSICS ATD1F400.93
ITOLQ = 1 ATD1F400.94
ITOLQCL = 1 ATD1F400.95
ITOLQCF = 1 ATD1F400.96
DO K=1,Q_LEVELS ATD1F400.97
II=0 ATD1F400.98
IIQCL=0 ATD1F400.99
IIQCF=0 ATD1F400.100
IQNEG(1)=0 ATD1F400.101
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB1F401.72
IF(D1(JQ(K)+I-1).LT.0.0) THEN ATD1F400.103
D1(JQ(K)+I-1)=0.0 ATD1F400.104
II=II+1 ATD1F400.105
IQNEG(II)=I ATD1F400.106
ENDIF ATD1F400.107
IF(D1(JQCL(K)+I-1).LT.0.0) THEN ATD1F400.108
D1(JQCL(K)+I-1)=0.0 ATD1F400.109
IIQCL=IIQCL+1 ATD1F400.110
IQCLNEG(IIQCL)=I ATD1F400.111
ENDIF ATD1F400.112
IF(D1(JQCF(K)+I-1).LT.0.0) THEN ATD1F400.113
D1(JQCF(K)+I-1)=0.0 ATD1F400.114
IIQCF=IIQCF+1 ATD1F400.115
IQCFNEG(IIQCF)=I ATD1F400.116
ENDIF ATD1F400.117
ENDDO ATD1F400.118
IF(II.NE.0.AND.ITOLQ.LE.1) THEN ATD1F400.119
WRITE(6,*) 'AFTER PHYSICS: NEGATIVE Q FOUND AND RESET TO ZERO' ATD1F400.120
C WRITE(6,*) 'NEGATIVE QT LEVEL ',K,' POINTS ',(IQNEG(I),I=1,II) ATD1F400.121
ITOLQ = ITOLQ + 1 ATD1F400.122
END IF ATD1F400.123
IF(IIQCL.NE.0.AND.ITOLQCL.LE.1) THEN ATD1F400.124
WRITE(6,*) 'AFTER PHYSICS: NEGATIVE QCL FOUND AND RESET TO ZERO' ATD1F400.125
ITOLQCL = ITOLQCL + 1 ATD1F400.126
END IF ATD1F400.127
IF(IIQCF.NE.0.AND.ITOLQCF.LE.1) THEN ATD1F400.128
WRITE(6,*) 'AFTER PHYSICS: NEGATIVE QCF FOUND AND RESET TO ZERO' ATD1F400.129
ITOLQCF = ITOLQCF + 1 ATD1F400.130
END IF ATD1F400.131
ENDDO ATD1F400.132
END IF ATD1F400.133
*IF DEF,MPP APB1F305.79
! Do boundary swaps on U,V,Q,THETA and QCL at all relevant levels APB1F305.80
CALL SWAPBOUNDS(D1(JU(1)),ROW_LENGTH,tot_P_ROWS, APB1F401.73
& EW_Halo,NS_Halo,P_LEVELS) APB1F401.74
CALL SWAPBOUNDS(D1(JV(1)),ROW_LENGTH,tot_P_ROWS, APB1F401.75
& EW_Halo,NS_Halo,P_LEVELS) APB1F401.76
CALL SWAPBOUNDS(D1(JQ(1)),ROW_LENGTH,tot_P_ROWS, APB1F401.77
& EW_Halo,NS_Halo,Q_LEVELS) APB1F401.78
CALL SWAPBOUNDS(D1(JQCL(1)),ROW_LENGTH,tot_P_ROWS, APB1F401.79
& EW_Halo,NS_Halo,Q_LEVELS) APB1F401.80
CALL SWAPBOUNDS(D1(JQCF(1)),ROW_LENGTH,tot_P_ROWS, APB1F401.81
& EW_Halo,NS_Halo,Q_LEVELS) APB1F401.82
CALL SWAPBOUNDS(D1(JTHETA(1)),ROW_LENGTH,tot_P_ROWS, APB1F401.83
& EW_Halo,NS_Halo,P_LEVELS) APB1F401.84
CALL SWAPBOUNDS(D1(JSNODEP),ROW_LENGTH,tot_P_ROWS, ARE1F405.34
& EW_Halo,NS_Halo,1) ARE1F405.35
IF (L_SULPC_SO2) THEN GSM6F404.12
CALL SWAPBOUNDS(D1(JSO2(1)),ROW_LENGTH,tot_P_ROWS, GSM6F404.13
& EW_Halo,NS_Halo,P_LEVELS) GSM6F404.14
CALL SWAPBOUNDS(D1(JSO4_AITKEN(1)),ROW_LENGTH,tot_P_ROWS, GSM6F404.15
& EW_Halo,NS_Halo,P_LEVELS) GSM6F404.16
CALL SWAPBOUNDS(D1(JSO4_ACCU(1)),ROW_LENGTH,tot_P_ROWS, GSM6F404.17
& EW_Halo,NS_Halo,P_LEVELS) GSM6F404.18
CALL SWAPBOUNDS(D1(JSO4_DISS(1)),ROW_LENGTH,tot_P_ROWS, GSM6F404.19
& EW_Halo,NS_Halo,P_LEVELS) GSM6F404.20
GSM6F404.21
IF (L_SULPC_NH3) THEN AWO5F405.43
CALL SWAPBOUNDS(D1(JNH3(1)),ROW_LENGTH,tot_P_ROWS, AWO5F405.44
& EW_Halo,NS_Halo,P_LEVELS) AWO5F405.45
END IF AWO5F405.46
IF (L_SULPC_DMS) THEN GSM6F404.22
CALL SWAPBOUNDS(D1(JDMS(1)),ROW_LENGTH,tot_P_ROWS, GSM6F404.23
& EW_Halo,NS_Halo,P_LEVELS) GSM6F404.24
ENDIF GSM6F404.25
ENDIF GSM6F404.26
IF (L_SOOT) THEN AWO5F405.47
CALL SWAPBOUNDS(D1(JSOOT_NEW(1)),ROW_LENGTH,tot_P_ROWS, AWO5F405.48
& EW_Halo,NS_Halo,P_LEVELS) AWO5F405.49
CALL SWAPBOUNDS(D1(JSOOT_AGD(1)),ROW_LENGTH,tot_P_ROWS, AWO5F405.50
& EW_Halo,NS_Halo,P_LEVELS) AWO5F405.51
CALL SWAPBOUNDS(D1(JSOOT_CLD(1)),ROW_LENGTH,tot_P_ROWS, AWO5F405.52
& EW_Halo,NS_Halo,P_LEVELS) AWO5F405.53
END IF AWO5F405.54
IF (L_CO2_INTERACTIVE) THEN ACN2F405.38
CALL SWAPBOUNDS(D1(JCO2(1)),ROW_LENGTH,tot_P_ROWS, ACN2F405.39
& EW_Halo,NS_Halo,P_LEVELS) ACN2F405.40
ENDIF ACN2F405.41
*ENDIF APB1F305.93
RETURN ATMPHY1.626
END ATMPHY1.627
ATMPHY1.628
ATMPHY1.629
*ENDIF ATMPHY1.630