SUBROUTINE ATM_DYN 1,155ATMDYN1.35
& (U_FIELDDA,P_FIELDDA,P_LEVELSDA,Q_LEVELSDA,P_ROWSDA, AYY2F400.203
& NUM_STASH_LEVELSDA, AYY2F400.204
& STASHLEN,PSTAR_OLD,DYN_TIMESTEP, GPB3F403.9
*CALL ARGSIZE 
@DYALLOC.245
*CALL ARGD1 @DYALLOC.246
*CALL ARGDUMA @DYALLOC.247
*CALL ARGDUMO @DYALLOC.248
*CALL ARGDUMW GKR1F401.166
*CALL ARGSTS @DYALLOC.249
*CALL ARGPTRA @DYALLOC.250
*CALL ARGPTRO @DYALLOC.251
*CALL ARGCONA @DYALLOC.252
*CALL ARGPPX GKR0F305.878
*CALL ARGFLDPT APB0F401.6
& ICODE,CMESSAGE,WRITD1_TEST) GSS1F304.1293
ATMDYN1.42
IMPLICIT NONE ATMDYN1.43
ATMDYN1.44
*CALL CMAXSIZE @DYALLOC.254
*CALL CSUBMODL GSS1F305.919
*CALL TYPSIZE @DYALLOC.255
*CALL TYPD1 @DYALLOC.256
*CALL TYPDUMA @DYALLOC.257
*CALL TYPDUMO @DYALLOC.258
*CALL TYPDUMW GKR1F401.167
*CALL TYPSTS @DYALLOC.259
*CALL TYPPTRA @DYALLOC.260
*CALL TYPPTRO @DYALLOC.261
*CALL TYPCONA @DYALLOC.262
*CALL PPXLOOK GKR0F305.879
APB0F401.7
! All TYPFLDPT arguments are intent IN APB0F401.8
*CALL TYPFLDPT APB0F401.9
@DYALLOC.263
INTEGER ATMDYN1.45
& U_FIELDDA, ! Extra copy of U_FIELD for dynamic alloc @DYALLOC.264
& P_FIELDDA, ! and P_FIELD @DYALLOC.265
& P_LEVELSDA, ! and P_LEVELS @DYALLOC.266
& Q_LEVELSDA, ! and Q_LEVELS AYY2F400.205
& P_ROWSDA, ! and P_ROWS AYY2F400.206
& NUM_STASH_LEVELSDA,! and NUM_STASH_LEVELS @DYALLOC.267
& STASHLEN, ! max. length of stashwork required ARB0F400.4
& ICODE ! Return code : 0 Normal exit ATMDYN1.50
C ! :>0 Error ATMDYN1.51
REAL @DYALLOC.268
& PSTAR_OLD(P_FIELD) ! OUT pstar at beginning of dynamics @DYALLOC.269
& ,DYN_TIMESTEP ! IN timestep for dynamics ARB0F400.6
CHARACTER*80 TS150793.9
& CMESSAGE ! Error message if ICODE >0 ATMDYN1.54
ATMDYN1.55
CL include comdecks @DYALLOC.270
ATMDYN1.58
*CALL CHSUNITS RS030293.92
*CALL CCONTROL ATMDYN1.60
*CALL CHISTORY GDR3F305.6
*CALL CPHYSCON ATMDYN1.65
*CALL CTIME @DYALLOC.271
*CALL C_GLOBAL GSS1F304.1294
*CALL C_WRITD GSS1F304.1295
*CALL CRUNTIMC ADR1F305.9
*CALL CPPRINT ARB1F403.69
*IF DEF,MPP ARB1F402.71
*CALL PARVARS ARB1F402.72
*ENDIF ARB1F402.73
ATMDYN1.70
CL Dynamically allocated area for stash processing ATMDYN1.71
ATMDYN1.72
REAL ATMDYN1.73
& STASHWORK(STASHLEN) ATMDYN1.74
ATMDYN1.76
REAL MM280993.3
& OMEGA_PRESS(NUM_STASH_LEVELSDA) @DYALLOC.272
ATMDYN1.79
CXL additional dynamically allocated workspace ATMDYN1.80
ATMDYN1.81
REAL ATMDYN1.82
& KD(P_LEVELSDA), @DYALLOC.273
& U_MEAN(U_FIELDDA,P_LEVELSDA), @DYALLOC.274
& WORK1(U_FIELDDA,P_LEVELSDA), @DYALLOC.275
& ETADOT(P_FIELDDA,P_LEVELSDA), @DYALLOC.276
& RS_FUNCTIONS(P_FIELDDA,P_LEVELSDA) @DYALLOC.277
ATMDYN1.88
REAL ATMDYN1.89
& WORK2(P_FIELDDA), @DYALLOC.278
& WORK3(P_FIELDDA*P_LEVELSDA) @DYALLOC.279
&, WORK4(P_FIELDDA,P_LEVELSDA) AAD2F404.314
&, WORK5(P_FIELDDA,Q_LEVELSDA) AYY2F400.208
&, ZERO_FIELD(P_FIELDDA,Q_LEVELSDA) ! mixed phase precip ADM2F404.38
ATMDYN1.92
LOGICAL ATMDYN1.93
& LIST(P_LEVELSDA) @DYALLOC.280
ATMDYN1.95
INTEGER ATMDYN1.96
*IF DEF,MPP ARB1F402.74
& TRACER_EW_SWEEPS(glsize(2),P_LEVELSDA) ARB1F402.75
*ELSE ARB1F402.76
& TRACER_EW_SWEEPS(P_ROWSDA,P_LEVELSDA) AYY2F400.209
*ENDIF ARB1F402.77
ATMDYN1.98
C*L external subroutine calls ATMDYN1.99
ATMDYN1.100
EXTERNAL ATMDYN1.101
& SET_FIL, ATMDYN1.102
& ADJ_CTL, ATMDYN1.103
& THETL_QT, ATMDYN1.104
& SET_TRAC, ARB1F402.78
& TRAC_ADV, ATMDYN1.105
& TRAC_VERT_ADV, ATMDYN1.106
& ADV_CTL, ATMDYN1.107
& MASS_UWT, ATMDYN1.108
& MASS_UWT_UV, ATD1F400.1
& DIF_CTL, ATMDYN1.109
& QT_POS, ATMDYN1.110
& FILT_UV, ATMDYN1.111
& STASH, ATMDYN1.112
& SET_LEVELS_LIST, ATMDYN1.113
& DIAG10_QC, ABM3F400.4
& DIAG10_A, ATMDYN1.114
& DIAG10_B, ATMDYN1.115
& TIMER ATMDYN1.116
& ,GLUE_CLD AYY2F400.210
& ,DIV_CALC AL131293.40
& ,MAXWIND AL131293.41
& ,DIVTEST AL131293.42
& ,ATMOS_ANG_MOM ARS1F400.3
& ,TRSRCE APC1F304.2
& ,TRBDRY APC1F304.3
*IF DEF,GLOBAL ATMDYN1.117
& ,FILT_FLD ATMDYN1.118
*ENDIF ATMDYN1.119
& ,DUMPCTL GKR4F403.102
ATMDYN1.120
ATMDYN1.121
ATMDYN1.128
C* --------------------------------------------------------------------- ATMDYN1.129
C Other local variables ATMDYN1.130
ATMDYN1.131
INTEGER ATMDYN1.132
& FIRST_POINT, ATMDYN1.135
& LAST_POINT, ATMDYN1.136
& VAR, ATMDYN1.137
& I, ATMDYN1.138
& II, ATD1F400.2
& IQNEG(P_FIELDDA), ! Pointer to negative q points to reset ATD1F400.3
& ! before calling tracer advection on qt ATD1F400.4
* & ,PRESSURE_ALTITUDE ! Pressure altitude for steep slope test ATD1F400.5
& ISL, ATMDYN1.139
& NI, ATMDYN1.140
& OMEGA_P_LEVS, ATMDYN1.141
& K, ATMDYN1.142
& POINTS, ATMDYN1.144
& START_LEVEL, ATMDYN1.145
& END_LEVEL, ATMDYN1.146
& LEVEL, ATMDYN1.147
& INEG_THETA, ATMDYN1.148
& WORK_LENGTH ATMDYN1.149
& ,IQCFNEG(P_FIELDDA) ADM2F404.122
& ,IM_IDENT ! internal model identifier GRB4F305.2
& ,IM_INDEX ! internal model index for STASH arrays GRB4F305.3
& ,I_COUNT AL131293.43
& ,NSWEEPS ! Number of sweeps of dynamics to perform AL131293.44
& ,ERROR AL131293.45
& ,A_STEP GDR5F305.7
& ,I_LOOP ! loop for multiple dynamics timesteps GPB3F403.10
*IF DEF,MPP APB0F305.9
APB0F305.10
INTEGER J,I_start,I_end APB0F401.10
INTEGER info APB0F401.11
INTEGER int_log ! integer version of logical: APB0F401.12
! ! 0 = .FALSE. APB0F401.13
! ! 1 = .TRUE. APB0F401.14
APB0F305.12
*ENDIF APB0F305.13
ATMDYN1.150
REAL ATMDYN1.151
& ADJUSTMENT_TIMESTEP, ATMDYN1.152
& LONGITUDE_STEP_INVERSE, ATMDYN1.153
& LATITUDE_STEP_INVERSE, ATMDYN1.154
& SCALAR, ATMDYN1.155
& WEIGHT ATMDYN1.156
& ,LOCAL_ADVSTEP ! Local advection timestep AL131293.46
& ,LOCAL_ADJSTEP ! Local adjustment timestep AL131293.47
& ,PU,PL AL131293.48
& ,DIVERG(P_FIELDDA) ! Horizontal divergence at top level ANF1F304.36
ATMDYN1.157
LOGICAL ATMDYN1.158
& L_GEOP ATMDYN1.159
&,L_WIND ! Set to true if wind exceeds limit AL131293.50
&,L_DIVERG ! Set to true if divergence exceeds limit AL131293.51
&,L_NEG_THETA_FOUND ! set to true if negative theta found APB0F401.15
&,FIRST_SWEEP,LAST_SWEEP ! First and/or last sweeps of dynamics ARR2F405.4
&,WRITD1_FIRST_SWEEP ! =T write on first sweep, =F on last sweep ARR2F405.5
&,WRITD1_THIS_SWEEP ! diagnostic dump write local switch ARR2F405.6
ARR2F405.7
PARAMETER(WRITD1_FIRST_SWEEP=.true.) ! default for dump write ARR2F405.8
C AL131293.52
*CALL P_EXNERC AL131293.53
ATMDYN1.160
ATMDYN1.161
ICODE=0 ATMDYN1.162
A_STEP = STEPim(atmos_im) GDR5F305.8
im_ident = atmos_im GRB4F305.4
im_index = internal_model_index(im_ident) GRB4F305.5
ATMDYN1.163
DO I_LOOP=1,A_SWEEPS_DYN GPB3F403.11
GPB3F403.12
! Must convert thetal,qt to theta,q,cl,cf for 2nd and subsequent loops GPB3F403.13
GPB3F403.14
IF (I_LOOP .GT. 1) THEN GPB3F403.15
GPB3F403.16
IF (LTIMER) CALL TIMER('THL2TH ',3) GPB3F403.17
GPB3F403.18
CALL THLQT2THQ(P_FIELD,Q_LEVELS, GPB3F403.19
& D1(JPSTAR),D1(JP_EXNER(1)), GPB3F403.20
& AKH,BKH,A_LEVDEPC(JAK),A_LEVDEPC(JBK),RHCRIT, GPB3F403.21
& D1(JTHETA(1)), GPB3F403.22
& D1(JQ(1)),D1(JQCF(1)),D1(JQCL(1)),D1(JRHC(1)), ASK1F405.84
& ICODE) GPB3F403.24
GPB3F403.25
IF (LTIMER) CALL TIMER('THL2TH ',4) GPB3F403.26
GPB3F403.27
ENDIF GPB3F403.28
ADJUSTMENT_TIMESTEP = DYN_TIMESTEP/A_ADJSTEPS ARB0F400.7
LONGITUDE_STEP_INVERSE=RECIP_PI_OVER_180/A_REALHD(1) ATMDYN1.165
LATITUDE_STEP_INVERSE=RECIP_PI_OVER_180/A_REALHD(2) ATMDYN1.166
NSWEEPS=1 AL131293.54
C AL131293.55
C TEST OF WIND AL131293.56
IF (L_HALF_TIMESTEP_DYN) THEN AL131293.57
L_WIND=.FALSE. AL131293.58
CALL MAXWIND(L_WIND,WIND_LIMIT,D1(JU(1)),D1(JV(1)),U_FIELD, ADR1F305.11
& FIRST_FLD_PT,LAST_U_FLD_PT,P_LEVELS) APB0F401.16
*IF DEF,MPP APB0F401.17
! Create a global version of L_WIND - so if any processor has L_WIND APB0F401.18
! set to .TRUE. - all processors will. APB0F401.19
int_log=0 APB0F401.20
IF (L_WIND) int_log=1 APB0F401.21
CALL GC_IMAX(1,N_PROCS,info,int_log) APB0F401.22
IF (int_log .EQ. 1) L_WIND=.TRUE. APB0F401.23
APB0F401.24
*ENDIF APB0F401.25
C IF WIND EXCEEDS LIMIT DO TWO SWEEPS AL131293.61
IF (L_WIND) THEN AL131293.62
NSWEEPS=2 AL131293.63
WRITE(6,'(A,I2)') ' WIND LIMIT EXCEEDED. NSWEEPS = ', GDR8F405.54
& NSWEEPS GDR8F405.55
END IF AL131293.64
END IF AL131293.65
C AL131293.66
C TEST OF DIVERGENCE AL131293.67
IF (L_HALF_TIMESTEP_DIV) THEN AL131293.68
C CALCULATE DIVERGENCE OF TOP LEVEL AL131293.69
K=P_LEVELS AL131293.70
CALL DIV_CALC(D1(JU(K)),D1(JV(K)),U_FIELD,P_FIELD,ROW_LENGTH, ARB2F403.2
*CALL ARGFLDPT ARB2F403.3
& SEC_P_LATITUDE,COS_U_LATITUDE, ARB2F403.4
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE,DIVERG) ARB2F403.5
C COMPARE DIVERGENCE WITH LIMIT SET AL131293.74
L_DIVERG=.FALSE. AL131293.75
CALL DIVTEST(P_FIELD, APB0F401.26
& (FIRST_ROW-1)*ROW_LENGTH+1,LAST_U_FLD_PT, APB0F401.27
& DIVERG,DIV_LIMIT,L_DIVERG) APB0F401.28
*IF DEF,MPP APB0F401.29
! Create a global version of L_DIVERG - so if any processor has L_DIVERG APB0F401.30
! set to .TRUE. - all processors will. APB0F401.31
int_log=0 APB0F401.32
IF (L_DIVERG) int_log=1 APB0F401.33
CALL GC_IMAX(1,N_PROCS,info,int_log) APB0F401.34
IF (int_log .EQ. 1) L_DIVERG=.TRUE. APB0F401.35
APB0F401.36
*ENDIF APB0F401.37
C IF DIVERGENCE EXCEEDS LIMIT DO TWO SWEEPS AL131293.78
IF (L_DIVERG) THEN AL131293.79
NSWEEPS=2 AL131293.80
WRITE(6,'(A,I2)') ' DIVERGENCE LIMIT EXCEEDED.'// GDR8F405.56
& ' NSWEEPS = ',NSWEEPS GDR8F405.57
END IF AL131293.81
END IF AL131293.82
C AL131293.83
LOCAL_ADVSTEP = DYN_TIMESTEP/NSWEEPS ARB0F400.8
LOCAL_ADJSTEP = LOCAL_ADVSTEP/A_ADJSTEPS ARB0F400.9
ATMDYN1.167
IF (L_LSPICE) THEN ADM2F404.123
! Remove negative qcf before dynamics,generated by ac and physics, ADM2F404.124
! probably. ADM2F404.125
DO K=1,Q_LEVELS ADM2F404.126
II=0 ADM2F404.127
IQCFNEG(1)=0 ADM2F404.128
DO I=1,P_FIELD ADM2F404.129
IF(D1(JQCF(K)+I-1).LT.0.0) THEN ADM2F404.130
II=II+1 ADM2F404.131
IQCFNEG(II)=I ADM2F404.132
D1(JQCF(K)+I-1)=0.0 ADM2F404.133
ENDIF ADM2F404.134
ENDDO ADM2F404.135
ENDDO ADM2F404.142
END IF ADM2F404.143
IF(L_TRACER_THETAL_QT)THEN ATD1F400.6
C Remove negative qt generated by ac and physics, ATD1F400.7
C before calling tracer (postive definite) advection dynamics ATD1F400.8
DO K=1,Q_LEVELS ATD1F400.9
II=0 ATD1F400.10
IQNEG(1)=0 ATD1F400.11
! loop over all points, including valid halos APB0F401.38
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.39
IF(D1(JQ(K)+I-1).LT.0.0) THEN ATD1F400.13
II=II+1 ATD1F400.14
IQNEG(II)=I ATD1F400.15
D1(JQ(K)+I-1)=0.0 ATD1F400.16
ENDIF ATD1F400.17
ENDDO ATD1F400.18
IF(II.GT.0) THEN ATD1F400.19
WRITE(6,*) 'BEFORE DYNAMICS:' ATD1F400.20
WRITE(6,*) 'LEVEL, NO. Q NEG ',K,II ATD1F400.21
& ,(IQNEG(I),I=1,II) ATD1F400.22
WRITE(6,*) ' NEGATIVE VALUES SET TO ZERO.' ATD1F400.23
END IF ATD1F400.24
ENDDO ATD1F400.25
END IF ATD1F400.26
*IF DEF,GLOBAL ATMDYN1.168
ATMDYN1.169
IF(L_SET_FILTER) THEN ATMDYN1.170
ATMDYN1.171
IF(LTIMER) THEN ATMDYN1.172
CALL TIMER('SET_FIL ',3) ATMDYN1.173
END IF ATMDYN1.174
CALL SET_FIL(D1(JU(1)),GRAV_WAVE_SPEED,ADJUSTMENT_TIMESTEP, ADR1F305.14
& DYN_TIMESTEP,SEC_P_LATITUDE, ARB0F400.10
& A_ROWDEPC(JFILTER_WAVE_NUMBER_P_ROWS), ATMDYN1.178
& A_ROWDEPC(JFILTER_WAVE_NUMBER_U_ROWS), ATMDYN1.179
& LONGITUDE_STEP_INVERSE,A_INTHD(19),A_INTHD(20), ATMDYN1.180
& P_FIELD,U_FIELD,P_LEVELS,ROW_LENGTH, ADR1F305.16
*CALL ARGFLDPT APB0F402.53
& FILTERING_SAFETY_FACTOR,TWO_D_GRID_CORRECTION) ATD1F400.27
ATMDYN1.184
IF(LTIMER) THEN ATMDYN1.185
CALL TIMER('SET_FIL ',4) ATMDYN1.186
END IF ATMDYN1.187
ATMDYN1.188
END IF ATMDYN1.189
ATMDYN1.190
*ENDIF ATMDYN1.191
ATMDYN1.192
*IF DEF,GLOBAL ATMDYN1.193
CL If this is the last assimilation step before the analysis dump ATMDYN1.194
CL is written then call FILT_FLD to field filter the moisture and ATMDYN1.195
CL potential temperature fields but not the cloud fields. ATMDYN1.196
CL The polar values of surface pressure, potential temperature, ATMDYN1.197
CL moisture and cloud fields are reset to the mean value of the ATMDYN1.198
CL surrounding row. ATMDYN1.199
IF( A_STEP.EQ.ASSIM_FIRSTSTEPim(a_im) + ASSIM_STEPSim(a_im) .AND. GDR5F305.9
& (MODEL_ASSIM_MODE.EQ."Atmosphere" .OR. ATMDYN1.201
& MODEL_ASSIM_MODE.EQ."Coupled ") .AND. ATMDYN1.202
& (RUN_ASSIM_MODE .EQ."Atmosphere" .OR. ATMDYN1.203
& RUN_ASSIM_MODE .EQ."Coupled ") .AND. ATMDYN1.204
& L_FIELD_FLT ) THEN ATMDYN1.205
CALL FILT_FLD(P_FIELD,P_LEVELS,Q_LEVELS,ROW_LENGTH, ATMDYN1.206
*CALL ARGFLDPT APB0F402.54
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)), ATMDYN1.207
& D1(JQCF(1)),IFAX,TRIGS, ATMDYN1.208
& A_ROWDEPC(JFILTER_WAVE_NUMBER_P_ROWS), ATMDYN1.209
& A_INTHD(19),A_INTHD(20),A_LEVDEPC(JAK), ATMDYN1.210
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), ATMDYN1.211
& A_LEVDEPC(JDELTA_BK),COS_P_LATITUDE, ATMDYN1.212
& RS_FUNCTIONS,LATITUDE_STEP_INVERSE,LLINTS) GSS1F304.1297
ADR1F403.7
*IF DEF,MPP ADR1F403.8
! Update the halos of fields filtered in FILT_FLD ADR1F403.9
CALL SWAPBOUNDS(D1(JPSTAR),ROW_LENGTH,P_ROWS, ADR1F403.10
& EW_Halo,NS_Halo,1) ADR1F403.11
CALL SWAPBOUNDS(D1(JTHETA(1)),ROW_LENGTH,P_ROWS, ADR1F403.12
& EW_Halo,NS_Halo,P_LEVELS) ADR1F403.13
CALL SWAPBOUNDS(D1(JQ(1)),ROW_LENGTH,P_ROWS, ADR1F403.14
& EW_Halo,NS_Halo,Q_LEVELS) ADR1F403.15
CALL SWAPBOUNDS(D1(JQCL(1)),ROW_LENGTH,P_ROWS, ADR1F403.16
& EW_Halo,NS_Halo,Q_LEVELS) ADR1F403.17
CALL SWAPBOUNDS(D1(JQCF(1)),ROW_LENGTH,P_ROWS, ADR1F403.18
& EW_Halo,NS_Halo,Q_LEVELS) ADR1F403.19
*ENDIF ADR1F403.20
ADR1F403.21
END IF ATMDYN1.214
*ENDIF ATMDYN1.215
APB0F401.40
FIRST_POINT=(FIRST_ROW-1)*ROW_LENGTH+1 APB0F401.41
LAST_POINT=P_LAST_ROW*ROW_LENGTH APB0F401.42
APB0F401.43
ATMDYN1.221
! if cloud water/ice diagnostics are required before dynamics ABM3F400.5
IF(I_LOOP.EQ.1 .AND. ( SF(229,10).OR.SF(230,10) ) ) THEN ABM3F400.6
! copy qcl/qcf to STASH diagnostic ABM3F400.34
CALL DIAG10_QC(D1(JQCL(1)),D1(JQCF(1)), ABM3F400.35
& ROW_LENGTH,P_LEVELS,Q_LEVELS,P_FIELD, ABM3F400.36
& NSECTS,NITEMS,TOTITEMS,NUM_STASH_LEVELS, ABM3F400.37
& NUM_LEVEL_LISTS,LEN_STLIST,STASHLEN,SF, ABM3F400.38
& STINDEX(1,1,0,im_index),STLIST, ABM3F400.39
& SI(1,0,im_index),STASH_LEVELS,STASHWORK, ABM3F400.40
& im_ident, GPB1F403.285
*CALL ARGFLDPT GPB1F403.286
*CALL ARGPPX GPB1F403.287
& ICODE,CMESSAGE) ABM3F400.41
ENDIF ABM3F400.42
DO I_COUNT=1,NSWEEPS AL131293.86
ARR2F405.9
! Find whether this is first or last sweep of the dynamics ARR2F405.10
IF(I_LOOP.EQ.1.AND.I_COUNT.EQ.1) THEN ARR2F405.11
FIRST_SWEEP=.true. ARR2F405.12
ELSE ARR2F405.13
FIRST_SWEEP=.false. ARR2F405.14
ENDIF ARR2F405.15
IF(I_LOOP.EQ.A_SWEEPS_DYN.AND.I_COUNT.EQ.NSWEEPS) THEN ARR2F405.16
LAST_SWEEP=.true. ARR2F405.17
ELSE ARR2F405.18
LAST_SWEEP=.false. ARR2F405.19
ENDIF ARR2F405.20
ARR2F405.21
! Diagnostic dumps on first sweep (default), otherwise last sweep ARR2F405.22
IF((FIRST_SWEEP.AND.WRITD1_FIRST_SWEEP).OR. ARR2F405.23
& (LAST_SWEEP.AND..NOT.WRITD1_FIRST_SWEEP)) THEN ARR2F405.24
WRITD1_THIS_SWEEP=.true. ARR2F405.25
ELSE ARR2F405.26
WRITD1_THIS_SWEEP=.false. ARR2F405.27
ENDIF ARR2F405.28
IF (I_COUNT.GT.1) THEN AL131293.87
C CONVERT THETAL AND QT TO THETA AND Q FOR SECOND SWEEP AL131293.88
C CONVERT THETA TO TEMPERATURE AL131293.89
DO K=1,Q_LEVELS AL131293.90
! loop over all points, including valid halos APB0F401.48
! Fujitsu vectorization directive GRB0F405.37
!OCL NOVREC GRB0F405.38
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.49
PU=D1(JPSTAR+I-1)*BKH(K+1)+AKH(K+1) AL131293.92
PL=D1(JPSTAR+I-1)*BKH(K)+AKH(K) AL131293.93
D1(JTHETA(K)+I-1)=D1(JTHETA(K)+I-1) * AL131293.94
& P_EXNER_C(D1(JP_EXNER(K+1)+I-1),D1(JP_EXNER(K)+I-1), AL131293.95
& PU,PL,KAPPA) AL131293.96
END DO AL131293.97
END DO AL131293.98
! CALL GLUE_CLD TO CONVERT TO TEMPERATURE AND Q AYY2F400.211
! Output LS_GRID_QC and LS_BS in WORK4 and WORK5 as CF not being updated AYY2F400.212
CALL GLUE_CLD(A_LEVDEPC(JAK),A_LEVDEPC(JBK),D1(JPSTAR), AYY2F400.213
& RHCRIT,Q_LEVELS,D1(JRHC(1)),P_FIELD,P_FIELD,D1(JTHETA(1)), ASK1F405.85
& WORK3,D1(JQ(1)),D1(JQCF(1)),D1(JQCL(1)),WORK4,WORK5,ERROR) AYY2F400.214
C CONVERT TEMPERATURE BACK TO THETA AL131293.103
DO K=1,Q_LEVELS AL131293.104
! loop over all points, including valid halos APB0F401.50
! Fujitsu vectorization directive GRB0F405.39
!OCL NOVREC GRB0F405.40
DO I=FIRST_VALID_PT,LAST_P_VALID_PT APB0F401.51
PU=D1(JPSTAR+I-1)*BKH(K+1)+AKH(K+1) AL131293.106
PL=D1(JPSTAR+I-1)*BKH(K)+AKH(K) AL131293.107
D1(JTHETA(K)+I-1)=D1(JTHETA(K)+I-1) / AL131293.108
& P_EXNER_C(D1(JP_EXNER(K+1)+I-1),D1(JP_EXNER(K)+I-1), AL131293.109
& PU,PL,KAPPA) AL131293.110
END DO AL131293.111
END DO AL131293.112
END IF AL131293.113
CL --------------------------------------------------------------------- ATMDYN1.222
CL Section 10 - adjustment ATMDYN1.223
CL call ADJ_CTL to perform adjustment steps ATMDYN1.224
CL --------------------------------------------------------------------- ATMDYN1.225
CL ATMDYN1.226
CL WORK1 holds V_MEAN ATMDYN1.227
CL ATMDYN1.228
ATMDYN1.229
CL copy THETA into WORK3 ATMDYN1.230
ATMDYN1.231
DO LEVEL=1,P_LEVELS ATMDYN1.232
K= (LEVEL-1)*P_FIELD ATMDYN1.233
DO I=1,P_FIELD ATMDYN1.234
WORK3(I+K) = D1(JTHETA(LEVEL)+I-1) ATMDYN1.235
END DO ATMDYN1.236
END DO ATMDYN1.237
ATMDYN1.238
IF(LTIMER) THEN ATMDYN1.239
CALL TIMER('ADJ_CTL ',3) ATMDYN1.240
CALL TIMER('ADJUSTMENT',5) GPB1F401.13
END IF ATMDYN1.241
ATMDYN1.242
C If geopotential required as diagnostic or required for calculating ATMDYN1.243
C another diagnostic then set logical to obtain field from ADJ_CTL. ATMDYN1.244
ATMDYN1.245
L_GEOP = .FALSE. ATMDYN1.246
IF(SF(206,10).OR.SF(219,10).OR.SF(220,10).OR.SF(221,10) ATMDYN1.247
& .OR.SF(222,10)) L_GEOP=.TRUE. ATMDYN1.248
ATMDYN1.249
CL 10.1 call ADJ_CTL to adjust model. ATMDYN1.250
CL ATMDYN1.251
IF (L_WRIT_DYN .AND. WRITD1_THIS_SWEEP .AND. ARR2F405.29
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1299
ATMDYN1.252
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1300
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1301
TJ270193.47
CALL DUMPCTL ( GKR4F403.103
*CALL ARGSIZE GKR4F403.104
*CALL ARGD1 GKR4F403.105
*CALL ARGDUMA GKR4F403.106
*CALL ARGDUMO GKR4F403.107
*CALL ARGDUMW GKR4F403.108
*CALL ARGCONA GKR4F403.109
*CALL ARGPTRA GKR4F403.110
*CALL ARGSTS GKR4F403.111
*CALL ARGPPX GKR4F403.112
& atmos_sm,0,.TRUE.,'bf_adj_ctl',a_step, GIE1F405.20
& ICODE,CMESSAGE) GKR4F403.114
GSS1F304.1303
END IF GSS1F304.1304
GSS1F304.1305
END IF GSS1F304.1306
GSS1F304.1307
CALL ADJ_CTL( ATMDYN1.253
& D1(JU(1)),D1(JV(1)),WORK3,D1(JQ(1)),D1(JPSTAR), AAD2F404.315
& D1(JOROG),RS_FUNCTIONS,U_MEAN, ATMDYN1.255
& WORK1,D1(JP_EXNER(1)),ETADOT, ATMDYN1.256
& PSTAR_OLD,COS_P_LATITUDE,COS_U_LATITUDE,SEC_P_LATITUDE, ATMDYN1.257
& SEC_U_LATITUDE,TAN_U_LATITUDE,F1,F2,F3, ATMDYN1.258
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ATMDYN1.259
& A_LEVDEPC(JAK),A_LEVDEPC(JBK), ATMDYN1.260
& A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK), ATMDYN1.261
& A_LEVDEPC(JTHETA_REF),LOCAL_ADJSTEP,A_ADJSTEPS, AL131293.114
& A_INTHD(19),A_INTHD(20), ATMDYN1.263
& ROW_LENGTH,P_LEVELS,Q_LEVELS, APB0F401.52
*CALL ARGFLDPT APB0F401.53
& P_FIELD,U_FIELD,AKH,BKH,AKH_TO_THE_KAPPA, ATMDYN1.265
& BKH_TO_THE_KAPPA,AK_TO_THE_KAPPA,BK_TO_THE_KAPPA, ATMDYN1.266
& COS_LONGITUDE,SIN_LONGITUDE, ATMDYN1.267
& TRIGS,IFAX,A_ROWDEPC(JFILTER_WAVE_NUMBER_P_ROWS), ATMDYN1.268
& A_ROWDEPC(JFILTER_WAVE_NUMBER_U_ROWS),ICODE,CMESSAGE, ATMDYN1.269
& L_NEG_PSTAR,STASHWORK(SI(206,10,im_index)),L_GEOP, GRB4F305.6
& ADJ_TIME_SMOOTHING_WEIGHT,ADJ_TIME_SMOOTHING_COEFF, GSS1F304.1308
& LLINTS,LWHITBROM) GSS1F304.1309
ATMDYN1.272
IF (L_WRIT_DYN .AND. WRITD1_THIS_SWEEP .AND. ARR2F405.30
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1311
TJ270193.51
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1312
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1313
GSS1F304.1314
CALL DUMPCTL ( GKR4F403.115
*CALL ARGSIZE GKR4F403.116
*CALL ARGD1 GKR4F403.117
*CALL ARGDUMA GKR4F403.118
*CALL ARGDUMO GKR4F403.119
*CALL ARGDUMW GKR4F403.120
*CALL ARGCONA GKR4F403.121
*CALL ARGPTRA GKR4F403.122
*CALL ARGSTS GKR4F403.123
*CALL ARGPPX GKR4F403.124
& atmos_sm,0,.TRUE.,'af_adj_ctl',a_step, GIE1F405.1
& ICODE,CMESSAGE) GKR4F403.126
GSS1F304.1316
END IF GSS1F304.1317
GSS1F304.1318
END IF GSS1F304.1319
GSS1F304.1320
IF(LTIMER) THEN ATMDYN1.273
CALL TIMER('ADJ_CTL ',4) ATMDYN1.274
CALL TIMER('ADJUSTMENT',6) GPB1F401.14
END IF ATMDYN1.275
ATMDYN1.276
IF(ICODE.GT.0) RETURN ATMDYN1.277
ATMDYN1.278
! Call DIAG10_A only on last sweep of long physics timestep ARB0F400.11
! and of half-timestep dynamics. ARB0F400.12
IF (I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS) THEN ARB0F400.13
IF(LTIMER) THEN ATMDYN1.289
CALL TIMER('DIAG10_A',3) ATMDYN1.290
END IF ATMDYN1.291
ATMDYN1.292
CL calculate amount of work-space required by DIAG10_A. ATMDYN1.293
IF(SF(207,10).OR.SF(208,10).OR.SF(209,10).OR.SF(210,10)) THEN ATMDYN1.294
WORK_LENGTH = P_FIELD*P_LEVELS ATMDYN1.295
ELSE ATMDYN1.296
WORK_LENGTH = 1 ATMDYN1.297
END IF ATMDYN1.298
ATMDYN1.299
CL call DIAG10_A to obtain diagnostics before call to THETL_QT. ATMDYN1.300
! N.B. PSTAR_OLD saved in 1st call to P_TH_ADJ from ADJ_CTL above, ARB0F400.14
! so timestep for pstar tendency should be local advection step. ARB0F400.15
ATMDYN1.301
CALL DIAG10_A( ATMDYN1.302
& D1(JPSTAR),PSTAR_OLD,U_MEAN,WORK1,D1(JQ(1)),ETADOT, ATMDYN1.303
& D1(JTHETA(1)),D1(JP_EXNER(1)),RS_FUNCTIONS, ATMDYN1.304
& SEC_U_LATITUDE,ROW_LENGTH,P_LEVELS,Q_LEVELS,P_FIELD, ATMDYN1.305
& U_FIELD,A_LEVDEPC(JAK),A_LEVDEPC(JBK),AKH,BKH, ATMDYN1.306
& LOCAL_ADVSTEP,FIRST_POINT,LAST_POINT, ARB0F400.16
& NSECTS,NITEMS,TOTITEMS,NUM_STASH_LEVELS, ATMDYN1.308
& NUM_LEVEL_LISTS,LEN_STLIST,STASHLEN,SF, ATMDYN1.309
& STINDEX(1,1,0,im_index),STLIST, GRB4F305.7
& SI(1,0,im_index),STASH_LEVELS,STASHWORK, GRB4F305.8
& WORK3,WORK_LENGTH, GPB1F403.288
& im_ident, GPB1F403.289
*CALL ARGFLDPT GPB1F403.290
*CALL ARGPPX GPB1F403.291
& ICODE,CMESSAGE) GPB1F403.292
ATMDYN1.312
IF(LTIMER) THEN ATMDYN1.313
CALL TIMER('DIAG10_A',4) ATMDYN1.314
END IF ATMDYN1.315
ATMDYN1.316
END IF ! I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS ARB0F400.17
ATMDYN1.317
CL 10.2 call THETL_QT to convert THETA and Q to THETAL and QT ATMDYN1.318
CL ATMDYN1.319
ATMDYN1.320
IF(LTIMER) THEN ATMDYN1.321
CALL TIMER('THETL_QT',3) ATMDYN1.322
END IF ATMDYN1.323
ATMDYN1.324
! If using mixed phase precip scheme then do not want ice in the call ADM2F404.57
! to THETL_QT. ADM2F404.58
IF (L_LSPICE) THEN ADM2F404.59
! Mixed phase precip scheme. Define an array of zeros instead ADM2F404.60
! of using QCF. ADM2F404.61
DO K=1,Q_LEVELS ADM2F404.62
DO I=1,P_FIELD ADM2F404.63
ZERO_FIELD(I,K)=0.0 ADM2F404.64
END DO ADM2F404.65
END DO ADM2F404.66
! Now call THETL_QT with the zero field ADM2F404.67
CALL THETL_QT( ADM2F404.68
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),ZERO_FIELD, ADM2F404.69
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) ADM2F404.70
! Else the call to THETL_QT does contain the QCF field ADM2F404.71
ELSE ADM2F404.72
CALL THETL_QT( ATMDYN1.325
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),D1(JQCF(1)), ATMDYN1.326
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) ATMDYN1.327
! END IF for L_LSPICE ADM2F404.73
END IF ADM2F404.74
ATMDYN1.328
IF(LTIMER) THEN ATMDYN1.329
CALL TIMER('THETL_QT',4) ATMDYN1.330
END IF ATMDYN1.331
ATMDYN1.332
! Call DIAG10_B only on last sweep of long physics timestep ARB0F400.18
! and of half-timestep dynamics. ARB0F400.19
IF (I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS) THEN ARB0F400.20
ATMDYN1.333
CL Check to see if any diagnostic calculated by DIAG10_B requested. ATMDYN1.334
IF(SF(211,10).OR.SF(212,10).OR.SF(213,10).OR.SF(214,10).OR. ATMDYN1.335
& SF(215,10).OR.SF(216,10).OR.SF(217,10).OR.SF(218,10).OR. ATMDYN1.336
& SF(219,10).OR.SF(220,10).OR.SF(221,10).OR.SF(222,10)) THEN ATMDYN1.337
ATMDYN1.338
IF(LTIMER) THEN ATMDYN1.339
CALL TIMER('DIAG10_B',3) ATMDYN1.340
END IF ATMDYN1.341
ATMDYN1.342
CL call DIAG10_B to obtain diagnostics after call to THETL_QT. ATMDYN1.343
ATMDYN1.344
CALL DIAG10_B( ATMDYN1.345
& U_MEAN,WORK1,D1(JQ(1)),D1(JTHETA(1)), ATMDYN1.346
& D1(JP_EXNER(1)),D1(JPSTAR),D1(JU(1)),D1(JV(1)), ATMDYN1.347
& SEC_U_LATITUDE,AKH,BKH,ROW_LENGTH,P_LEVELS, ATMDYN1.348
& Q_LEVELS,P_FIELD,U_FIELD,FIRST_POINT,LAST_POINT, ATMDYN1.349
& NSECTS,NITEMS,TOTITEMS,NUM_STASH_LEVELS, ATMDYN1.350
& NUM_LEVEL_LISTS,LEN_STLIST,STASHLEN,SF, ATMDYN1.351
& STINDEX(1,1,0,im_index),STLIST, GRB4F305.9
& SI(1,0,im_index),STASH_LEVELS,STASHWORK, GRB4F305.10
& WORK3, GPB1F403.293
& im_ident, GPB1F403.294
*CALL ARGFLDPT GPB1F403.295
*CALL ARGPPX GPB1F403.296
& ICODE,CMESSAGE) GPB1F403.297
ATMDYN1.354
IF(LTIMER) THEN ATMDYN1.355
CALL TIMER('DIAG10_B',4) ATMDYN1.356
END IF ATMDYN1.357
ATMDYN1.358
END IF ! SFs ARB0F400.21
ATMDYN1.360
! Calculate angular momentum diagnostics if required on last sweep only ARS1F400.4
ARS1F400.5
IF (I_COUNT.EQ.NSWEEPS) THEN ARS1F400.6
IF(SF(223,10).OR.SF(224,10).OR.SF(225,10).OR. ARS1F400.7
& SF(226,10).OR.SF(227,10).OR.SF(228,10)) THEN ARS1F400.8
CALL ATMOS_ANG_MOM(P_FIELD,U_FIELD,P_ROWS,ROW_LENGTH,P_LEVELS, ARS1F400.9
*CALL ARGFLDPT GPB1F404.154
& A_REALHD(1),A_REALHD(2),A_REALHD(3),A_REALHD(4), ARS1F400.10
& D1(JPSTAR),D1(JU(1)),D1(JV(1)),RS_FUNCTIONS, ARS1F400.11
& COS_U_LATITUDE, ARS1F400.12
& A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK), ARS1F400.13
& SF(223,10),SF(224,10),SF(225,10), ARS1F400.14
& SF(226,10),SF(227,10),SF(228,10), ARS1F400.15
& STASHWORK(SI(223,10,im_index)),STASHWORK(SI(224,10,im_index)), ARS1F400.16
& STASHWORK(SI(225,10,im_index)),STASHWORK(SI(226,10,im_index)), ARS1F400.17
& STASHWORK(SI(227,10,im_index)),STASHWORK(SI(228,10,im_index))) ARS1F400.18
ENDIF ARS1F400.19
ENDIF ARS1F400.20
ARS1F400.21
ARS1F400.22
IF(LTIMER) THEN ATMDYN1.361
CALL TIMER('STASH ',3) ATMDYN1.362
END IF ATMDYN1.363
ATMDYN1.364
CALL STASH(a_sm,a_im,10,STASHWORK, GKR0F305.880
*CALL ARGSIZE @DYALLOC.285
*CALL ARGD1 @DYALLOC.286
*CALL ARGDUMA @DYALLOC.287
*CALL ARGDUMO @DYALLOC.288
*CALL ARGDUMW GKR1F401.168
*CALL ARGSTS @DYALLOC.289
*CALL ARGPPX GKR0F305.881
& ICODE,CMESSAGE) @DYALLOC.293
ATMDYN1.366
IF(LTIMER) THEN ATMDYN1.367
CALL TIMER('STASH ',4) ATMDYN1.368
END IF ATMDYN1.369
ATMDYN1.370
IF(ICODE.GT.0) THEN ATMDYN1.371
RETURN ATMDYN1.372
END IF ATMDYN1.373
ATMDYN1.374
END IF ! I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS ARB0F400.22
ATMDYN1.375
CL --------------------------------------------------------------------- ATMDYN1.376
CL Section 11 Tracer Advection ATMDYN1.377
CL --------------------------------------------------------------------- ATMDYN1.378
CL WORK1 holds V_MEAN. ATMDYN1.379
CL ATMDYN1.380
CL 11.1 horizontal advection of tracers. mass weighted values are output ATMDYN1.381
ATMDYN1.382
C Enable calculation of number of tracer sweeps. ATD1F400.28
IF(L_TRACER_THETAL_QT .OR. TR_VARS.NE.0 .OR. L_MURK AWO2F401.5
& .OR. L_SOOT AWO2F405.74
!------- Code for soot variables ----------- AWO2F405.75
! AWO2F405.76
& .OR. L_SULPC_SO2 .OR. L_LSPICE .OR. L_CO2_INTERACTIVE) THEN ACN2F405.137
GRB1F400.2
IF(LTIMER) THEN GSM1F401.1
CALL TIMER('TRAC_ADV',3) GRB1F400.3
END IF GSM1F401.2
ATMDYN1.384
CL Call SET_TRAC to calculate number of horizontal sweeps required at ATMDYN1.385
CL each level. ATMDYN1.386
ATMDYN1.387
CALL SET_TRAC(TRACER_EW_SWEEPS,U_MEAN,P_FIELD,U_FIELD, ATMDYN1.388
& P_LEVELS,ROW_LENGTH, ARB1F402.79
*CALL ARGFLDPT ARB1F402.80
& LONGITUDE_STEP_INVERSE,SEC_P_LATITUDE, ARB1F402.81
& LOCAL_ADVSTEP,PSTAR_OLD,A_LEVDEPC(JDELTA_AK), ARB1F402.82
& A_LEVDEPC(JDELTA_BK),RS_FUNCTIONS) ARB1F402.83
ATMDYN1.393
! Print number of EW tracer advection sweeps required, under same ARB1F403.70
! control variables as for max/min print diagnostics. ARB1F403.71
IF(LPRVXN) THEN ARB1F403.72
IF(MOD(A_STEP-PRVXN_FIRST,PRVXN_STEP).EQ.0 .AND. ARB1F403.73
& A_STEP.GE.PRVXN_FIRST .AND. ARB1F403.74
& (PRVXN_LAST.LE.0 .OR. A_STEP.LE.PRVXN_LAST)) THEN ARB1F403.75
do k = 1,p_levels ARB1F403.76
write(6,*)' ATMDYN; level, tracer_ew_sweeps ',k, ARB1F403.77
*IF DEF,MPP ARB1F403.78
& (tracer_ew_sweeps(i,k),i=1,glsize(2)) ARB1F403.79
*ELSE ARB1F403.80
& (tracer_ew_sweeps(i,k),i=1,p_rows) ARB1F403.81
*ENDIF ARB1F403.82
end do ARB1F403.83
END IF ARB1F403.84
END IF ARB1F403.85
ARB1F403.86
*IF DEF,MPP ARB1F402.84
FIRST_POINT = START_POINT_NO_HALO ARB1F402.85
POINTS = upd_P_ROWS * ROW_LENGTH ARB1F402.86
*IF DEF,GLOBAL APB0F401.1796
! If processor includes North or South polar row, compute a pt. on it ARB1F402.87
IF (at_top_of_LPG) THEN ARB1F402.88
FIRST_POINT = FIRST_POINT -Offx -1 ARB1F402.89
POINTS = POINTS +Offx +1 ARB1F402.90
END IF ARB1F402.91
IF (at_base_of_LPG) THEN ARB1F402.92
POINTS = POINTS +Offx +1 ARB1F402.93
END IF ARB1F402.94
*ENDIF ARB1F402.95
*ELSE ARB1F402.96
*IF DEF,GLOBAL ARB1F402.97
POINTS=upd_P_ROWS*ROW_LENGTH+2 APB0F401.1797
FIRST_POINT=ROW_LENGTH APB0F401.1798
*ELSE APB0F401.1799
POINTS=upd_P_ROWS*ROW_LENGTH APB0F401.1800
FIRST_POINT=ROW_LENGTH+1 APB0F401.1801
*ENDIF APB0F401.1802
*ENDIF ARB1F402.98
ATMDYN1.396
START_LEVEL=1+P_LEVELS-TR_LEVELS ATMDYN1.397
END_LEVEL=START_LEVEL+TRAC_ADV_LEVELS-1 ADR1F305.20
ATMDYN1.399
IF (TR_VARS.NE.0) THEN APC1F304.5
DO VAR=1,TR_VARS ATMDYN1.400
ATMDYN1.401
*IF DEF,MPP GPB7F405.3
GPB7F405.4
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.5
CALL SWAPBOUNDS(D1(JTRACER(START_LEVEL,VAR)),ROW_LENGTH,P_ROWS, GPB7F405.6
& EW_Halo,NS_Halo,TRAC_ADV_LEVELS) GPB7F405.7
GPB7F405.8
*ENDIF GPB7F405.9
GPB7F405.10
DO K=START_LEVEL,END_LEVEL ATMDYN1.402
ATMDYN1.403
CALL TRAC_ADV(D1(JTRACER(K,VAR)),TRACER_EW_SWEEPS(1,K), ATMDYN1.404
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, ATMDYN1.405
& LOCAL_ADVSTEP,ROW_LENGTH, ARB1F402.99
*CALL ARGFLDPT ARB1F402.100
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), ATMDYN1.407
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), ATMDYN1.408
& A_LEVDEPC(JDELTA_BK+K-1), ATMDYN1.409
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ATMDYN1.410
& L_SUPERBEE) ATMDYN1.411
ATMDYN1.412
END DO ATMDYN1.413
ATMDYN1.414
*IF DEF,MPP GPB7F405.11
GPB7F405.12
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.13
CALL SWAPBOUNDS(D1(JTRACER(START_LEVEL,VAR)),ROW_LENGTH,P_ROWS, GPB7F405.14
& EW_Halo,NS_Halo,TRAC_ADV_LEVELS) GPB7F405.15
GPB7F405.16
*ENDIF GPB7F405.17
GPB7F405.18
ATMDYN1.418
! For vertical advection of tracers call TRAC_VERT_ADV with ATD1F400.30
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. ATD1F400.31
CALL TRAC_VERT_ADV(D1(JTRACER(1,VAR)),ETADOT,D1(JPSTAR), ATMDYN1.419
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, AL131293.123
& FIRST_POINT,POINTS,P_LEVELS, ATMDYN1.421
& P_LEVELS+1-TR_LEVELS, ATMDYN1.422
& P_LEVELS,RS_FUNCTIONS,A_LEVDEPC(JAK), ATMDYN1.423
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), ATMDYN1.424
& A_LEVDEPC(JDELTA_BK),WORK2, ATD1F400.32
& .FALSE.,L_SUPERBEE) ATD1F400.33
ATMDYN1.426
*IF DEF,GLOBAL APB0F401.1803
C Copy the one polar value updated by TRAC_VERT_ADV to the other APB0F401.1804
C polar locations. APB0F401.1805
DO K= START_LEVEL,END_LEVEL APB0F401.1806
*IF DEF,MPP ARB1F402.101
IF (at_top_of_LPG) THEN ARB1F402.102
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ARB1F402.103
D1(JTRACER(K,VAR)+I) = ARB1F402.104
& D1(JTRACER(K,VAR)+START_POINT_NO_HALO-Offx-2) ARB1F402.105
END DO ARB1F402.106
END IF ARB1F402.107
IF (at_base_of_LPG) THEN ARB1F402.108
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ARB1F402.109
D1(JTRACER(K,VAR)+I) = ARB1F402.110
& D1(JTRACER(K,VAR)+END_P_POINT_NO_HALO+Offx) ARB1F402.111
END DO ARB1F402.112
END IF ARB1F402.113
*ELSE ARB1F402.114
DO I = 0, ROW_LENGTH - 2 APB0F401.1807
D1(JTRACER(K,VAR)+I) = D1(JTRACER(K,VAR)+ROW_LENGTH-1) APB0F401.1808
D1(JTRACER(K,VAR)+P_FIELD-1-I) = APB0F401.1809
& D1(JTRACER(K,VAR)+P_FIELD-ROW_LENGTH) APB0F401.1810
END DO APB0F401.1811
*ENDIF ARB1F402.115
END DO APB0F401.1812
*ENDIF APB0F401.1813
*IF DEF,MPP ARB1F402.116
ARB1F402.117
! Call swapbounds to update halo points for tracer advection levels. ARB1F402.118
CALL SWAPBOUNDS(D1(JTRACER(START_LEVEL,VAR)),ROW_LENGTH,P_ROWS, ARB1F402.119
& EW_Halo,NS_Halo,TRAC_ADV_LEVELS) ARB1F402.120
ARB1F402.121
*ENDIF ARB1F402.122
END DO ATMDYN1.427
ENDIF APC1F304.6
APC1F304.7
C Advect Aerosol if required. APC1F304.8
IF (L_MURK) THEN APC1F304.9
START_LEVEL=1 APC1F304.10
END_LEVEL=A_INTHD(13) ! Boundary layer levels APC0F405.764
CL If required, add source increment to aerosol field. APC1F304.12
IF (L_MURK_SOURCE) THEN APC1F304.13
DO K=START_LEVEL,END_LEVEL APC1F304.14
CALL TRSRCE( APC1F304.15
& A_LEVDEPC(JDELTA_AK+K-1), APC1F304.16
& A_LEVDEPC(JDELTA_BK+K-1), APC1F304.17
& P_FIELD, APC1F304.18
& P_FIELD, APC1F304.19
& D1(JPSTAR), APC1F304.20
& D1(JMURK(K)), APC1F304.21
& D1(JMURK_SOURCE(K)), APC1F304.22
& LOCAL_ADVSTEP, APC1F304.23
& I_HOUR, APC3F400.3
& I_MINUTE, APC3F400.4
& 0.1, ! AMPlitude of diurnal variation of emissions AWO2F401.7
& ICODE APC1F304.24
& ) APC1F304.25
IF (ICODE.GT.0) THEN APC1F304.26
CMESSAGE='Error in TRSRCE' APC1F304.27
RETURN APC1F304.28
ENDIF APC1F304.29
END DO APC1F304.30
END IF APC1F304.31
C Now advect the aerosol APC1F304.32
IF (L_MURK_ADVECT) THEN APC1F304.33
GPB7F405.19
*IF DEF,MPP GPB7F405.20
GPB7F405.21
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.22
K = END_LEVEL-START_LEVEL+1 GPB7F405.23
CALL SWAPBOUNDS(D1(JMURK(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.24
& EW_Halo,NS_Halo,K) GPB7F405.25
GPB7F405.26
*ENDIF GPB7F405.27
GPB7F405.28
DO K=START_LEVEL,END_LEVEL APC1F304.34
APC1F304.35
CALL TRAC_ADV(D1(JMURK(K)),TRACER_EW_SWEEPS(1,K), APC1F304.36
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, APC1F304.37
& LOCAL_ADVSTEP,ROW_LENGTH, ARB1F402.123
*CALL ARGFLDPT ARB1F402.124
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), APC1F304.39
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), APC1F304.40
& A_LEVDEPC(JDELTA_BK+K-1), APC1F304.41
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, APC1F304.42
& L_SUPERBEE) APC1F304.43
APC1F304.44
END DO APC1F304.45
APC1F304.46
*IF DEF,MPP GPB7F405.29
GPB7F405.30
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.31
K = END_LEVEL-START_LEVEL+1 GPB7F405.32
CALL SWAPBOUNDS(D1(JMURK(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.33
& EW_Halo,NS_Halo,K) GPB7F405.34
GPB7F405.35
*ENDIF GPB7F405.36
GPB7F405.37
APC1F304.50
! For vertical advection of aerosol call TRAC_VERT_ADV with ATD1F400.34
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. ATD1F400.35
CALL TRAC_VERT_ADV(D1(JMURK(1)),ETADOT,D1(JPSTAR), APC1F304.51
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, APC1F304.52
& FIRST_POINT,POINTS,P_LEVELS, APC1F304.53
& START_LEVEL,END_LEVEL, APC1F304.54
& RS_FUNCTIONS,A_LEVDEPC(JAK), APC1F304.55
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), APC1F304.56
& A_LEVDEPC(JDELTA_BK),WORK2, ATD1F400.36
& .FALSE.,L_SUPERBEE) ATD1F400.37
END IF APC1F304.58
APC1F304.59
*IF DEF,GLOBAL APB0F401.1814
C Copy the one polar value updated by TRAC_VERT_ADV to the other APB0F401.1815
C polar locations. APB0F401.1816
DO K= START_LEVEL,END_LEVEL APB0F401.1817
*IF DEF,MPP ARB1F402.125
IF (at_top_of_LPG) THEN ARB1F402.126
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ARB1F402.127
D1(JMURK(K)+I) = D1(JMURK(K)+START_POINT_NO_HALO-Offx-2) ARB1F402.128
END DO ARB1F402.129
END IF ARB1F402.130
IF (at_base_of_LPG) THEN ARB1F402.131
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ARB1F402.132
D1(JMURK(K)+I) = D1(JMURK(K)+END_P_POINT_NO_HALO+Offx) ARB1F402.133
END DO ARB1F402.134
END IF ARB1F402.135
*ELSE ARB1F402.136
DO I = 0, ROW_LENGTH - 2 APB0F401.1818
D1(JMURK(K)+I) = D1(JMURK(K)+ROW_LENGTH-1) APB0F401.1819
D1(JMURK(K)+P_FIELD-1-I) = D1(JMURK(K)+P_FIELD-ROW_LENGTH) APB0F401.1820
END DO APB0F401.1821
*ENDIF ARB1F402.137
END DO APB0F401.1822
*ENDIF APB0F401.1823
C APC1F304.60
C Add boundary terms for aerosol. APC1F304.61
C APC1F304.62
IF( L_MURK_BDRY) THEN APC1F304.63
DO K=START_LEVEL,END_LEVEL APC1F304.64
CALL TRBDRY( APC1F304.65
& A_LEVDEPC(JAK+K-1), APC1F304.66
& A_LEVDEPC(JBK+K-1), APC1F304.67
& P_FIELD, APC1F304.70
& P_FIELD, APC1F304.71
& U_FIELD, APC1F304.72
& ROW_LENGTH, ARB1F402.138
*CALL ARGFLDPT ARB1F402.139
& D1(JPSTAR), APC1F304.74
& D1(JU(K)),D1(JV(K)), APC1F304.75
& D1(JMURK(K)), APC1F304.76
& LOCAL_ADVSTEP, APC1F304.77
& ICODE APC1F304.78
& ) APC1F304.79
IF (ICODE.GT.0) THEN APC1F304.80
CMESSAGE='Error in TRBDRY' APC1F304.81
RETURN APC1F304.82
ENDIF APC1F304.83
END DO APC1F304.84
END IF APC1F304.85
*IF DEF,MPP ARB1F402.140
ARB1F402.141
! Call swapbounds to update halo points for tracer advection levels. ARB1F402.142
K = END_LEVEL-START_LEVEL+1 ARB1F403.87
CALL SWAPBOUNDS(D1(JMURK(START_LEVEL)),ROW_LENGTH,P_ROWS, ARB1F402.143
& EW_Halo,NS_Halo,K) ARB1F403.88
ARB1F402.145
*ENDIF ARB1F402.146
END IF ! End of aerosol code APC1F304.86
! -------------------------------------------------------------------- ADM2F404.146
! Code to advect ICE_VAR ADM2F404.147
! -------------------------------------------------------------------- ADM2F404.148
IF (L_LSPICE) THEN ADM2F404.149
! Start of 3A precipitation scheme ice tracer advection ADM2F404.150
! ADM2F404.151
*IF DEF,MPP GPB7F405.38
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.39
K = Q_LEVELS GPB7F405.40
CALL SWAPBOUNDS(D1(JQCF(1)),ROW_LENGTH,P_ROWS, GPB7F405.41
& EW_Halo,NS_Halo,K) GPB7F405.42
*ENDIF GPB7F405.43
! GPB7F405.44
! GPB7F405.45
DO K=1, Q_LEVELS ADM2F404.152
! ADM2F404.153
CALL TRAC_ADV(D1(JQCF(K)),TRACER_EW_SWEEPS(1,K), ADM2F404.154
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, ADM2F404.155
& LOCAL_ADVSTEP,ROW_LENGTH, ADM2F404.156
*CALL ARGFLDPT ADM2F404.157
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), ADM2F404.158
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), ADM2F404.159
& A_LEVDEPC(JDELTA_BK+K-1), ADM2F404.160
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ADM2F404.161
& L_SUPERBEE) ADM2F404.162
! ADM2F404.163
END DO ADM2F404.164
*IF DEF,MPP GPB7F405.46
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.47
K = Q_LEVELS GPB7F405.48
CALL SWAPBOUNDS(D1(JQCF(1)),ROW_LENGTH,P_ROWS, GPB7F405.49
& EW_Halo,NS_Halo,K) GPB7F405.50
*ENDIF GPB7F405.51
! GPB7F405.52
! GPB7F405.53
! ADM2F404.165
! Set ice flux through lower boundary to zero ADM2F404.166
GPB7F405.54
! ADM2F404.170
! ADM2F404.171
CALL TRAC_VERT_ADV(D1(JQCF(1)),ETADOT,D1(JPSTAR), ADM2F404.172
& P_FIELD,LOCAL_ADVSTEP,1,Q_LEVELS, ADM2F404.173
& FIRST_POINT,POINTS,P_LEVELS, ADM2F404.174
& 1, ADM2F404.175
& Q_LEVELS,RS_FUNCTIONS,A_LEVDEPC(JAK), ADM2F404.176
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), ADM2F404.177
& A_LEVDEPC(JDELTA_BK),WORK2, ADM2F404.178
& .FALSE.,L_SUPERBEE) ADM2F404.179
ADM2F404.180
*IF DEF,GLOBAL ADM2F404.181
! Copy polar values along row ADM2F404.182
DO K=1,Q_LEVELS ADM2F404.183
*IF DEF,MPP ADM2F404.184
IF (at_top_of_LPG) THEN ADM2F404.185
DO I=FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ADM2F404.186
D1(JQCF(K)+I)=D1(JQCF(K)+START_POINT_NO_HALO-Offx-2) ADM2F404.187
END DO ADM2F404.188
END IF ADM2F404.189
IF (at_base_of_LPG) THEN ADM2F404.190
DO I=END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ADM2F404.191
D1(JQCF(K)+I)=D1(JQCF(K)+END_P_POINT_NO_HALO+Offx) ADM2F404.192
END DO ADM2F404.193
END IF ADM2F404.194
*ELSE ADM2F404.195
DO I=1,ROW_LENGTH-1 ADM2F404.196
D1(JQCF(K)+I-1) = D1(JQCF(K)+ROW_LENGTH-1) ADM2F404.197
D1(JQCF(K)+P_FIELD-I) = D1(JQCF(K)+P_FIELD-ROW_LENGTH) ADM2F404.198
END DO ADM2F404.199
*ENDIF ADM2F404.200
END DO ADM2F404.201
*ENDIF ADM2F404.202
*IF DEF,MPP ADM2F404.203
! Call swapbounds to update halo points for tracer advection levels. ADM2F404.204
K = Q_LEVELS ADM2F404.205
CALL SWAPBOUNDS(D1(JQCF(1)),ROW_LENGTH,P_ROWS, ADM2F404.206
& EW_Halo,NS_Halo,K) ADM2F404.207
*ENDIF ADM2F404.208
! ADM2F404.209
! ADM2F404.210
POINTS=upd_P_ROWS*ROW_LENGTH+2 ADM2F404.226
! End of 3A precipitation scheme ice tracer advection ADM2F404.227
END IF ADM2F404.228
! AWO2F401.8
!-- ---- Code for Sulphur Cycle tracers ------ AWO2F401.9
! AWO2F401.10
IF (L_SULPC_SO2) THEN AWO2F401.11
START_LEVEL=1 AWO2F401.12
END_LEVEL=P_LEVELS AWO2F401.13
AWO2F401.14
! If required, add 3_D Natural SO2 emissions AWO2F401.15
! AWO2F401.16
IF (L_SO2_NATEM) THEN AWO2F401.17
! AWO2F401.18
DO K=START_LEVEL,END_LEVEL AWO2F401.19
CALL TRSRCE( AWO2F401.20
& A_LEVDEPC(JDELTA_AK+K-1), AWO2F401.21
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F401.22
& P_FIELD, AWO2F401.23
& P_FIELD, AWO2F401.24
& D1(JPSTAR), AWO2F401.25
& D1(JSO2(K)), AWO2F401.26
& D1(JSO2_NATEM(K)), AWO2F401.27
& LOCAL_ADVSTEP, AWO2F401.28
& I_HOUR, AWO2F401.29
& I_MINUTE, AWO2F401.30
& 0.0, ! AMPlitude of diurnal variation of emissions AWO2F401.31
& ICODE AWO2F401.32
& ) AWO2F401.33
! AWO2F401.34
IF (ICODE.GT.0) THEN AWO2F401.35
CMESSAGE='Error in TRSRCE' AWO2F401.36
RETURN AWO2F401.37
ENDIF AWO2F401.38
END DO AWO2F401.39
! AWO2F401.40
END IF ! END L_SO2_NATEM condition AWO2F401.41
! AWO2F401.42
! Now advect the Sulphur Cycle tracers AWO2F401.43
! AWO2F401.44
*IF DEF,MPP GPB7F405.55
GPB7F405.56
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.57
K = END_LEVEL-START_LEVEL+1 GPB7F405.58
CALL SWAPBOUNDS(D1(JSO2(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.59
& EW_Halo,NS_Halo,K) GPB7F405.60
GPB7F405.61
*ENDIF GPB7F405.62
DO K=START_LEVEL,END_LEVEL ! for SO2 AWO2F401.45
CALL TRAC_ADV(D1(JSO2(K)),TRACER_EW_SWEEPS(1,K), AWO2F401.46
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F401.47
& LOCAL_ADVSTEP,ROW_LENGTH, ARB1F402.147
*CALL ARGFLDPT ARB1F402.148
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), AWO2F401.49
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F401.50
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F401.51
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F401.52
& L_SUPERBEE) AWO2F401.53
END DO AWO2F401.54
*IF DEF,MPP GPB7F405.63
GPB7F405.64
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.65
K = END_LEVEL-START_LEVEL+1 GPB7F405.66
CALL SWAPBOUNDS(D1(JSO2(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.67
& EW_Halo,NS_Halo,K) GPB7F405.68
GPB7F405.69
*ENDIF GPB7F405.70
! AWO2F401.55
GPB7F405.71
AWO2F401.59
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F401.60
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F401.61
CALL TRAC_VERT_ADV(D1(JSO2(1)),ETADOT,D1(JPSTAR), AWO2F401.62
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, AWO2F401.63
& FIRST_POINT,POINTS,P_LEVELS, AWO2F401.64
& START_LEVEL,END_LEVEL, AWO2F401.65
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F401.66
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F401.67
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F401.68
& .FALSE.,L_SUPERBEE) AWO2F401.69
! AWO2F401.70
*IF DEF,GLOBAL AWO2F401.71
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F401.72
C polar locations. AWO2F401.73
DO K= START_LEVEL,END_LEVEL AWO2F401.74
*IF DEF,MPP ARB1F402.149
IF (at_top_of_LPG) THEN ARB1F402.150
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ARB1F402.151
D1(JSO2(K)+I) = D1(JSO2(K)+START_POINT_NO_HALO-Offx-2) ARB1F402.152
END DO ARB1F402.153
END IF ARB1F402.154
IF (at_base_of_LPG) THEN ARB1F402.155
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ARB1F402.156
D1(JSO2(K)+I) = D1(JSO2(K)+END_P_POINT_NO_HALO+Offx) ARB1F402.157
END DO ARB1F402.158
END IF ARB1F402.159
*ELSE ARB1F402.160
DO I = 0, ROW_LENGTH - 2 AWO2F401.75
D1(JSO2(K)+I) = D1(JSO2(K)+ROW_LENGTH-1) AWO2F401.76
D1(JSO2(K)+P_FIELD-1-I) = AWO2F401.77
& D1(JSO2(K)+P_FIELD-ROW_LENGTH) AWO2F401.78
END DO AWO2F401.79
*ENDIF ARB1F402.161
END DO AWO2F401.80
*ENDIF AWO2F401.81
*IF DEF,MPP ARB1F402.162
ARB1F402.163
! Call swapbounds to update halo points for tracer advection levels. ARB1F402.164
K = END_LEVEL-START_LEVEL+1 ARB1F403.89
CALL SWAPBOUNDS(D1(JSO2(START_LEVEL)),ROW_LENGTH,P_ROWS, ARB1F402.165
& EW_Halo,NS_Halo,K) ARB1F403.90
ARB1F402.167
*ENDIF ARB1F402.168
! AWO2F401.82
! Advect NH3 if present AWO2F405.5
IF (L_SULPC_NH3) THEN AWO2F405.6
*IF DEF,MPP AWO2F405.7
K=END_LEVEL-START_LEVEL+1 AWO2F405.8
CALL SWAPBOUNDS(D1(JNH3(START_LEVEL)),ROW_LENGTH,P_ROWS, AWO2F405.9
& EW_Halo,NS_Halo,K) AWO2F405.10
*ENDIF AWO2F405.11
DO K=START_LEVEL,END_LEVEL AWO2F405.12
CALL TRAC_ADV(D1(JNH3(K)),TRACER_EW_SWEEPS(1,K), AWO2F405.13
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F405.14
& LOCAL_ADVSTEP,ROW_LENGTH, AWO2F405.15
*CALL ARGFLDPT AWO2F405.16
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), AWO2F405.17
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F405.18
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F405.19
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F405.20
& L_SUPERBEE) AWO2F405.21
END DO AWO2F405.22
! AWO2F405.23
*IF DEF,MPP AWO2F405.24
K=END_LEVEL-START_LEVEL+1 AWO2F405.25
CALL SWAPBOUNDS(D1(JNH3(START_LEVEL)),ROW_LENGTH,P_ROWS, AWO2F405.26
& EW_Halo,NS_Halo,K) AWO2F405.27
*ENDIF AWO2F405.28
! AWO2F405.29
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F405.30
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F405.31
CALL TRAC_VERT_ADV(D1(JNH3(1)),ETADOT,D1(JPSTAR), AWO2F405.32
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, AWO2F405.33
& FIRST_POINT,POINTS,P_LEVELS, AWO2F405.34
& START_LEVEL,END_LEVEL, AWO2F405.35
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F405.36
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F405.37
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F405.38
& .FALSE.,L_SUPERBEE) AWO2F405.39
! AWO2F405.40
*IF DEF,GLOBAL AWO2F405.41
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F405.42
C polar locations. AWO2F405.43
DO K= START_LEVEL,END_LEVEL AWO2F405.44
*IF DEF,MPP AWO2F405.45
IF (at_top_of_LPG) THEN AWO2F405.46
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 AWO2F405.47
D1(JNH3(K)+I) = D1(JNH3(K)+START_POINT_NO_HALO-Offx-2) AWO2F405.48
END DO AWO2F405.49
END IF AWO2F405.50
IF (at_base_of_LPG) THEN AWO2F405.51
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 AWO2F405.52
D1(JNH3(K)+I) = D1(JNH3(K)+END_P_POINT_NO_HALO+Offx) AWO2F405.53
END DO AWO2F405.54
END IF AWO2F405.55
*ELSE AWO2F405.56
DO I = 0, ROW_LENGTH - 2 AWO2F405.57
D1(JNH3(K)+I) = D1(JNH3(K)+ROW_LENGTH-1) AWO2F405.58
D1(JNH3(K)+P_FIELD-1-I) = AWO2F405.59
& D1(JNH3(K)+P_FIELD-ROW_LENGTH) AWO2F405.60
END DO AWO2F405.61
*ENDIF AWO2F405.62
END DO AWO2F405.63
*ENDIF AWO2F405.64
*IF DEF,MPP AWO2F405.65
! AWO2F405.66
! Call swapbounds to update halo points for tracer advection levels. AWO2F405.67
K = END_LEVEL-START_LEVEL+1 AWO2F405.68
CALL SWAPBOUNDS(D1(JNH3(START_LEVEL)),ROW_LENGTH,P_ROWS, AWO2F405.69
& EW_Halo,NS_Halo,K) AWO2F405.70
*ENDIF AWO2F405.71
! AWO2F405.72
END IF ! END OF L_SULPC_NH3 BLOCK AWO2F405.73
! AWO2F401.83
*IF DEF,MPP GPB7F405.72
GPB7F405.73
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.74
K = END_LEVEL-START_LEVEL+1 GPB7F405.75
CALL SWAPBOUNDS(D1(JSO4_AITKEN(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.76
& EW_Halo,NS_Halo,K) GPB7F405.77
GPB7F405.78
*ENDIF GPB7F405.79
DO K=START_LEVEL,END_LEVEL ! for SO4_AIT AWO2F401.84
CALL TRAC_ADV(D1(JSO4_AITKEN(K)),TRACER_EW_SWEEPS(1,K), AWO2F401.85
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F401.86
& LOCAL_ADVSTEP,ROW_LENGTH, ARB1F402.169
*CALL ARGFLDPT ARB1F402.170
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), AWO2F401.88
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F401.89
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F401.90
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F401.91
& L_SUPERBEE) AWO2F401.92
END DO AWO2F401.93
*IF DEF,MPP GPB7F405.80
AWO2F401.94
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.81
K = END_LEVEL-START_LEVEL+1 GPB7F405.82
CALL SWAPBOUNDS(D1(JSO4_AITKEN(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.83
& EW_Halo,NS_Halo,K) GPB7F405.84
GPB7F405.85
*ENDIF GPB7F405.86
GPB7F405.87
AWO2F401.98
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F401.99
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F401.100
CALL TRAC_VERT_ADV(D1(JSO4_AITKEN(1)),ETADOT,D1(JPSTAR), AWO2F401.101
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, AWO2F401.102
& FIRST_POINT,POINTS,P_LEVELS, AWO2F401.103
& START_LEVEL,END_LEVEL, AWO2F401.104
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F401.105
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F401.106
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F401.107
& .FALSE.,L_SUPERBEE) AWO2F401.108
! AWO2F401.109
*IF DEF,GLOBAL AWO2F401.110
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F401.111
C polar locations. AWO2F401.112
DO K= START_LEVEL,END_LEVEL AWO2F401.113
*IF DEF,MPP ARB1F402.171
IF (at_top_of_LPG) THEN ARB1F402.172
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ARB1F402.173
D1(JSO4_AITKEN(K)+I) = ARB1F402.174
& D1(JSO4_AITKEN(K)+START_POINT_NO_HALO-Offx-2) ARB1F402.175
END DO ARB1F402.176
END IF ARB1F402.177
IF (at_base_of_LPG) THEN ARB1F402.178
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ARB1F402.179
D1(JSO4_AITKEN(K)+I) = ARB1F402.180
& D1(JSO4_AITKEN(K)+END_P_POINT_NO_HALO+Offx) ARB1F402.181
END DO ARB1F402.182
END IF ARB1F402.183
*ELSE ARB1F402.184
DO I = 0, ROW_LENGTH - 2 AWO2F401.114
D1(JSO4_AITKEN(K)+I) = D1(JSO4_AITKEN(K)+ROW_LENGTH-1) AWO2F401.115
D1(JSO4_AITKEN(K)+P_FIELD-1-I) = AWO2F401.116
& D1(JSO4_AITKEN(K)+P_FIELD-ROW_LENGTH) AWO2F401.117
END DO AWO2F401.118
*ENDIF ARB1F402.185
END DO AWO2F401.119
*ENDIF AWO2F401.120
*IF DEF,MPP ARB1F402.186
ARB1F402.187
! Call swapbounds to update halo points for tracer advection levels. ARB1F402.188
K = END_LEVEL-START_LEVEL+1 ARB1F403.91
CALL SWAPBOUNDS(D1(JSO4_AITKEN(START_LEVEL)),ROW_LENGTH,P_ROWS, ARB1F402.189
& EW_Halo,NS_Halo,K) ARB1F403.92
ARB1F402.191
*ENDIF ARB1F402.192
! AWO2F401.121
! AWO2F401.122
*IF DEF,MPP GPB7F405.88
GPB7F405.89
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.90
K = END_LEVEL-START_LEVEL+1 GPB7F405.91
CALL SWAPBOUNDS(D1(JSO4_ACCU(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.92
& EW_Halo,NS_Halo,K) GPB7F405.93
GPB7F405.94
*ENDIF GPB7F405.95
DO K=START_LEVEL,END_LEVEL ! for SO4_ACCU AWO2F401.123
CALL TRAC_ADV(D1(JSO4_ACCU(K)),TRACER_EW_SWEEPS(1,K), AWO2F401.124
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F401.125
& LOCAL_ADVSTEP,ROW_LENGTH, ARB1F402.193
*CALL ARGFLDPT ARB1F402.194
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), AWO2F401.127
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F401.128
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F401.129
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F401.130
& L_SUPERBEE) AWO2F401.131
END DO AWO2F401.132
*IF DEF,MPP GPB7F405.96
AWO2F401.133
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.97
K = END_LEVEL-START_LEVEL+1 GPB7F405.98
CALL SWAPBOUNDS(D1(JSO4_ACCU(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.99
& EW_Halo,NS_Halo,K) GPB7F405.100
GPB7F405.101
*ENDIF GPB7F405.102
GPB7F405.103
AWO2F401.137
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F401.138
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F401.139
CALL TRAC_VERT_ADV(D1(JSO4_ACCU(1)),ETADOT,D1(JPSTAR), AWO2F401.140
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, AWO2F401.141
& FIRST_POINT,POINTS,P_LEVELS, AWO2F401.142
& START_LEVEL,END_LEVEL, AWO2F401.143
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F401.144
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F401.145
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F401.146
& .FALSE.,L_SUPERBEE) AWO2F401.147
! AWO2F401.148
*IF DEF,GLOBAL AWO2F401.149
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F401.150
C polar locations. AWO2F401.151
DO K= START_LEVEL,END_LEVEL AWO2F401.152
*IF DEF,MPP ARB1F402.195
IF (at_top_of_LPG) THEN ARB1F402.196
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ARB1F402.197
D1(JSO4_ACCU(K)+I) = ARB1F402.198
& D1(JSO4_ACCU(K)+START_POINT_NO_HALO-Offx-2) ARB1F402.199
END DO ARB1F402.200
END IF ARB1F402.201
IF (at_base_of_LPG) THEN ARB1F402.202
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ARB1F402.203
D1(JSO4_ACCU(K)+I) = ARB1F402.204
& D1(JSO4_ACCU(K)+END_P_POINT_NO_HALO+Offx) ARB1F402.205
END DO ARB1F402.206
END IF ARB1F402.207
*ELSE ARB1F402.208
DO I = 0, ROW_LENGTH - 2 AWO2F401.153
D1(JSO4_ACCU(K)+I) = D1(JSO4_ACCU(K)+ROW_LENGTH-1) AWO2F401.154
D1(JSO4_ACCU(K)+P_FIELD-1-I) = AWO2F401.155
& D1(JSO4_ACCU(K)+P_FIELD-ROW_LENGTH) AWO2F401.156
END DO AWO2F401.157
*ENDIF ARB1F402.209
END DO AWO2F401.158
*ENDIF AWO2F401.159
*IF DEF,MPP ARB1F402.210
ARB1F402.211
! Call swapbounds to update halo points for tracer advection levels. ARB1F402.212
K = END_LEVEL-START_LEVEL+1 ARB1F403.93
CALL SWAPBOUNDS(D1(JSO4_ACCU(START_LEVEL)),ROW_LENGTH,P_ROWS, ARB1F402.213
& EW_Halo,NS_Halo,K) ARB1F403.94
ARB1F402.215
*ENDIF ARB1F402.216
! AWO2F401.160
! AWO2F401.161
*IF DEF,MPP GPB7F405.104
GPB7F405.105
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.106
K = END_LEVEL-START_LEVEL+1 GPB7F405.107
CALL SWAPBOUNDS(D1(JSO4_DISS(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.108
& EW_Halo,NS_Halo,K) GPB7F405.109
GPB7F405.110
*ENDIF GPB7F405.111
GPB7F405.112
DO K=START_LEVEL,END_LEVEL ! for SO4_DISS AWO2F401.162
CALL TRAC_ADV(D1(JSO4_DISS(K)),TRACER_EW_SWEEPS(1,K), AWO2F401.163
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F401.164
& LOCAL_ADVSTEP,ROW_LENGTH, ARB1F402.217
*CALL ARGFLDPT ARB1F402.218
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), AWO2F401.166
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F401.167
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F401.168
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F401.169
& L_SUPERBEE) AWO2F401.170
END DO AWO2F401.171
*IF DEF,MPP GPB7F405.113
AWO2F401.172
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.114
K = END_LEVEL-START_LEVEL+1 GPB7F405.115
CALL SWAPBOUNDS(D1(JSO4_DISS(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.116
& EW_Halo,NS_Halo,K) GPB7F405.117
GPB7F405.118
*ENDIF GPB7F405.119
GPB7F405.120
AWO2F401.176
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F401.177
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F401.178
CALL TRAC_VERT_ADV(D1(JSO4_DISS(1)),ETADOT,D1(JPSTAR), AWO2F401.179
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, AWO2F401.180
& FIRST_POINT,POINTS,P_LEVELS, AWO2F401.181
& START_LEVEL,END_LEVEL, AWO2F401.182
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F401.183
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F401.184
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F401.185
& .FALSE.,L_SUPERBEE) AWO2F401.186
! AWO2F401.187
*IF DEF,GLOBAL AWO2F401.188
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F401.189
C polar locations. AWO2F401.190
DO K= START_LEVEL,END_LEVEL AWO2F401.191
*IF DEF,MPP ARB1F402.219
IF (at_top_of_LPG) THEN ARB1F402.220
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ARB1F402.221
D1(JSO4_DISS(K)+I) = ARB1F402.222
& D1(JSO4_DISS(K)+START_POINT_NO_HALO-Offx-2) ARB1F402.223
END DO ARB1F402.224
END IF ARB1F402.225
IF (at_base_of_LPG) THEN ARB1F402.226
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ARB1F402.227
D1(JSO4_DISS(K)+I) = ARB1F402.228
& D1(JSO4_DISS(K)+END_P_POINT_NO_HALO+Offx) ARB1F402.229
END DO ARB1F402.230
END IF ARB1F402.231
*ELSE ARB1F402.232
DO I = 0, ROW_LENGTH - 2 AWO2F401.192
D1(JSO4_DISS(K)+I) = D1(JSO4_DISS(K)+ROW_LENGTH-1) AWO2F401.193
D1(JSO4_DISS(K)+P_FIELD-1-I) = AWO2F401.194
& D1(JSO4_DISS(K)+P_FIELD-ROW_LENGTH) AWO2F401.195
END DO AWO2F401.196
*ENDIF ARB1F402.233
END DO AWO2F401.197
*ENDIF AWO2F401.198
*IF DEF,MPP ARB1F402.234
ARB1F402.235
! Call swapbounds to update halo points for tracer advection levels. ARB1F402.236
K = END_LEVEL-START_LEVEL+1 ARB1F403.95
CALL SWAPBOUNDS(D1(JSO4_DISS(START_LEVEL)),ROW_LENGTH,P_ROWS, ARB1F402.237
& EW_Halo,NS_Halo,K) ARB1F403.96
ARB1F402.239
*ENDIF ARB1F402.240
! AWO2F401.199
! AWO2F401.200
IF (L_SULPC_DMS) THEN ! advect DMS if present AWO2F401.201
! AWO2F401.202
*IF DEF,MPP GPB7F405.121
GPB7F405.122
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.123
K = END_LEVEL-START_LEVEL+1 GPB7F405.124
CALL SWAPBOUNDS(D1(JDMS(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.125
& EW_Halo,NS_Halo,K) GPB7F405.126
GPB7F405.127
*ENDIF GPB7F405.128
DO K=START_LEVEL,END_LEVEL AWO2F401.203
CALL TRAC_ADV(D1(JDMS(K)),TRACER_EW_SWEEPS(1,K), AWO2F401.204
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F401.205
& LOCAL_ADVSTEP,ROW_LENGTH, ARB1F402.241
*CALL ARGFLDPT ARB1F402.242
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), AWO2F401.207
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F401.208
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F401.209
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F401.210
& L_SUPERBEE) AWO2F401.211
END DO AWO2F401.212
*IF DEF,MPP GPB7F405.129
AWO2F401.213
! Call swapbounds to update halo points for tracer advection levels. GPB7F405.130
K = END_LEVEL-START_LEVEL+1 GPB7F405.131
CALL SWAPBOUNDS(D1(JDMS(START_LEVEL)),ROW_LENGTH,P_ROWS, GPB7F405.132
& EW_Halo,NS_Halo,K) GPB7F405.133
GPB7F405.134
*ENDIF GPB7F405.135
AWO2F401.217
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F401.218
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F401.219
CALL TRAC_VERT_ADV(D1(JDMS(1)),ETADOT,D1(JPSTAR), AWO2F401.220
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, AWO2F401.221
& FIRST_POINT,POINTS,P_LEVELS, AWO2F401.222
& START_LEVEL,END_LEVEL, AWO2F401.223
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F401.224
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F401.225
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F401.226
& .FALSE.,L_SUPERBEE) AWO2F401.227
! AWO2F401.228
! AWO2F401.229
*IF DEF,GLOBAL AWO2F401.230
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F401.231
C polar locations. AWO2F401.232
DO K= START_LEVEL,END_LEVEL AWO2F401.233
*IF DEF,MPP ARB1F402.243
IF (at_top_of_LPG) THEN ARB1F402.244
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ARB1F402.245
D1(JDMS(K)+I) = D1(JDMS(K)+START_POINT_NO_HALO-Offx-2) ARB1F402.246
END DO ARB1F402.247
END IF ARB1F402.248
IF (at_base_of_LPG) THEN ARB1F402.249
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ARB1F402.250
D1(JDMS(K)+I) = D1(JDMS(K)+END_P_POINT_NO_HALO+Offx) ARB1F402.251
END DO ARB1F402.252
END IF ARB1F402.253
*ELSE ARB1F402.254
DO I = 0, ROW_LENGTH - 2 AWO2F401.234
D1(JDMS(K)+I) = D1(JDMS(K)+ROW_LENGTH-1) AWO2F401.235
D1(JDMS(K)+P_FIELD-1-I) = AWO2F401.236
& D1(JDMS(K)+P_FIELD-ROW_LENGTH) AWO2F401.237
END DO AWO2F401.238
*ENDIF ARB1F402.255
END DO AWO2F401.239
*ENDIF AWO2F401.240
*IF DEF,MPP ARB1F402.256
ARB1F402.257
! Call swapbounds to update halo points for tracer advection levels. ARB1F402.258
K = END_LEVEL-START_LEVEL+1 ARB1F403.97
CALL SWAPBOUNDS(D1(JDMS(START_LEVEL)),ROW_LENGTH,P_ROWS, ARB1F402.259
& EW_Halo,NS_Halo,K) ARB1F403.98
ARB1F402.261
*ENDIF ARB1F402.262
! AWO2F401.241
END IF ! END L_SULPC_DMS condition AWO2F401.242
! AWO2F401.243
END IF ! END L_SULPC_SO2 condition AWO2F401.244
! AWO2F401.245
! ---End of Sulphur Cycle code --- AWO2F401.246
! AWO2F401.247
AWO2F401.248
IF (L_SOOT) THEN ! Advect 3 modes of soot AWO2F405.77
START_LEVEL=1 AWO2F405.78
END_LEVEL=P_LEVELS AWO2F405.79
! Fresh soot: AWO2F405.80
!~~~~~~~~~~~~ AWO2F405.81
*IF DEF,MPP AWO2F405.82
K=END_LEVEL-START_LEVEL+1 AWO2F405.83
CALL SWAPBOUNDS(D1(JSOOT_NEW(START_LEVEL)),ROW_LENGTH, AWO2F405.84
& P_ROWS,EW_Halo,NS_Halo,K) AWO2F405.85
*ENDIF AWO2F405.86
DO K=START_LEVEL,END_LEVEL AWO2F405.87
CALL TRAC_ADV(D1(JSOOT_NEW(K)),TRACER_EW_SWEEPS(1,K), AWO2F405.88
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F405.89
& LOCAL_ADVSTEP,ROW_LENGTH, AWO2F405.90
*CALL ARGFLDPT AWO2F405.91
& SEC_P_LATITUDE,COS_P_LATITUDE, AWO2F405.92
& RS_FUNCTIONS(1,K), AWO2F405.93
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F405.94
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F405.95
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F405.96
& L_SUPERBEE) AWO2F405.97
END DO AWO2F405.98
AWO2F405.99
*IF DEF,MPP AWO2F405.100
K=END_LEVEL-START_LEVEL+1 AWO2F405.101
CALL SWAPBOUNDS(D1(JSOOT_NEW(START_LEVEL)),ROW_LENGTH,P_ROWS, AWO2F405.102
& EW_Halo,NS_Halo,K) AWO2F405.103
*ENDIF AWO2F405.104
AWO2F405.105
! AWO2F405.106
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F405.107
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F405.108
CALL TRAC_VERT_ADV(D1(JSOOT_NEW(1)),ETADOT,D1(JPSTAR), AWO2F405.109
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL, AWO2F405.110
& END_LEVEL, AWO2F405.111
& FIRST_POINT,POINTS,P_LEVELS, AWO2F405.112
& START_LEVEL,END_LEVEL, AWO2F405.113
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F405.114
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F405.115
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F405.116
& .FALSE.,L_SUPERBEE) AWO2F405.117
! AWO2F405.118
! AWO2F405.119
*IF DEF,GLOBAL AWO2F405.120
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F405.121
C polar locations. AWO2F405.122
DO K= START_LEVEL,END_LEVEL AWO2F405.123
*IF DEF,MPP AWO2F405.124
IF (at_top_of_LPG) THEN AWO2F405.125
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 AWO2F405.126
D1(JSOOT_NEW(K)+I) = AWO2F405.127
& D1(JSOOT_NEW(K)+START_POINT_NO_HALO-Offx-2) AWO2F405.128
END DO AWO2F405.129
END IF AWO2F405.130
IF (at_base_of_LPG) THEN AWO2F405.131
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 AWO2F405.132
D1(JSOOT_NEW(K)+I) = AWO2F405.133
& D1(JSOOT_NEW(K)+END_P_POINT_NO_HALO+Offx) AWO2F405.134
END DO AWO2F405.135
END IF AWO2F405.136
*ELSE AWO2F405.137
DO I = 0, ROW_LENGTH - 2 AWO2F405.138
D1(JSOOT_NEW(K)+I) = D1(JSOOT_NEW(K)+ROW_LENGTH-1) AWO2F405.139
D1(JSOOT_NEW(K)+P_FIELD-1-I) = AWO2F405.140
& D1(JSOOT_NEW(K)+P_FIELD-ROW_LENGTH) AWO2F405.141
END DO AWO2F405.142
*ENDIF AWO2F405.143
END DO AWO2F405.144
*ENDIF AWO2F405.145
*IF DEF,MPP AWO2F405.146
! AWO2F405.147
! Call swapbounds to update halo points for tracer advection levels. AWO2F405.148
K = END_LEVEL-START_LEVEL+1 AWO2F405.149
CALL SWAPBOUNDS(D1(JSOOT_NEW(START_LEVEL)),ROW_LENGTH,P_ROWS, AWO2F405.150
& EW_Halo,NS_Halo,K) AWO2F405.151
AWO2F405.152
*ENDIF AWO2F405.153
! AWO2F405.154
! Aged soot: AWO2F405.155
!~~~~~~~~~~~ AWO2F405.156
*IF DEF,MPP AWO2F405.157
K=END_LEVEL-START_LEVEL+1 AWO2F405.158
CALL SWAPBOUNDS(D1(JSOOT_AGD(START_LEVEL)),ROW_LENGTH, AWO2F405.159
& P_ROWS,EW_Halo,NS_Halo,K) AWO2F405.160
*ENDIF AWO2F405.161
DO K=START_LEVEL,END_LEVEL AWO2F405.162
CALL TRAC_ADV(D1(JSOOT_AGD(K)),TRACER_EW_SWEEPS(1,K), AWO2F405.163
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F405.164
& LOCAL_ADVSTEP,ROW_LENGTH, AWO2F405.165
*CALL ARGFLDPT AWO2F405.166
& SEC_P_LATITUDE,COS_P_LATITUDE, AWO2F405.167
& RS_FUNCTIONS(1,K), AWO2F405.168
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F405.169
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F405.170
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F405.171
& L_SUPERBEE) AWO2F405.172
END DO AWO2F405.173
AWO2F405.174
*IF DEF,MPP AWO2F405.175
K=END_LEVEL-START_LEVEL+1 AWO2F405.176
CALL SWAPBOUNDS(D1(JSOOT_AGD(START_LEVEL)),ROW_LENGTH, AWO2F405.177
& P_ROWS,EW_Halo,NS_Halo,K) AWO2F405.178
*ENDIF AWO2F405.179
AWO2F405.180
! AWO2F405.181
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F405.182
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F405.183
CALL TRAC_VERT_ADV(D1(JSOOT_AGD(1)),ETADOT,D1(JPSTAR), AWO2F405.184
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL, AWO2F405.185
& END_LEVEL, AWO2F405.186
& FIRST_POINT,POINTS,P_LEVELS, AWO2F405.187
& START_LEVEL,END_LEVEL, AWO2F405.188
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F405.189
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F405.190
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F405.191
& .FALSE.,L_SUPERBEE) AWO2F405.192
! AWO2F405.193
! AWO2F405.194
*IF DEF,GLOBAL AWO2F405.195
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F405.196
C polar locations. AWO2F405.197
DO K= START_LEVEL,END_LEVEL AWO2F405.198
*IF DEF,MPP AWO2F405.199
IF (at_top_of_LPG) THEN AWO2F405.200
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 AWO2F405.201
D1(JSOOT_AGD(K)+I) = AWO2F405.202
& D1(JSOOT_AGD(K)+START_POINT_NO_HALO-Offx-2) AWO2F405.203
END DO AWO2F405.204
END IF AWO2F405.205
IF (at_base_of_LPG) THEN AWO2F405.206
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 AWO2F405.207
D1(JSOOT_AGD(K)+I) = AWO2F405.208
& D1(JSOOT_AGD(K)+END_P_POINT_NO_HALO+Offx) AWO2F405.209
END DO AWO2F405.210
END IF AWO2F405.211
*ELSE AWO2F405.212
DO I = 0, ROW_LENGTH - 2 AWO2F405.213
D1(JSOOT_AGD(K)+I) = D1(JSOOT_AGD(K)+ROW_LENGTH-1) AWO2F405.214
D1(JSOOT_AGD(K)+P_FIELD-1-I) = AWO2F405.215
& D1(JSOOT_AGD(K)+P_FIELD-ROW_LENGTH) AWO2F405.216
END DO AWO2F405.217
*ENDIF AWO2F405.218
END DO AWO2F405.219
*ENDIF AWO2F405.220
*IF DEF,MPP AWO2F405.221
! AWO2F405.222
! Call swapbounds to update halo points for tracer advection levels. AWO2F405.223
K = END_LEVEL-START_LEVEL+1 AWO2F405.224
CALL SWAPBOUNDS(D1(JSOOT_AGD(START_LEVEL)),ROW_LENGTH, AWO2F405.225
& P_ROWS,EW_Halo,NS_Halo,K) AWO2F405.226
! AWO2F405.227
*ENDIF AWO2F405.228
! AWO2F405.229
! Soot in cloud water: AWO2F405.230
!~~~~~~~~~~~~~~~~~~~~~ AWO2F405.231
*IF DEF,MPP AWO2F405.232
K=END_LEVEL-START_LEVEL+1 AWO2F405.233
CALL SWAPBOUNDS(D1(JSOOT_CLD(START_LEVEL)),ROW_LENGTH, AWO2F405.234
& P_ROWS,EW_Halo,NS_Halo,K) AWO2F405.235
*ENDIF AWO2F405.236
DO K=START_LEVEL,END_LEVEL AWO2F405.237
CALL TRAC_ADV(D1(JSOOT_CLD(K)),TRACER_EW_SWEEPS(1,K), AWO2F405.238
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, AWO2F405.239
& LOCAL_ADVSTEP,ROW_LENGTH, AWO2F405.240
*CALL ARGFLDPT AWO2F405.241
& SEC_P_LATITUDE,COS_P_LATITUDE, AWO2F405.242
& RS_FUNCTIONS(1,K), AWO2F405.243
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), AWO2F405.244
& A_LEVDEPC(JDELTA_BK+K-1), AWO2F405.245
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, AWO2F405.246
& L_SUPERBEE) AWO2F405.247
END DO AWO2F405.248
AWO2F405.249
*IF DEF,MPP AWO2F405.250
K=END_LEVEL-START_LEVEL+1 AWO2F405.251
CALL SWAPBOUNDS(D1(JSOOT_CLD(START_LEVEL)),ROW_LENGTH, AWO2F405.252
& P_ROWS,EW_Halo,NS_Halo,K) AWO2F405.253
*ENDIF AWO2F405.254
AWO2F405.255
AWO2F405.256
! For vertical advection of aerosol call TRAC_VERT_ADV with AWO2F405.257
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. AWO2F405.258
CALL TRAC_VERT_ADV(D1(JSOOT_CLD(1)),ETADOT,D1(JPSTAR), AWO2F405.259
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL, AWO2F405.260
& END_LEVEL, AWO2F405.261
& FIRST_POINT,POINTS,P_LEVELS, AWO2F405.262
& START_LEVEL,END_LEVEL, AWO2F405.263
& RS_FUNCTIONS,A_LEVDEPC(JAK), AWO2F405.264
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), AWO2F405.265
& A_LEVDEPC(JDELTA_BK),WORK2, AWO2F405.266
& .FALSE.,L_SUPERBEE) AWO2F405.267
! AWO2F405.268
! AWO2F405.269
*IF DEF,GLOBAL AWO2F405.270
C Copy the one polar value updated by TRAC_VERT_ADV to the other AWO2F405.271
C polar locations. AWO2F405.272
DO K= START_LEVEL,END_LEVEL AWO2F405.273
*IF DEF,MPP AWO2F405.274
IF (at_top_of_LPG) THEN AWO2F405.275
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 AWO2F405.276
D1(JSOOT_CLD(K)+I) = AWO2F405.277
& D1(JSOOT_CLD(K)+START_POINT_NO_HALO-Offx-2) AWO2F405.278
END DO AWO2F405.279
END IF AWO2F405.280
IF (at_base_of_LPG) THEN AWO2F405.281
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 AWO2F405.282
D1(JSOOT_CLD(K)+I) = AWO2F405.283
& D1(JSOOT_CLD(K)+END_P_POINT_NO_HALO+Offx) AWO2F405.284
END DO AWO2F405.285
END IF AWO2F405.286
*ELSE AWO2F405.287
DO I = 0, ROW_LENGTH - 2 AWO2F405.288
D1(JSOOT_CLD(K)+I) = D1(JSOOT_CLD(K)+ROW_LENGTH-1) AWO2F405.289
D1(JSOOT_CLD(K)+P_FIELD-1-I) = AWO2F405.290
& D1(JSOOT_CLD(K)+P_FIELD-ROW_LENGTH) AWO2F405.291
END DO AWO2F405.292
*ENDIF AWO2F405.293
END DO AWO2F405.294
*ENDIF AWO2F405.295
*IF DEF,MPP AWO2F405.296
! AWO2F405.297
! Call swapbounds to update halo points for tracer advection levels. AWO2F405.298
K = END_LEVEL-START_LEVEL+1 AWO2F405.299
CALL SWAPBOUNDS(D1(JSOOT_CLD(START_LEVEL)),ROW_LENGTH, AWO2F405.300
& P_ROWS,EW_Halo,NS_Halo,K) AWO2F405.301
AWO2F405.302
*ENDIF AWO2F405.303
! AWO2F405.304
END IF ! L_SOOT condition AWO2F405.305
! AWO2F405.306
! --- End of soot advection --- AWO2F405.307
! AWO2F405.308
AWO2F405.309
ACN2F405.138
!-- ---- Code for Carbon Cycle tracer ------ ACN2F405.139
! ACN2F405.140
IF (L_CO2_INTERACTIVE) THEN ACN2F405.141
START_LEVEL=1 ACN2F405.142
END_LEVEL=P_LEVELS ACN2F405.143
ACN2F405.144
*IF DEF,MPP ACN2F405.145
K=END_LEVEL-START_LEVEL+1 ACN2F405.146
CALL SWAPBOUNDS(D1(JCO2(START_LEVEL)), ACN2F405.147
& ROW_LENGTH,P_ROWS,EW_Halo,NS_Halo,K) ACN2F405.148
*ENDIF ACN2F405.149
ACN2F405.150
DO K=START_LEVEL,END_LEVEL ACN2F405.151
CALL TRAC_ADV(D1(JCO2(K)),TRACER_EW_SWEEPS(1,K), ACN2F405.152
& U_MEAN(1,K),WORK1(1,K),U_FIELD,P_FIELD, ACN2F405.153
& LOCAL_ADVSTEP,ROW_LENGTH, ACN2F405.154
*CALL ARGFLDPT ACN2F405.155
& SEC_P_LATITUDE,COS_P_LATITUDE,RS_FUNCTIONS(1,K), ACN2F405.156
& PSTAR_OLD,A_LEVDEPC(JDELTA_AK+K-1), ACN2F405.157
& A_LEVDEPC(JDELTA_BK+K-1), ACN2F405.158
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE, ACN2F405.159
& L_SUPERBEE) ACN2F405.160
END DO ACN2F405.161
ACN2F405.162
*IF DEF,MPP ACN2F405.163
K=END_LEVEL-START_LEVEL+1 ACN2F405.164
CALL SWAPBOUNDS(D1(JCO2(START_LEVEL)), ACN2F405.165
& ROW_LENGTH,P_ROWS,EW_Halo,NS_Halo,K) ACN2F405.166
*ENDIF ACN2F405.167
ACN2F405.168
! For vertical advection of carbon dioxide call TRAC_VERT_ADV with ACN2F405.169
! penultimate argument (L_TRACER_THETAL_QT) set to .FALSE. ACN2F405.170
CALL TRAC_VERT_ADV(D1(JCO2(1)),ETADOT,D1(JPSTAR), ACN2F405.171
& P_FIELD,LOCAL_ADVSTEP,START_LEVEL,END_LEVEL, ACN2F405.172
& FIRST_POINT,POINTS,P_LEVELS, ACN2F405.173
& START_LEVEL,END_LEVEL, ACN2F405.174
& RS_FUNCTIONS,A_LEVDEPC(JAK), ACN2F405.175
& A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), ACN2F405.176
& A_LEVDEPC(JDELTA_BK),WORK2, ACN2F405.177
& .FALSE.,L_SUPERBEE) ACN2F405.178
! ACN2F405.179
! ACN2F405.180
*IF DEF,GLOBAL ACN2F405.181
C Copy the one polar value updated by TRAC_VERT_ADV to the other ACN2F405.182
C polar locations. ACN2F405.183
DO K= START_LEVEL,END_LEVEL ACN2F405.184
*IF DEF,MPP ACN2F405.185
IF (at_top_of_LPG) THEN ACN2F405.186
DO I = FIRST_VALID_PT+Offx-1,START_POINT_NO_HALO-Offx-3 ACN2F405.187
D1(JCO2(K)+I) = D1(JCO2(K)+START_POINT_NO_HALO-Offx-2) ACN2F405.188
END DO ACN2F405.189
END IF ACN2F405.190
IF (at_base_of_LPG) THEN ACN2F405.191
DO I = END_P_POINT_NO_HALO+Offx+1,LAST_P_VALID_PT-Offx-1 ACN2F405.192
D1(JCO2(K)+I) = D1(JCO2(K)+END_P_POINT_NO_HALO+Offx) ACN2F405.193
END DO ACN2F405.194
END IF ACN2F405.195
*ELSE ACN2F405.196
DO I = 0, ROW_LENGTH - 2 ACN2F405.197
D1(JCO2(K)+I) = D1(JCO2(K)+ROW_LENGTH-1) ACN2F405.198
D1(JCO2(K)+P_FIELD-1-I) = ACN2F405.199
& D1(JCO2(K)+P_FIELD-ROW_LENGTH) ACN2F405.200
END DO ACN2F405.201
*ENDIF ACN2F405.202
END DO ACN2F405.203
*ENDIF ACN2F405.204
*IF DEF,MPP ACN2F405.205
! Call swapbounds to update halo points for tracer advection levels. ACN2F405.206
K = END_LEVEL-START_LEVEL+1 ACN2F405.207
CALL SWAPBOUNDS(D1(JCO2(START_LEVEL)),ROW_LENGTH,P_ROWS, ACN2F405.208
& EW_Halo,NS_Halo,K) ACN2F405.209
ACN2F405.210
*ENDIF ACN2F405.211
! ACN2F405.212
END IF ! END CO2_INTERACTIVE condition ACN2F405.213
! ACN2F405.214
! ---End of Carbon Cycle code --- ACN2F405.215
! ACN2F405.216
GRB1F400.4
IF(LTIMER)CALL TIMER('TRAC_ADV',4) GSM1F401.3
C APC1F304.87
C STASH handling APC1F304.88
C APC1F304.89
FIRST_POINT=ROW_LENGTH+1 ATMDYN1.428
ATMDYN1.429
! Call STASH only on last sweep of long physics timestep ARB0F400.23
! and of half-timestep dynamics. ARB0F400.24
IF (I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS) THEN ARB0F400.25
ATD0F304.3
IF(LTIMER) THEN ATMDYN1.430
CALL TIMER('STASH ',3) ATMDYN1.431
END IF ATMDYN1.432
ATMDYN1.433
CALL STASH(a_sm,a_im,11,STASHWORK, GKR0F305.882
*CALL ARGSIZE @DYALLOC.295
*CALL ARGD1 @DYALLOC.296
*CALL ARGDUMA @DYALLOC.297
*CALL ARGDUMO @DYALLOC.298
*CALL ARGDUMW GKR1F401.169
*CALL ARGSTS @DYALLOC.299
*CALL ARGPPX GKR0F305.883
& ICODE,CMESSAGE) @DYALLOC.303
ATMDYN1.435
IF(LTIMER) THEN ATMDYN1.436
CALL TIMER('STASH ',4) ATMDYN1.437
END IF ATMDYN1.438
ATMDYN1.439
IF(ICODE.GT.0) THEN ATMDYN1.440
RETURN ATMDYN1.441
END IF ATMDYN1.442
ATD0F304.4
END IF ! I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS ARB0F400.26
ATMDYN1.443
ENDIF ! TR_VARS.NE.0 ARB0F400.27
ATMDYN1.445
CL --------------------------------------------------------------------- ATMDYN1.446
CL Section 12 Advection of momentum, thetal and qt ATMDYN1.447
CL --------------------------------------------------------------------- ATMDYN1.448
CL ATMDYN1.449
CL WORK1 holds V_MEAN. ATMDYN1.450
CL ATMDYN1.451
CL 12.1 Set up divergence damping coefficients for assimilation ADR1F305.21
CL or forecast as appropriate ATMDYN1.453
ATMDYN1.454
IF(.NOT.LASSIMILATION) THEN ATMDYN1.455
DO LEVEL=1,P_LEVELS ATMDYN1.456
KD(LEVEL)=DIV_DAMP_COEFF_FC(LEVEL) ADR1F305.22
END DO ATMDYN1.458
ATMDYN1.459
ELSEIF(A_STEP-ASSIM_FIRSTSTEPim(a_im).LT.ASSIM_STEPSim(a_im))THEN GDR5F305.10
DO LEVEL=1,P_LEVELS ATMDYN1.461
KD(LEVEL)=DIV_DAMP_COEFF_ASSM(LEVEL) ADR1F305.23
END DO ATMDYN1.463
ATMDYN1.464
ELSE ATMDYN1.465
IF (ASSIM_EXTRASTEPSim(a_im).EQ.0) THEN GDR5F305.11
WEIGHT=1.0 ATMDYN1.467
ELSE ATMDYN1.468
WEIGHT = GDR5F305.12
& REAL(A_STEP-ASSIM_FIRSTSTEPim(a_im)-ASSIM_STEPSim(a_im))/ GDR5F305.13
& REAL(ASSIM_EXTRASTEPSim(a_im)) GDR5F305.14
END IF ATMDYN1.471
ATMDYN1.472
DO LEVEL=1,P_LEVELS ATMDYN1.473
KD(LEVEL) = WEIGHT*DIV_DAMP_COEFF_FC(LEVEL) + ADR1F305.24
& (1.0-WEIGHT)*DIV_DAMP_COEFF_ASSM(LEVEL) ADR1F305.25
END DO ATMDYN1.476
ATMDYN1.477
END IF ATMDYN1.478
ATMDYN1.479
CL 12.2 Call ADV_CTL to advect primary fields, all advected fields are ATMDYN1.480
CL mass weighted on output ATMDYN1.481
ATMDYN1.482
IF(LTIMER) THEN ATMDYN1.483
CALL TIMER('ADVECTION',5) GPB1F401.15
CALL TIMER('ADV_CTL ',3) ATMDYN1.484
END IF ATMDYN1.485
ATMDYN1.486
IF (L_WRIT_DYN .AND. WRITD1_THIS_SWEEP .AND. ARR2F405.31
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1322
TJ270193.55
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1323
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1324
GSS1F304.1325
CALL DUMPCTL ( GKR4F403.127
*CALL ARGSIZE GKR4F403.128
*CALL ARGD1 GKR4F403.129
*CALL ARGDUMA GKR4F403.130
*CALL ARGDUMO GKR4F403.131
*CALL ARGDUMW GKR4F403.132
*CALL ARGCONA GKR4F403.133
*CALL ARGPTRA GKR4F403.134
*CALL ARGSTS GKR4F403.135
*CALL ARGPPX GKR4F403.136
& atmos_sm,0,.TRUE.,'bf_adv_ctl',a_step, GIE1F405.21
& ICODE,CMESSAGE) GKR4F403.138
GSS1F304.1327
END IF GSS1F304.1328
GSS1F304.1329
END IF GSS1F304.1330
GSS1F304.1331
! If using mixed phase precip scheme then do not want ice in the call ADM2F404.75
IF (L_LSPICE) THEN ADM2F404.76
! Already set up zerofield array so no need to do it again ADM2F404.77
! Mixed phase precip scheme. Go straight to the call. ADM2F404.78
CALL ADV_CTL( ADM2F404.79
& D1(JTHETA(1)),D1(JQ(1)),PSTAR_OLD,D1(JPSTAR), ADM2F404.80
& U_MEAN,WORK1,D1(JU(1)), ADM2F404.81
& D1(JV(1)),COS_U_LATITUDE,COS_P_LATITUDE,SEC_P_LATITUDE,ETADOT, ADM2F404.82
& RS_FUNCTIONS,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK), ADM2F404.83
& LATITUDE_STEP_INVERSE,LOCAL_ADVSTEP, ADM2F404.84
& NU_BASIC,LONGITUDE_STEP_INVERSE,A_INTHD(19),A_INTHD(20) ADM2F404.85
& ,Q_LEVELS,U_FIELD,P_FIELD,ROW_LENGTH, ADM2F404.86
*CALL ARGFLDPT ADM2F404.87
& P_LEVELS,SEC_U_LATITUDE, ADM2F404.88
& F1,F2,A_LEVDEPC(JAK),A_LEVDEPC(JBK), ADM2F404.89
& KD,AKH,BKH,COS_LONGITUDE,SIN_LONGITUDE, ADM2F404.90
& TRIGS,IFAX,A_ROWDEPC(JFILTER_WAVE_NUMBER_P_ROWS), ADM2F404.91
& WORK3,D1(JQCL(1)),ZERO_FIELD, ADM2F404.92
& D1(JP_EXNER(1)),LLINTS,LWHITBROM, ADM2F404.93
& L_TRACER_THETAL_QT,TRACER_EW_SWEEPS,L_SUPERBEE) ADM2F404.94
ELSE ADM2F404.95
CALL ADV_CTL( ATMDYN1.487
& D1(JTHETA(1)),D1(JQ(1)),PSTAR_OLD,D1(JPSTAR), ATMDYN1.488
& U_MEAN,WORK1,D1(JU(1)), ATMDYN1.489
& D1(JV(1)),COS_U_LATITUDE,COS_P_LATITUDE,SEC_P_LATITUDE,ETADOT, ATD1F400.38
& RS_FUNCTIONS,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK), ATMDYN1.491
& LATITUDE_STEP_INVERSE,LOCAL_ADVSTEP, AL131293.124
& NU_BASIC,LONGITUDE_STEP_INVERSE,A_INTHD(19),A_INTHD(20) ADR1F305.26
& ,Q_LEVELS,U_FIELD,P_FIELD,ROW_LENGTH, APB0F401.54
*CALL ARGFLDPT APB0F401.55
& P_LEVELS,SEC_U_LATITUDE, APB0F401.56
& F1,F2,A_LEVDEPC(JAK),A_LEVDEPC(JBK), ATMDYN1.496
& KD,AKH,BKH,COS_LONGITUDE,SIN_LONGITUDE, ATMDYN1.497
& TRIGS,IFAX,A_ROWDEPC(JFILTER_WAVE_NUMBER_P_ROWS), ATMDYN1.498
& WORK3,D1(JQCL(1)),D1(JQCF(1)), ATMDYN1.499
& D1(JP_EXNER(1)),LLINTS,LWHITBROM, ATD1F400.39
& L_TRACER_THETAL_QT,TRACER_EW_SWEEPS,L_SUPERBEE) ATD1F400.40
! END IF for L_LSPICE ADM2F404.96
END IF ADM2F404.97
ATMDYN1.501
IF (L_WRIT_DYN .AND. WRITD1_THIS_SWEEP .AND. ARR2F405.32
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1334
GSS1F304.1335
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1336
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1337
GSS1F304.1338
CALL DUMPCTL ( GKR4F403.139
*CALL ARGSIZE GKR4F403.140
*CALL ARGD1 GKR4F403.141
*CALL ARGDUMA GKR4F403.142
*CALL ARGDUMO GKR4F403.143
*CALL ARGDUMW GKR4F403.144
*CALL ARGCONA GKR4F403.145
*CALL ARGPTRA GKR4F403.146
*CALL ARGSTS GKR4F403.147
*CALL ARGPPX GKR4F403.148
& atmos_sm,0,.TRUE.,'af_adv_ctl',a_step, GIE1F405.2
& ICODE,CMESSAGE) GKR4F403.150
GSS1F304.1340
END IF GSS1F304.1341
GSS1F304.1342
END IF GSS1F304.1343
TJ270193.59
IF(LTIMER) THEN ATMDYN1.502
CALL TIMER('ADV_CTL ',4) ATMDYN1.503
CALL TIMER('ADVECTION',6) GPB1F401.16
END IF ATMDYN1.504
ATMDYN1.506
CL --------------------------------------------------------------------- ATMDYN1.507
CL 12.3 IF STANDARD ADVECTION THEN CALL MASS_UWT TO REMOVE ATD1F400.41
CL MASS-WEIGHTING OF PRIMARY FIELDS (CALL MASS_UWT) ATD1F400.42
CL IF TRACER ADVECTION OF THETAL AND QT THEN REMOVE ATD1F400.43
CL MASS-WEIGHTING FROM U AND V ONLY (CALL MASS_UWT_UV) ATD1F400.44
CL --------------------------------------------------------------------- ATMDYN1.510
IF(L_TRACER_THETAL_QT)THEN ATD1F400.45
ATD1F400.46
IF(LTIMER) THEN ATD1F400.47
CALL TIMER('MASS_UVW',3) ATD1F400.48
END IF ATD1F400.49
ATD1F400.50
CALL MASS_UWT_UV( ATD1F400.51
& RS_FUNCTIONS,WORK4,D1(JU(1)),D1(JV(1)),D1(JPSTAR), AAD2F404.316
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), ATD1F400.53
& A_LEVDEPC(JDELTA_BK),P_FIELD,U_FIELD,P_LEVELS,ROW_LENGTH, APB0F401.57
*CALL ARGFLDPT APB0F401.58
& LLINTS,LWHITBROM) APB0F401.59
ATD1F400.56
IF(LTIMER) THEN ATD1F400.57
CALL TIMER('MASS_UVW',4) ATD1F400.58
END IF ATD1F400.59
ATD1F400.60
ELSE ATD1F400.61
ATD1F400.62
ATMDYN1.511
IF(LTIMER) THEN ATMDYN1.512
CALL TIMER('MASS_UWT',3) ATMDYN1.513
END IF ATMDYN1.514
ATMDYN1.515
CALL MASS_UWT( ATMDYN1.516
& RS_FUNCTIONS,WORK4,D1(JTHETA(1)),D1(JQ(1)),D1(JU(1)), AAD2F404.317
& D1(JV(1)),D1(JPSTAR), ATMDYN1.518
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),A_LEVDEPC(JDELTA_AK), ATMDYN1.519
& A_LEVDEPC(JDELTA_BK),P_FIELD,U_FIELD,P_LEVELS,Q_LEVELS, ATMDYN1.520
& ROW_LENGTH, APB0F401.60
*CALL ARGFLDPT APB0F401.61
& LLINTS,LWHITBROM) APB0F401.62
ATMDYN1.522
IF(LTIMER) THEN ATMDYN1.523
CALL TIMER('MASS_UWT',4) ATMDYN1.524
END IF ATMDYN1.525
END IF ATD1F400.63
ATMDYN1.526
*IF DEF,MPP APB0F305.32
! U and V are swapped here, and not within adv_ctl, as are the other APB0F305.33
! advected variables, because MASS_UWT applies an interpolated operator APB0F305.34
! to U and V which leaves the halo incorrect. Moving the UV swap to here APB0F305.35
! saves having to do an extra swap on the operator or UV. APB0F305.36
CALL SWAPBOUNDS(D1(JU(1)),ROW_LENGTH,P_ROWS, APB0F401.63
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.64
CALL SWAPBOUNDS(D1(JV(1)),ROW_LENGTH,P_ROWS, APB0F401.65
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.66
! And update the halos of THETA APB0F401.67
! CALL SWAPBOUNDS(D1(JTHETA(1)),ROW_LENGTH,P_ROWS, APB0F401.68
! & EW_Halo,NS_Halo,P_LEVELS) APB0F401.69
*ENDIF APB0F305.39
! Compute omega and call STASH only on last sweep ARB0F400.28
! of long physics timestep and of half-timestep dynamics. ARB0F400.29
IF (I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS) THEN ARB0F400.30
ATD0F304.8
c if either omega on pressure levels or omega on model levels requested ATMDYN1.527
c then remove mass-weighting from omega on model levels. ATMDYN1.528
ATMDYN1.529
IF(SF(201,12).OR.SF(202,12)) THEN ATMDYN1.530
DO K=1,P_LEVELS ATMDYN1.531
CALL P_TO_UV(RS_FUNCTIONS(1,K),WORK2,P_FIELD,U_FIELD, ATMDYN1.532
& ROW_LENGTH,P_ROWS) ATMDYN1.533
! loop over "local" points - not including top and bottom halos APB0F401.70
DO I=FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.71
WORK3((K-1)*U_FIELD+I)= WORK3((K-1)*U_FIELD+I)/WORK2(I) ATMDYN1.535
END DO ATMDYN1.536
END DO ATMDYN1.537
END IF ATMDYN1.538
ATMDYN1.539
CL Copy omega on model levels into stashwork if diagnostic required. ATMDYN1.540
IF(SF(201,12)) THEN ATMDYN1.541
CALL COPYDIAG_3D(STASHWORK(SI(201,12,im_index)), GRB4F305.11
& WORK3,FIRST_POINT, GRB4F305.12
& LAST_POINT,U_FIELD,ROW_LENGTH,P_LEVELS, ATMDYN1.543
& STLIST(1,STINDEX(1,201,12,im_index)), GRB4F305.13
& LEN_STLIST,STASH_LEVELS, GRB4F305.14
& NUM_STASH_LEVELS+1, GPB1F403.298
& im_ident,12,201, GPB1F403.299
*CALL ARGPPX GPB1F403.300
& ICODE,CMESSAGE) GPB1F403.301
IF(ICODE.GT.0) THEN ATMDYN1.547
RETURN ATMDYN1.548
END IF ATMDYN1.549
END IF ATMDYN1.550
ATMDYN1.551
CL-------------------Extract Reqd Pressures for OMEGA_P-------------- ATMDYN1.552
ATMDYN1.553
C WORK1 holds pressure, WORK2 holds required pressure ATMDYN1.554
ATMDYN1.555
IF(SF(202,12)) THEN ATMDYN1.556
ATMDYN1.557
ISL=STINDEX(1,202,12,im_index) GRB4F305.15
IF(STLIST(10,ISL).LT.0) THEN ATMDYN1.559
IF(STLIST(11,ISL).EQ.2) THEN ATMDYN1.560
NI=-STLIST(10,ISL) ATMDYN1.561
OMEGA_P_LEVS=STASH_LEVELS(1,NI) ATMDYN1.562
DO K =1,OMEGA_P_LEVS ATMDYN1.563
OMEGA_PRESS(K)=STASH_LEVELS(K+1,NI)/1000.0 ATMDYN1.564
ENDDO ATMDYN1.565
ELSE ATMDYN1.566
CMESSAGE='ATM_DYN Level not pressure for OMEGA' ATMDYN1.567
ICODE=1 ATMDYN1.568
RETURN ATMDYN1.569
END IF ATMDYN1.570
ELSE ATMDYN1.571
CMESSAGE='ATM_DYN Level not a LEVELS list for OMEGA' ATMDYN1.572
ICODE=1 ATMDYN1.573
RETURN ATMDYN1.574
END IF ATMDYN1.575
ATMDYN1.576
CL------------------Interpolate OMEGA onto Pressure level--------- ATMDYN1.577
ATMDYN1.578
C Set up inout and output pressures ATMDYN1.579
CALL P_TO_UV(D1(JPSTAR),WORK2,P_FIELD,U_FIELD,ROW_LENGTH,P_ROWS) ATMDYN1.580
DO K=1,P_LEVELS ATMDYN1.581
! loop over "local" points - not including top and bottom halos APB0F401.72
DO I=FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.73
WORK1(I,K) = A_LEVDEPC(JAK+K-1)+A_LEVDEPC(JBK+K-1)*WORK2(I) ATMDYN1.583
END DO ATMDYN1.584
END DO ATMDYN1.585
*IF DEF,MPP GSM5F403.1
CALL SWAPBOUNDS(WORK1(1,1),ROW_LENGTH,tot_U_ROWS,EW_Halo, GSM5F403.2
& NS_Halo,P_LEVELS) GSM5F403.3
*ENDIF GSM5F403.4
ATMDYN1.586
DO K=1,OMEGA_P_LEVS ATMDYN1.587
! loop over "local" points - not including top and bottom halos APB0F401.74
DO I=FIRST_FLD_PT,LAST_U_FLD_PT APB0F401.75
WORK2(I)=OMEGA_PRESS(K)*100.0 ! convert to Pascals ATMDYN1.589
END DO ATMDYN1.590
CALL V_INT(WORK1,WORK2,WORK3, ATMDYN1.591
& STASHWORK(SI(202,12,im_index)+(K-1)*U_FIELD), GRB4F305.16
& U_FIELD,P_LEVELS,WORK1,WORK2,.FALSE., GSM1F405.563
& FIRST_FLD_PT,LAST_U_FLD_PT) GSM1F405.564
END DO ATMDYN1.594
ENDIF ATMDYN1.595
ATMDYN1.596
IF(LTIMER) THEN ATMDYN1.597
CALL TIMER('STASH ',3) ATMDYN1.598
END IF ATMDYN1.599
CALL STASH(a_sm,a_im,12,STASHWORK, GKR0F305.884
*CALL ARGSIZE @DYALLOC.305
*CALL ARGD1 @DYALLOC.306
*CALL ARGDUMA @DYALLOC.307
*CALL ARGDUMO @DYALLOC.308
*CALL ARGDUMW GKR1F401.170
*CALL ARGSTS @DYALLOC.309
*CALL ARGPPX GKR0F305.885
& ICODE,CMESSAGE) @DYALLOC.313
ATMDYN1.601
IF(LTIMER) THEN ATMDYN1.602
CALL TIMER('STASH ',4) ATMDYN1.603
END IF ATMDYN1.604
ATMDYN1.605
IF (ICODE.GT.0) THEN ATMDYN1.606
RETURN ATMDYN1.607
END IF ATMDYN1.608
ATD0F304.9
END IF ! I_LOOP.eq.A_SWEEPS_DYN .and. I_COUNT.eq.NSWEEPS ARB0F400.31
ATMDYN1.609
ATMDYN1.610
CL --------------------------------------------------------------------- ATMDYN1.611
CL section 13 Divergence, damping, diffusion and filtering ATMDYN1.612
CL --------------------------------------------------------------------- ATMDYN1.613
CL 13.1 call DIF_CTL to perform diffusions ATMDYN1.614
CL --------------------------------------------------------------------- ATMDYN1.615
ATMDYN1.616
IF(LTIMER) THEN ATMDYN1.617
CALL TIMER('DIFFUSION',5) GPB1F401.17
CALL TIMER('DIF_CTL ',3) ATMDYN1.618
END IF ATMDYN1.619
ATMDYN1.620
CALL DIF_CTL( ATMDYN1.621
& D1(JPSTAR),D1(JU(1)),D1(JV(1)),D1(JTHETA(1)),D1(JQ(1)), ATMDYN1.622
& RS_FUNCTIONS,DIFF_COEFF,DIFF_COEFF_Q, ADR1F305.27
& DIFF_EXP,DIFF_EXP_Q, ADR1F305.28
& A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK), ATMDYN1.625
& A_LEVDEPC(JAK),A_LEVDEPC(JBK), ATD1F400.64
& LOCAL_ADVSTEP, AL131293.125
& COS_U_LATITUDE,COS_P_LATITUDE,SEC_U_LATITUDE, ATMDYN1.627
& SEC_P_LATITUDE,LONGITUDE_STEP_INVERSE,P_FIELD, ATMDYN1.628
& LATITUDE_STEP_INVERSE,U_FIELD,ROW_LENGTH, APB0F401.76
*CALL ARGFLDPT APB0F401.77
& P_LEVELS,Q_LEVELS, APB0F401.78
& COS_LONGITUDE,SIN_LONGITUDE, ATD1F400.65
& PRESSURE_ALTITUDE,L_TRACER_THETAL_QT) ATD1F400.66
ATMDYN1.632
IF(LTIMER) THEN ATMDYN1.633
CALL TIMER('DIF_CTL ',4) ATMDYN1.634
CALL TIMER('DIFFUSION',6) GPB1F401.18
END IF ATMDYN1.635
ATMDYN1.636
IF(.NOT.L_TRACER_THETAL_QT)THEN ATD1F400.67
C IF NOT TRACER QT THEN CALL QTPOS TO REMOVE NEGATIVE HUMIDITY ATD1F400.68
CL --------------------------------------------------------------------- ATMDYN1.637
CL 13.2 call QT_POS to remove negative humidity ATMDYN1.638
CL --------------------------------------------------------------------- ATMDYN1.639
ATMDYN1.640
IF(LTIMER) THEN ATMDYN1.641
CALL TIMER('QT_POS ',3) ATMDYN1.642
END IF ATMDYN1.643
ATMDYN1.644
CALL QT_POS_CTL( APB6F401.1
& D1(JQ(1)),RS_FUNCTIONS,ROW_LENGTH,P_FIELD,Q_LEVELS, APB6F401.2
*CALL ARGFLDPT APB6F401.3
& ICODE,CMESSAGE,COS_P_LATITUDE,SEC_P_LATITUDE, APB6F401.4
& L_NEG_QT,L_QT_POS_LOCAL, APB6F401.5
& LOCAL_ADVSTEP,SF(201,13),STASHWORK(SI(201,13,im_index))) ARB0F400.32
ATMDYN1.649
IF (L_WRIT_DYN .AND. WRITD1_THIS_SWEEP .AND. ARR2F405.33
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1346
TJ270193.63
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1347
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1348
GSS1F304.1349
CALL DUMPCTL ( GKR4F403.151
*CALL ARGSIZE GKR4F403.152
*CALL ARGD1 GKR4F403.153
*CALL ARGDUMA GKR4F403.154
*CALL ARGDUMO GKR4F403.155
*CALL ARGDUMW GKR4F403.156
*CALL ARGCONA GKR4F403.157
*CALL ARGPTRA GKR4F403.158
*CALL ARGSTS GKR4F403.159
*CALL ARGPPX GKR4F403.160
& atmos_sm,0,.TRUE.,'af_qt_pos_',a_step, GIE1F405.3
& ICODE,CMESSAGE) GKR4F403.162
GSS1F304.1351
END IF GSS1F304.1352
GSS1F304.1353
END IF GSS1F304.1354
GSS1F304.1355
IF(LTIMER) THEN ATMDYN1.650
CALL TIMER('QT_POS ',4) ATMDYN1.651
END IF ATMDYN1.652
ATMDYN1.653
IF(ICODE.GT.0) THEN ATMDYN1.654
RETURN ATMDYN1.655
END IF ATMDYN1.656
END IF ATD1F400.69
ATMDYN1.657
IF(L_NEG_THETA) THEN ATMDYN1.658
DO K=1,P_LEVELS ATMDYN1.659
*IF -DEF,MPP APB0F401.79
INEG_THETA=1 APB0F305.40
DO I=1,P_FIELD ATMDYN1.663
IF(D1(JTHETA(K)+I-1).LT.0.0) THEN APB0F401.83
L_NEG_THETA_FOUND=.TRUE. APB0F401.84
GOTO 132 APB0F401.85
ENDIF APB0F401.86
INEG_THETA=I +1 ATMDYN1.665
END DO ATMDYN1.666
*ELSE APB0F305.42
! New version of the check for negative theta - doesn't look at halos APB0F305.43
INEG_THETA=1 APB0F401.81
L_NEG_THETA_FOUND=.FALSE. APB0F401.82
DO J=NS_Halo+1,P_ROWS-NS_Halo APB0F401.87
I_start=(J-1)*ROW_LENGTH + FIRST_ROW_PT APB0F401.88
I_end=(J-1)*ROW_LENGTH + LAST_ROW_PT APB0F401.89
DO I=I_start,I_end APB0F401.90
INEG_THETA=I APB0F401.91
IF (D1(JTHETA(K)+I-1).LT.0.0) THEN APB0F401.92
L_NEG_THETA_FOUND=.TRUE. APB0F401.93
GOTO 132 APB0F401.94
ENDIF APB0F401.95
ENDDO APB0F401.96
ENDDO APB0F401.97
*ENDIF APB0F305.52
132 CONTINUE ATMDYN1.667
*IF -DEF,MPP GSS9F402.91
IF(INEG_THETA.NE.P_FIELD+1) THEN ATMDYN1.669
*ELSE APB0F401.99
IF(L_NEG_THETA_FOUND) THEN APB0F401.100
*ENDIF APB0F401.101
*IF DEF,MPP APB0F401.102
WRITE(6,*) ' Processor ',MY_PROC_ID,' has found negative THETA' GIE0F403.88
*ENDIF APB0F401.104
WRITE(6,*)'NEGATIVE THETA AT POINT',INEG_THETA,' LEVEL ',K GIE0F403.89
ICODE = 1 ATMDYN1.671
ENDIF ATMDYN1.674
END DO ATMDYN1.675
*IF DEF,MPP APB0F401.105
! Add PE number to ICODE and broadcast to PE0 GSM2F405.3
IF (ICODE .GT. 0) ICODE=ICODE+MY_PROC_ID GSM2F405.4
CALL GC_IMAX(1,N_PROCS,info,ICODE) APB0F401.106
*ENDIF APB0F401.107
IF (ICODE .GT. 0) THEN GSM2F405.5
*IF DEF,MPP GSM2F405.6
WRITE(6,*)'NEGATIVE THETA DETECTED IN PE ',ICODE-1 GSM2F405.7
WRITE(6,*)'Check output from all PEs for full details' GSM2F405.8
ICODE=1 GSM2F405.9
*ENDIF GSM2F405.10
CMESSAGE='ATM_DYN : NEGATIVE THETA DETECTED. ' GSM2F405.11
RETURN GSM2F405.12
END IF GSM2F405.13
END IF ATMDYN1.676
ATMDYN1.677
*IF DEF,GLOBAL ATMDYN1.678
ATMDYN1.679
CL --------------------------------------------------------------------- ATMDYN1.680
CL 13.3 call FILT_UV to filter ATMDYN1.681
CL --------------------------------------------------------------------- ATMDYN1.682
ATMDYN1.683
IF(LTIMER) THEN ATMDYN1.684
CALL TIMER('FILT_UV ',3) ATMDYN1.685
END IF ATMDYN1.686
ATMDYN1.687
CALL FILT_UV( ATMDYN1.688
*IF DEF,A13_1C AAD2F404.318
& D1(JPSTAR),D1(JU(1)),D1(JV(1)),WORK4, AAD2F404.319
*ELSE AAD2F404.320
& D1(JPSTAR),D1(JU(1)),D1(JV(1)),RS_FUNCTIONS, ATMDYN1.689
*ENDIF AAD2F404.321
& A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK), ATMDYN1.690
& P_FIELD,U_FIELD, ATMDYN1.691
& A_INTHD(19),A_INTHD(20), ATMDYN1.692
& P_LEVELS,ROW_LENGTH, APB7F401.121
*CALL ARGFLDPT APB7F401.122
& TRIGS,IFAX,COS_LONGITUDE,SIN_LONGITUDE, APB7F401.123
& A_ROWDEPC(JFILTER_WAVE_NUMBER_U_ROWS)) ATMDYN1.695
*IF DEF,MPP APB0F401.109
! Swap required to renew halos on U,V after new values from filter APB0F401.110
CALL SWAPBOUNDS(D1(JU(1)),ROW_LENGTH,P_ROWS, APB0F401.111
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.112
CALL SWAPBOUNDS(D1(JV(1)),ROW_LENGTH,P_ROWS, APB0F401.113
& EW_Halo,NS_Halo,P_LEVELS) APB0F401.114
*ENDIF APB0F401.115
TJ270193.64
IF (L_WRIT_DYN .AND. WRITD1_THIS_SWEEP .AND. ARR2F405.34
& (A_STEP.LE.T_WRITD1_END .OR. T_WRITD1_END .EQ. 0)) THEN GSS1F304.1357
GSS1F304.1358
IF (A_STEP.EQ.T_WRITD1_START .OR. GSS1F304.1359
& WRITD1_TEST.GT.WRITD1_TEST_PREV) THEN GSS1F304.1360
GSS1F304.1361
CALL DUMPCTL ( GKR4F403.163
*CALL ARGSIZE GKR4F403.164
*CALL ARGD1 GKR4F403.165
*CALL ARGDUMA GKR4F403.166
*CALL ARGDUMO GKR4F403.167
*CALL ARGDUMW GKR4F403.168
*CALL ARGCONA GKR4F403.169
*CALL ARGPTRA GKR4F403.170
*CALL ARGSTS GKR4F403.171
*CALL ARGPPX GKR4F403.172
& atmos_sm,0,.TRUE.,'af_filt_uv',a_step, GIE1F405.4
& ICODE,CMESSAGE) GKR4F403.174
GSS1F304.1363
END IF GSS1F304.1364
GSS1F304.1365
END IF GSS1F304.1366
ATMDYN1.696
IF(LTIMER) THEN ATMDYN1.697
CALL TIMER('FILT_UV ',4) ATMDYN1.698
END IF ATMDYN1.699
ATMDYN1.700
*ELSE ARB2F402.3
*IF DEF,MPP ARB2F402.4
! Swap required to renew halos on U,V because of new values from FILTER ARB2F402.5
CALL SWAPBOUNDS(D1(JU(1)),ROW_LENGTH,P_ROWS, ARB2F402.6
& EW_Halo,NS_Halo,P_LEVELS) ARB2F402.7
CALL SWAPBOUNDS(D1(JV(1)),ROW_LENGTH,P_ROWS, ARB2F402.8
& EW_Halo,NS_Halo,P_LEVELS) ARB2F402.9
*ENDIF ARB2F402.10
*ENDIF ATMDYN1.701
ATMDYN1.702
END DO ! I_COUNT ARB0F400.33
CL --------------------------------------------------------------------- ATMDYN1.703
CL call stash to output diagnostics, and complete routine ATMDYN1.704
CL --------------------------------------------------------------------- ATMDYN1.705
ATMDYN1.706
! Call STASH only on last sweep of long physics timestep. ARB0F400.34
IF (I_LOOP.eq.A_SWEEPS_DYN) THEN ARB0F400.35
ARB0F400.36
IF(LTIMER) THEN ATMDYN1.707
CALL TIMER('STASH ',3) ATMDYN1.708
END IF ATMDYN1.709
ATMDYN1.710
CALL STASH(a_sm,a_im,13,STASHWORK, GKR0F305.886
*CALL ARGSIZE @DYALLOC.316
*CALL ARGD1 @DYALLOC.317
*CALL ARGDUMA @DYALLOC.318
*CALL ARGDUMO @DYALLOC.319
*CALL ARGDUMW GKR1F401.171
*CALL ARGSTS @DYALLOC.320
*CALL ARGPPX GKR0F305.887
& ICODE,CMESSAGE) @DYALLOC.324
ATMDYN1.712
IF(LTIMER) THEN ATMDYN1.713
CALL TIMER('STASH ',4) ATMDYN1.714
END IF ATMDYN1.715
ATMDYN1.716
IF(L_TRACER_THETAL_QT)THEN ATD1F400.70
C IF TRACER ADVECTION CHECK FOR NEGATIVE Q AFTER DYNAMICS ATD1F400.71
DO K=1,Q_LEVELS ATD1F400.72
II=0 ATD1F400.73
IQNEG(1)=0 ATD1F400.74
DO I=1,P_FIELD ATD1F400.75
IF(D1(JQ(K)+I-1).LT.0.0) THEN ATD1F400.76
II=II+1 ATD1F400.77
IQNEG(II)=I ATD1F400.78
ENDIF ATD1F400.79
ENDDO ATD1F400.80
IF(II.NE.0) THEN ATD1F400.81
WRITE(6,*) 'AFTER DYNAMICS:' ATD1F400.82
WRITE(6,*) 'NEGATIVE QT LEVEL ',K,' POINTS ',(IQNEG(I),I=1,II) ATD1F400.83
END IF ATD1F400.84
END DO ATD1F400.85
END IF ATD1F400.86
IF(ICODE.GT.0) THEN ATMDYN1.717
RETURN ATMDYN1.718
END IF ATMDYN1.719
ARB0F400.37
END IF ! I_LOOP.eq.A_SWEEPS_DYN ARB0F400.38
ATMDYN1.720
GPB3F403.29
ENDDO ! I_LOOP : loop over multiple dynamics timesteps GPB3F403.30
GPB3F403.31
RETURN ATMDYN1.721
END ATMDYN1.722
CLL Subroutine MAXWIND------------------------------------------- AL131293.127
CLL AL131293.128
CLL Purpose: Subroutine for use with half timestep dynamics. AL131293.129
CLL Checks wind speed, starting from the top level, AL131293.130
CLL to see if it exceeds IMAX. AL131293.131
CLL If this value is exceeded, L_WIND is set to .TRUE. AL131293.132
CLL and control is returned to the main program. AL131293.133
CLL AL131293.134
CLL Model Modification history: AL131293.135
CLL version Date AL131293.136
CLL 3.3 13/12/93 Written by A.S.Lawless AL131293.137
CLL 4.1 02/04/96 Added START and END arguments P.Burton APB0F401.116
CLL AL131293.138
CLL Programming standard: UMDP No 3 AL131293.139
CLL AL131293.140
CLL System components covered: P1 AL131293.141
CLL AL131293.142
CLL System task: P0 AL131293.143
CLL AL131293.144
CLLEND----------------------------------------------------------- AL131293.145
C*L Arguments--------------------------------------------------- AL131293.146
SUBROUTINE MAXWIND(L_WIND,WMAX,U,V,U_FIELD,START,END,P_LEVELS) 1APB0F401.117
INTEGER AL131293.148
& U_FIELD ! DIMENSION OF FIELD ON VELOCITY GRID AL131293.149
&,P_LEVELS ! NUMBER OF PRESSURE LEVELS AL131293.150
&,START ! Point to start check at APB0F401.118
&,END ! Point to end check at APB0F401.119
REAL AL131293.151
& U(U_FIELD,P_LEVELS) ! U FIELD AL131293.152
&,V(U_FIELD,P_LEVELS) ! V FIELD AL131293.153
&,WMAX ! MAXIMUM WIND TO TEST AGAINST AL131293.154
LOGICAL AL131293.155
& L_WIND ! SET TO TRUE IF WIND EXCEEDS LIMIT AL131293.156
C*--------------------------------------------------------------- AL131293.157
C*L Define local variables AL131293.158
INTEGER AL131293.159
& I,K ! LOOP VARIABLES AL131293.160
REAL AL131293.161
& WSQ ! SQUARE OF WIND AL131293.162
&,WMAXSQ ! SQUARE OF WMAX AL131293.163
C---------------------------------------------------------------- AL131293.164
WMAXSQ=WMAX*WMAX AL131293.165
K=P_LEVELS AL131293.166
DO WHILE ((.NOT.L_WIND).AND.(K.GT.0)) AL131293.167
DO I=START,END APB0F401.120
WSQ=U(I,K)*U(I,K)+V(I,K)*V(I,K) AL131293.169
IF (WSQ.GT.WMAXSQ) L_WIND=.TRUE. AL131293.170
END DO AL131293.171
K=K-1 AL131293.172
END DO AL131293.173
C AL131293.174
RETURN AL131293.175
END AL131293.176
C AL131293.177
CLL Subroutine DIVTEST--------------------------------------------- AL131293.178
CLL AL131293.179
CLL PURPOSE: To test if the input field exceeds AL131293.180
CLL the input limit. If so, the logical variable AL131293.181
CLL L_DIVERG is returned as true. AL131293.182
CLL AL131293.183
CLL 13/12/93 Written by A.S.Lawless AL131293.184
CLL 4.1 02/04/96 Removed unused ROW_LENGTH argument P.Burton APB0F401.121
CLL AL131293.185
CLL Programming standard: UMDP No 3 AL131293.186
CLL AL131293.187
CLL System components covered: P1 AL131293.188
CLL System task: P0 AL131293.189
CLL AL131293.190
CLLEND------------------------------------------------------------- AL131293.191
C*L Arguments:----------------------------------------------------- AL131293.192
SUBROUTINE DIVTEST(P_FIELD,START,END,FIELD,LIMIT,L_DIVERG) 1APB0F401.122
APB0F401.123
INTEGER APB0F401.124
& P_FIELD ! SIZE OF FIELD ON P POINTS APB0F401.125
& ,START ! FIRST POINT TO CHECK AL131293.199
& ,END ! LAST POINT TO CHECK AL131293.200
REAL AL131293.201
& FIELD(P_FIELD) ! INPUT FIELD AL131293.202
& ,LIMIT ! INPUT LIMIT AL131293.203
LOGICAL AL131293.204
& L_DIVERG ! RETURN AS TRUE IF FIELD EXCEEDS LIMIT AL131293.205
C*----------------------------------------------------------------- AL131293.206
C*L LOCAL VARIABLES AL131293.207
INTEGER I AL131293.208
C------------------------------------------------------------------ AL131293.209
L_DIVERG=.FALSE. AL131293.210
DO I=START,END AL131293.211
IF(ABS(FIELD(I)).GT.LIMIT) L_DIVERG=.TRUE. AL131293.212
END DO AL131293.213
C AL131293.214
RETURN AL131293.215
END AL131293.216
*ENDIF ATMDYN1.723