SUBROUTINE AC_CTL(INT18,TR_VARSDA,P_FIELDDA,Q_LEVELSDA, 1,34ABM3F400.51
*CALL ARGSIZE 
@DYALLOC.193
*CALL ARGD1 @DYALLOC.194
*CALL ARGDUMA @DYALLOC.195
*CALL ARGDUMO @DYALLOC.196
*CALL ARGDUMW GKR1F401.163
*CALL ARGSTS @DYALLOC.197
*CALL ARGPTRA @DYALLOC.198
*CALL ARGPTRO @DYALLOC.199
*CALL ARGCONA @DYALLOC.200
*CALL ARGPPX GKR0F305.874
& ICODE, CMESSAGE) @DYALLOC.201
IMPLICIT NONE AC_CTL1.19
@DYALLOC.202
*CALL CMAXSIZE @DYALLOC.203
*CALL CSUBMODL GSS2F305.94
*CALL TYPSIZE @DYALLOC.204
*CALL TYPD1 @DYALLOC.205
*CALL TYPDUMA @DYALLOC.206
*CALL TYPDUMO @DYALLOC.207
*CALL TYPDUMW GKR1F401.164
*CALL TYPSTS @DYALLOC.208
*CALL TYPPTRA @DYALLOC.209
*CALL TYPPTRO @DYALLOC.210
*CALL TYPCONA @DYALLOC.211
*CALL PPXLOOK GKR0F305.875
AC_CTL1.20
INTEGER INT18 ! Dummy variable for STASH_MAXLEN(18) AC_CTL1.21
INTEGER TR_VARSDA ! Copy of TR_VARS for dynamic allocn. ANF1F304.6
INTEGER P_FIELDDA,Q_LEVELSDA ABM3F400.52
INTEGER ICODE ! Return code : 0 Normal Exit AC_CTL1.22
c ! : > 0 Error AC_CTL1.23
AC_CTL1.24
CHARACTER*(*) CMESSAGE ! Error message if return code >0 AC_CTL1.25
AC_CTL1.26
*CALL C_MDI TJ050593.6
*CALL CHSUNITS RS030293.133
*CALL CCONTROL AC_CTL1.28
*CALL CTIME @DYALLOC.212
*CALL CSIZEOBS AC_CTL1.33
*CALL CHISTORY GDR3F305.5
*CALL CTRACERA ARSAF304.4
*CALL CRUNTIMC ADR1F305.3
AC_CTL1.35
*CALL C_LHEAT ABM3F400.53
*CALL C_R_CP ABM3F400.54
*CALL ACPARM ABM3F400.55
*CALL COMACP ABM3F400.56
CL External subroutines called AC_CTL1.36
EXTERNAL AC, TIMER, STASH ,STRATQ , FINDPTR AC_CTL1.37
EXTERNAL THETL_QT,GLUE_CLD ABM3F400.57
*IF DEF,MPP ASB1F403.4
EXTERNAL SWAPBOUNDS_shmem,SWAPBOUNDS ARB0F404.11
*ENDIF ASB1F403.6
AC_CTL1.38
CL Dynamically allocated area for stash processing AC_CTL1.39
REAL STASHWORK(INT18) AC_CTL1.40
ARSAF304.5
CL Dynamically allocated area for tracer pointers ARSAF304.6
INTEGER TR_SIZE ! Full size of tracer data ARSAF304.7
! no. tracers * levels * fields ARSAF304.8
! (set to 1 if no tracers) ARSAF304.9
INTEGER I_TRACER_ADDRESS (TR_VARSDA+1) ARSAF304.10
! Addresses in full tracer array ARSAF304.11
! for each tracer variable in ARSAF304.12
! use (add 1 to length to avoid ARSAF304.13
! null array) ARSAF304.14
INTEGER I_TRACER_ITEM (TR_VARSDA+1) ARSAF304.15
! STASH item code for each ARSAF304.16
! tracer variable in use ARSAF304.17
! (add 1 to length to avoid ARSAF304.18
! null array) ARSAF304.19
AC_CTL1.41
INTEGER AC_CTL1.42
& STASHMACRO_TAG, ! STASHmacro tag number AC_CTL1.43
& MDI, ! Missing data indicator AC_CTL1.44
& JU10M,JV10M,JT1P5M ! addresses returned from FINDPTR AC_CTL1.45
& ,JRH1P5M ! address returned from FINDPTR AC_CTL1.46
& ,JLSRR,JLSSR,JCVRR,JCVSR ! addresses returned from FINDPTR SB151293.3
& ,JSRA,JCONVCC,JVS1P5M ! addresses returned from FINDPTR ABM1F304.8
& ,JTIC ! addresses returned from FINDPTR ABM3F400.58
& ,JQCL_P,JQCF_P ! addresses returned from FINDPTR ABM3F400.59
& ,JQCL_BL,JQCF_BL ! addresses returned from FINDPTR ABM3F400.60
& ,JQCL_BD,JQCF_BD ! addresses returned from FINDPTR ABM3F400.61
& ,JQCL_DC,JQCF_DC ! addresses returned from FINDPTR ABM3F400.62
& ,JT_BL,JT_P ! addresses returned from FINDPTR ABM3F400.63
& ,K, ERROR ! do loop variable/ error ABM3F400.64
AC_CTL1.47
INTEGER J ! DO Loop Variable. AC_CTL1.48
INTEGER I, IIND ! temporary scalars ARSAF304.20
INTEGER im_index ! Internal model index GSS2F305.95
INTEGER IADDR_SMC, IADDR_TSURF, LEN_TSURF AFF2F401.3
REAL WORK(P_FIELDDA,Q_LEVELSDA) ! array for large-scale ABM3F400.65
! latent heating ABM3F400.66
!(first used for glue_cld output not reqd later) ABM3F400.67
REAL WORK2(P_FIELDDA,Q_LEVELSDA) ! arrays for output ABM3F400.68
REAL WORK3(P_FIELDDA,Q_LEVELSDA) ! from glue_cld ABM3F400.69
REAL ZERO_FIELD(P_FIELDDA,Q_LEVELSDA) ! use if mixed phase precip ADM2F404.14
REAL PU,PL ! temporary variables in exner calculations ABM3F400.70
*CALL P_EXNERC ABM3F400.71
CL AC_CTL1.49
CL 1.0 Get address for each field from its STASH section/item code AC_CTL1.50
CL and STASHmacro tag (searching only on STASHmacro tag) AC_CTL1.51
MDI = IMDI TJ050593.7
STASHMACRO_TAG = 30 AC_CTL1.53
AC_CTL1.54
C Initialise STASHWORK for section 18. AC_CTL1.55
DO J = 1, INT18 AC_CTL1.56
STASHWORK(J) = RMDI TJ050593.8
AC_CTL1.58
END DO AC_CTL1.59
AC_CTL1.60
CL 1.1 U10m AC_CTL1.61
CALL FINDPTR (A_IM,3, 225, GSS2F305.96
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, AC_CTL1.63
& STASHMACRO_TAG,MDI,JU10M, @DYALLOC.213
*CALL ARGSIZE @DYALLOC.214
*CALL ARGSTS @DYALLOC.215
& ICODE,CMESSAGE) @DYALLOC.216
AC_CTL1.67
IF (JU10M .EQ. 0) THEN AC_CTL1.68
ICODE = 3225 AC_CTL1.69
CMESSAGE = "AC_CTL: 10m U-wind not available for use by AC" AC_CTL1.70
AC_CTL1.71
END IF AC_CTL1.72
AC_CTL1.73
IF (ICODE .GT. 0) GOTO 999 AC_CTL1.74
AC_CTL1.75
CL 1.2 V10m AC_CTL1.76
CALL FINDPTR (A_IM,3, 226, GSS2F305.97
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, AC_CTL1.78
& STASHMACRO_TAG,MDI,JV10M, @DYALLOC.217
*CALL ARGSIZE @DYALLOC.218
*CALL ARGSTS @DYALLOC.219
& ICODE,CMESSAGE) @DYALLOC.220
AC_CTL1.82
IF (JV10M .EQ. 0) THEN AC_CTL1.83
ICODE = 3226 AC_CTL1.84
CMESSAGE = "AC_CTL: 10m V-wind not available for use by AC" AC_CTL1.85
AC_CTL1.86
END IF AC_CTL1.87
AC_CTL1.88
IF (ICODE .GT. 0) GOTO 999 AC_CTL1.89
AC_CTL1.90
CL 1.3 T1.5m AC_CTL1.91
CALL FINDPTR(A_IM, 3,236, GSS2F305.98
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, AC_CTL1.93
& STASHMACRO_TAG,MDI,JT1P5M, @DYALLOC.221
*CALL ARGSIZE @DYALLOC.222
*CALL ARGSTS @DYALLOC.223
& ICODE,CMESSAGE) @DYALLOC.224
AC_CTL1.97
IF (JT1P5M .EQ. 0) THEN AC_CTL1.98
ICODE = 3236 AC_CTL1.99
CMESSAGE = "AC_CTL: 1.5m temp not available for use by AC" AC_CTL1.100
AC_CTL1.101
END IF AC_CTL1.102
AC_CTL1.103
IF (ICODE .GT. 0) GOTO 999 AC_CTL1.104
AC_CTL1.105
CL 1.4 RH1.5m SB151293.4
CALL FINDPTR (A_IM,3, 245, GSS2F305.99
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, AC_CTL1.108
& STASHMACRO_TAG,MDI,JRH1P5M, @DYALLOC.225
*CALL ARGSIZE @DYALLOC.226
*CALL ARGSTS @DYALLOC.227
& ICODE,CMESSAGE) @DYALLOC.228
AC_CTL1.112
IF (JRH1P5M .EQ. 0) THEN AC_CTL1.113
ICODE = 3245 AC_CTL1.114
CMESSAGE = "AC_CTL: 1.5m rh not available for use by AC" AC_CTL1.115
AC_CTL1.116
END IF AC_CTL1.117
AC_CTL1.118
IF (ICODE .GT. 0) GOTO 999 AC_CTL1.119
AC_CTL1.120
CL 1.5 large scale rainfall rate SB151293.5
CALL FINDPTR(A_IM, 4,203, GSS2F305.100
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, SB151293.7
& STASHMACRO_TAG,MDI,JLSRR, SB151293.8
*CALL ARGSIZE SB151293.9
*CALL ARGSTS SB151293.10
& ICODE,CMESSAGE) SB151293.11
SB151293.12
IF (JLSRR .EQ. 0) THEN SB151293.13
ICODE = 4203 SB151293.14
CMESSAGE = "AC_CTL: large scale rainfall rate not available" SB151293.15
SB151293.16
END IF SB151293.17
SB151293.18
IF (ICODE .GT. 0) GOTO 999 SB151293.19
SB151293.20
CL 1.6 large scale snowfall rate SB151293.21
CALL FINDPTR(A_IM, 4,204, GSS2F305.101
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, SB151293.23
& STASHMACRO_TAG,MDI,JLSSR, SB151293.24
*CALL ARGSIZE SB151293.25
*CALL ARGSTS SB151293.26
& ICODE,CMESSAGE) SB151293.27
SB151293.28
IF (JLSSR .EQ. 0) THEN SB151293.29
ICODE = 4204 SB151293.30
CMESSAGE = "AC_CTL: large scale snowfall rate not available" SB151293.31
SB151293.32
END IF SB151293.33
SB151293.34
IF (ICODE .GT. 0) GOTO 999 SB151293.35
SB151293.36
CL 1.7 convective rainfall rate SB151293.37
CALL FINDPTR(A_IM, 5,205, GSS2F305.102
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, SB151293.39
& STASHMACRO_TAG,MDI,JCVRR, SB151293.40
*CALL ARGSIZE SB151293.41
*CALL ARGSTS SB151293.42
& ICODE,CMESSAGE) SB151293.43
SB151293.44
IF (JCVRR .EQ. 0) THEN SB151293.45
ICODE = 5205 SB151293.46
CMESSAGE = "AC_CTL: convective rainfall rate not available" SB151293.47
SB151293.48
END IF SB151293.49
SB151293.50
IF (ICODE .GT. 0) GOTO 999 SB151293.51
SB151293.52
CL 1.8 convective snowfall rate SB151293.53
CALL FINDPTR(A_IM, 5,206, GSS2F305.103
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, SB151293.55
& STASHMACRO_TAG,MDI,JCVSR, SB151293.56
*CALL ARGSIZE SB151293.57
*CALL ARGSTS SB151293.58
& ICODE,CMESSAGE) SB151293.59
SB151293.60
IF (JCVSR .EQ. 0) THEN SB151293.61
ICODE = 5206 SB151293.62
CMESSAGE = "AC_CTL: convective snowfall rate not available" SB151293.63
SB151293.64
END IF SB151293.65
SB151293.66
IF (ICODE .GT. 0) GOTO 999 SB151293.67
SB151293.68
CL 1.9 surface run-off amount ABM1F304.9
CALL FINDPTR(A_IM, 8,204, GSS2F305.104
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM1F304.11
& STASHMACRO_TAG,MDI,JSRA, ABM1F304.12
*CALL ARGSIZE ABM1F304.13
*CALL ARGSTS ABM1F304.14
& ICODE,CMESSAGE) ABM1F304.15
ABM1F304.16
IF (JSRA .EQ. 0) THEN ABM1F304.17
ICODE = 8204 ABM1F304.18
CMESSAGE = "AC_CTL: surface runoff amount not available" ABM1F304.19
ABM1F304.20
END IF ABM1F304.21
ABM1F304.22
IF (ICODE .GT. 0) GOTO 999 ABM1F304.23
ABM1F304.24
CL 1.10 convective cloud cover on each model level ABM1F304.25
CALL FINDPTR(A_IM, 5,212, GSS2F305.105
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM1F304.27
& STASHMACRO_TAG,MDI,JCONVCC, ABM1F304.28
*CALL ARGSIZE ABM1F304.29
*CALL ARGSTS ABM1F304.30
& ICODE,CMESSAGE) ABM1F304.31
ABM1F304.32
IF (JCONVCC .EQ. 0) THEN ABM1F304.33
ICODE = 5212 ABM1F304.34
CMESSAGE = "AC_CTL: convective cloud amount not available" ABM1F304.35
ABM1F304.36
END IF ABM1F304.37
ABM1F304.38
IF (ICODE .GT. 0) GOTO 999 ABM1F304.39
ABM1F304.40
CL 1.11 VIS1.5m ABM1F304.41
CALL FINDPTR (A_IM, 3,247, GSS2F305.106
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM1F304.43
& STASHMACRO_TAG,MDI,JVS1P5M, ABM1F304.44
*CALL ARGSIZE ABM1F304.45
*CALL ARGSTS ABM1F304.46
& ICODE,CMESSAGE) ABM1F304.47
ABM1F304.48
IF (JVS1P5M .EQ. 0) THEN ABM1F400.3
ICODE = 3247 ABM1F400.4
CMESSAGE = "AC_CTL: 1.5m vis not available for use by AC" ABM1F400.5
ABM1F400.6
END IF ABM1F400.7
ABM1F400.8
IF (ICODE .GT. 0) GOTO 999 ABM1F400.9
ABM1F400.10
CL 1.12 tracers ARSAF304.21
ARSAF304.22
C If there are no tracers (TR_VARS=0), TR_SIZE (size of tracer ARSAF304.23
C array) is set to 1. ARSAF304.24
C Also, the pointers are set to dummy values (see later). ARSAF304.25
ARSAF304.26
IF (TR_VARS.EQ.0) THEN ARSAF304.27
TR_SIZE=1 ARSAF304.28
ARSAF304.29
ELSE ARSAF304.30
TR_SIZE=TR_VARS*TR_LEVELS*P_FIELD ARSAF304.31
ARSAF304.32
C For each tracer in use, set up tracer address and item code ARSAF304.33
I=0 ! count tracers in use ARSAF304.34
im_index=internal_model_index(A_IM) GSS2F305.107
DO J = A_TRACER_FIRST, A_TRACER_LAST ARSAF304.35
IF(SI(J,0,im_index).NE.1) THEN ! tracer in use GSS2F305.108
I=I+1 ARSAF304.37
IIND=J-A_TRACER_FIRST+1 ARSAF304.38
I_TRACER_ADDRESS(I)=JTRACER(1,A_TR_INDEX(IIND)) ARSAF304.39
I_TRACER_ITEM(I)=J ARSAF304.40
END IF ARSAF304.41
END DO ARSAF304.42
ARSAF304.43
C Number of tracers should correspond to TR_VARS ARSAF304.44
IF (I.NE.TR_VARS) THEN ARSAF304.45
ICODE=4600 ARSAF304.46
CMESSAGE = 'AC_CTL: tracers in use is not TR_VARS' ARSAF304.47
GO TO 999 ARSAF304.48
END IF ARSAF304.49
ARSAF304.50
C Tracer addresses are now relative to start of D1; make them ARSAF304.51
C relative to start of tracer array ARSAF304.52
DO J=1,TR_VARS ARSAF304.53
I_TRACER_ADDRESS(J)=I_TRACER_ADDRESS(J)-JTRACER(1,1)+1 ARSAF304.54
END DO ARSAF304.55
END IF ARSAF304.56
ARSAF304.57
C Set last (or only) values in tracer pointer arrays ARSAF304.58
I_TRACER_ADDRESS(TR_VARS+1)=1 ARSAF304.59
I_TRACER_ITEM (TR_VARS+1)=MDI ARSAF304.60
ARSAF304.61
IF( L_LHN ) THEN ABM3F400.72
! seek convective heating rate and ABM3F400.73
! diagnostics for calculating large-scale latent heating rate ABM3F400.74
ABM3F400.75
CL 1.13 theta increments from convection ABM3F400.76
CALL FINDPTR( A_IM,5,203, ABM3F400.77
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.78
& STASHMACRO_TAG,MDI,JTIC, ABM3F400.79
*CALL ARGSIZE ABM3F400.80
*CALL ARGSTS ABM3F400.81
& ICODE,CMESSAGE) ABM3F400.82
ABM3F400.83
IF (JTIC .EQ. 0) THEN ABM3F400.84
ICODE = 5203 ABM3F400.85
CMESSAGE = "AC_CTL: theta incrs from conv'n not available" ABM3F400.86
ABM3F400.87
END IF ABM3F400.88
ABM3F400.89
IF (ICODE .GT. 0) GOTO 999 ABM3F400.90
ABM3F400.91
CL 1.14 cloud liquid water after large-scale precipitation ABM3F400.92
CALL FINDPTR( A_IM,4,205, ABM3F400.93
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.94
& STASHMACRO_TAG,MDI,JQCL_P, ABM3F400.95
*CALL ARGSIZE ABM3F400.96
*CALL ARGSTS ABM3F400.97
& ICODE,CMESSAGE) ABM3F400.98
ABM3F400.99
IF (JQCL_P .EQ. 0) THEN ABM3F400.100
ICODE = 4205 ABM3F400.101
CMESSAGE = "AC_CTL: cld lqd wtr after ls_ppn not available" ABM3F400.102
ABM3F400.103
END IF ABM3F400.104
ABM3F400.105
IF (ICODE .GT. 0) GOTO 999 ABM3F400.106
ABM3F400.107
CL 1.15 cloud ice after large-scale precipitation ABM3F400.108
CALL FINDPTR( A_IM,4,206, ABM3F400.109
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.110
& STASHMACRO_TAG,MDI,JQCF_P, ABM3F400.111
*CALL ARGSIZE ABM3F400.112
*CALL ARGSTS ABM3F400.113
& ICODE,CMESSAGE) ABM3F400.114
ABM3F400.115
IF (JQCF_P .EQ. 0) THEN ABM3F400.116
ICODE = 4206 ABM3F400.117
CMESSAGE = "AC_CTL: cld ice after ls_ppn not available" ABM3F400.118
ABM3F400.119
END IF ABM3F400.120
ABM3F400.121
IF (ICODE .GT. 0) GOTO 999 ABM3F400.122
ABM3F400.123
CL 1.16 temp after large-scale precipitation ABM3F400.124
CALL FINDPTR( A_IM,4,004, ABM3F400.125
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.126
& STASHMACRO_TAG,MDI,JT_P, ABM3F400.127
*CALL ARGSIZE ABM3F400.128
*CALL ARGSTS ABM3F400.129
& ICODE,CMESSAGE) ABM3F400.130
ABM3F400.131
IF (JT_P .EQ. 0) THEN ABM3F400.132
ICODE = 4004 ABM3F400.133
CMESSAGE = "AC_CTL: temp after ls_ppn not available" ABM3F400.134
ABM3F400.135
END IF ABM3F400.136
ABM3F400.137
IF (ICODE .GT. 0) GOTO 999 ABM3F400.138
ABM3F400.139
CL 1.17 cloud liquid water after boundary layer ABM3F400.140
CALL FINDPTR( A_IM,3,239, ABM3F400.141
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.142
& STASHMACRO_TAG,MDI,JQCL_BL, ABM3F400.143
*CALL ARGSIZE ABM3F400.144
*CALL ARGSTS ABM3F400.145
& ICODE,CMESSAGE) ABM3F400.146
ABM3F400.147
IF (JQCL_BL.EQ. 0) THEN ABM3F400.148
ICODE = 3239 ABM3F400.149
CMESSAGE = "AC_CTL: cld lqd wtr after b_lyr not available" ABM3F400.150
ABM3F400.151
END IF ABM3F400.152
ABM3F400.153
IF (ICODE .GT. 0) GOTO 999 ABM3F400.154
ABM3F400.155
CL 1.18 cloud ice after boundary layer ABM3F400.156
CALL FINDPTR( A_IM,3,240, ABM3F400.157
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.158
& STASHMACRO_TAG,MDI,JQCF_BL, ABM3F400.159
*CALL ARGSIZE ABM3F400.160
*CALL ARGSTS ABM3F400.161
& ICODE,CMESSAGE) ABM3F400.162
ABM3F400.163
IF (JQCF_BL.EQ. 0) THEN ABM3F400.164
ICODE = 3240 ABM3F400.165
CMESSAGE = "AC_CTL: cld ice after b_lyr not available" ABM3F400.166
ABM3F400.167
END IF ABM3F400.168
ABM3F400.169
IF (ICODE .GT. 0) GOTO 999 ABM3F400.170
ABM3F400.171
CL 1.19 temp after boundary layer ABM3F400.172
CALL FINDPTR( A_IM,3,004, ABM3F400.173
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.174
& STASHMACRO_TAG,MDI,JT_BL, ABM3F400.175
*CALL ARGSIZE ABM3F400.176
*CALL ARGSTS ABM3F400.177
& ICODE,CMESSAGE) ABM3F400.178
ABM3F400.179
IF (JT_BL.EQ. 0) THEN ABM3F400.180
ICODE = 3004 ABM3F400.181
CMESSAGE = "AC_CTL: temp after b_lyr not available" ABM3F400.182
ABM3F400.183
END IF ABM3F400.184
ABM3F400.185
IF (ICODE .GT. 0) GOTO 999 ABM3F400.186
ABM3F400.187
CL 1.20 cloud liquid water after dynamic cloud ABM3F400.188
CALL FINDPTR( A_IM,9,206, ABM3F400.189
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.190
& STASHMACRO_TAG,MDI,JQCL_DC, ABM3F400.191
*CALL ARGSIZE ABM3F400.192
*CALL ARGSTS ABM3F400.193
& ICODE,CMESSAGE) ABM3F400.194
ABM3F400.195
IF (JQCL_DC.EQ. 0) THEN ABM3F400.196
ICODE = 9206 ABM3F400.197
CMESSAGE = "AC_CTL: cld lqd wtr after dyn_cld not available" ABM3F400.198
ABM3F400.199
END IF ABM3F400.200
ABM3F400.201
IF (ICODE .GT. 0) GOTO 999 ABM3F400.202
ABM3F400.203
CL 1.21 cloud ice after dynamic cloud ABM3F400.204
CALL FINDPTR( A_IM,9,207, ABM3F400.205
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.206
& STASHMACRO_TAG,MDI,JQCF_DC, ABM3F400.207
*CALL ARGSIZE ABM3F400.208
*CALL ARGSTS ABM3F400.209
& ICODE,CMESSAGE) ABM3F400.210
ABM3F400.211
IF (JQCF_DC.EQ. 0) THEN ABM3F400.212
ICODE = 9207 ABM3F400.213
CMESSAGE = "AC_CTL: cld ice after dyn_cld not available" ABM3F400.214
ABM3F400.215
END IF ABM3F400.216
ABM3F400.217
CL 1.22 cloud liquid water before dynamics ABM3F400.218
CALL FINDPTR( A_IM,10,229, ABM3F400.219
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.220
& STASHMACRO_TAG,MDI,JQCL_BD, ABM3F400.221
*CALL ARGSIZE ABM3F400.222
*CALL ARGSTS ABM3F400.223
& ICODE,CMESSAGE) ABM3F400.224
ABM3F400.225
IF (JQCL_BD.EQ. 0) THEN ABM3F400.226
ICODE =10229 ABM3F400.227
CMESSAGE = "AC_CTL: cld lqd wtr before dynamics not available" ABM3F400.228
ABM3F400.229
END IF ABM3F400.230
ABM3F400.231
IF (ICODE .GT. 0) GOTO 999 ABM3F400.232
ABM3F400.233
CL 1.23 cloud ice before dynamics ABM3F400.234
CALL FINDPTR( A_IM,10,230, ABM3F400.235
& MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI,MDI, ABM3F400.236
& STASHMACRO_TAG,MDI,JQCF_BD, ABM3F400.237
*CALL ARGSIZE ABM3F400.238
*CALL ARGSTS ABM3F400.239
& ICODE,CMESSAGE) ABM3F400.240
ABM3F400.241
IF (JQCF_BD.EQ. 0) THEN ABM3F400.242
ICODE =10230 ABM3F400.243
CMESSAGE = "AC_CTL: cld ice before dynamics not available" ABM3F400.244
ABM3F400.245
END IF ABM3F400.246
ABM3F400.247
IF (ICODE .GT. 0) GOTO 999 ABM3F400.248
ABM3F400.249
! 1.24 Get 'balanced' qcl,qcf at end of physics/start of assimilation ABM3F400.250
! -------------------------------------------------------------- ABM3F400.251
! 1.24.1 calculate thetal and qt from theta,q,qc ABM3F400.252
! If using mixed phase precip scheme then do not want ice in the call ADM2F404.15
! to THETL_QT. ADM2F404.16
IF (L_LSPICE) THEN ADM2F404.17
! Mixed phase precip scheme. Define an array of zeros instead ADM2F404.18
! of using QCF. ADM2F404.19
DO K=1,Q_LEVELS ADM2F404.20
DO J=1,P_FIELD ADM2F404.21
ZERO_FIELD(J,K)=0.0 ADM2F404.22
END DO ADM2F404.23
END DO ADM2F404.24
! Now call THETL_QT with the zero field ADM2F404.25
CALL THETL_QT( ADM2F404.26
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),ZERO_FIELD, ADM2F404.27
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) ADM2F404.28
! Else the call to THETL_QT does contain the QCF field ADM2F404.29
ELSE ADM2F404.30
CALL THETL_QT( ABM3F400.253
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),D1(JQCF(1)), ABM3F400.254
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) ABM3F400.255
! END IF for L_LSPICE ADM2F404.31
END IF ADM2F404.32
! 1.24.2 convert thetal to tl ABM3F400.256
DO K=1,Q_LEVELS ABM3F400.257
DO J=1,P_FIELD ABM3F400.258
PU=D1(JPSTAR+J-1)*BKH(K+1)+AKH(K+1) ABM3F400.259
PL=D1(JPSTAR+J-1)*BKH(K)+AKH(K) ABM3F400.260
D1(JTHETA(K)+J-1)=D1(JTHETA(K)+J-1) * ABM3F400.261
& P_EXNER_C(D1(JP_EXNER(K+1)+J-1),D1(JP_EXNER(K)+J-1), ABM3F400.262
& PU,PL,KAPPA) ABM3F400.263
END DO ABM3F400.264
END DO ABM3F400.265
! 1.24.3 call glue_cld to convert tl and qt to t,q,qc ABM3F400.266
CALL GLUE_CLD(A_LEVDEPC(JAK),A_LEVDEPC(JBK),D1(JPSTAR), ABM3F400.267
& RHCRIT,Q_LEVELS,D1(JRHC(1)),P_FIELD,P_FIELD,D1(JTHETA(1)), ASK1F405.81
& WORK,D1(JQ(1)),D1(JQCF(1)),D1(JQCL(1)),WORK2,WORK3,ERROR) ABM3F400.269
! 1.24.4 convert t back to theta for assimilation ABM3F400.270
DO K=1,Q_LEVELS ABM3F400.271
DO J=1,P_FIELD ABM3F400.272
PU=D1(JPSTAR+J-1)*BKH(K+1)+AKH(K+1) ABM3F400.273
PL=D1(JPSTAR+J-1)*BKH(K)+AKH(K) ABM3F400.274
D1(JTHETA(K)+J-1)=D1(JTHETA(K)+J-1) / ABM3F400.275
& P_EXNER_C(D1(JP_EXNER(K+1)+J-1),D1(JP_EXNER(K)+J-1), ABM3F400.276
& PU,PL,KAPPA) ABM3F400.277
END DO ABM3F400.278
END DO ABM3F400.279
ABM3F400.280
! 1.25 Calculate 'large-scale' latent heating contributions ABM3F400.281
! (equation 1 in FR Working Paper 171) ABM3F400.282
! ---------------------------------------------------- ABM3F400.283
DO K=1,Q_LEVELS ABM3F400.284
DO J=1,P_FIELD ABM3F400.285
WORK(J,K)= ABM3F400.286
& LC/CP*(D1(JQCL(K)+J-1)- ABM3F400.287
& D1(JQCL_P+J-1+(K-1)*P_FIELD) + ABM3F400.288
& D1(JQCL_DC+J-1+(K-1)*P_FIELD) - ABM3F400.289
& D1(JQCL_BD+J-1+(K-1)*P_FIELD) ) + ABM3F400.290
& (LC+LF)/CP*( D1(JQCF(K)+J-1)- ABM3F400.291
& D1(JQCF_P+J-1+(K-1)*P_FIELD) + ABM3F400.292
& D1(JQCF_DC+J-1+(K-1)*P_FIELD) - ABM3F400.293
& D1(JQCF_BD+J-1+(K-1)*P_FIELD) ) + ABM3F400.294
& D1(JT_P+J-1+(K-1)*P_FIELD) - ABM3F400.295
& D1(JT_BL+J-1+(K-1)*P_FIELD) ABM3F400.296
END DO ABM3F400.297
ABM3F400.298
! deal with boundary layer latent heating term ABM3F400.299
IF(K.LE.BL_LEVELS) THEN ABM3F400.300
DO J=1,P_FIELD ABM3F400.301
WORK(J,K) = WORK(J,K) + ABM3F400.302
& LC/CP*(D1(JQCL_BL+J-1+(K-1)*P_FIELD) - ABM3F400.303
& D1(JQCL_DC+J-1+(K-1)*P_FIELD)) + ABM3F400.304
& (LC+LF)/CP*(D1(JQCF_BL+J-1+(K-1)*P_FIELD) - ABM3F400.305
& D1(JQCF_DC+J-1+(K-1)*P_FIELD)) ABM3F400.306
ABM3F400.307
END DO ABM3F400.308
ENDIF ABM3F400.309
END DO ABM3F400.310
! large scale latent heating currently dT/dt in K/timestep ABM3F400.311
! convert to dtheta/dt in K/s, same unit as for convective heating ABM3F400.312
DO K=1,Q_LEVELS ABM3F400.313
DO J=1,P_FIELD ABM3F400.314
PU=D1(JPSTAR+J-1)*BKH(K+1)+AKH(K+1) ABM3F400.315
PL=D1(JPSTAR+J-1)*BKH(K)+AKH(K) ABM3F400.316
WORK(J,K) = WORK(J,K) / ABM3F400.317
& P_EXNER_C(D1(JP_EXNER(K+1)+J-1),D1(JP_EXNER(K)+J-1), ABM3F400.318
& PU,PL,KAPPA) ABM3F400.319
WORK(J,K) = WORK(J,K) / SECS_PER_STEPim(atmos_im) ABM3F400.320
END DO ABM3F400.321
END DO ABM3F400.322
ABM3F400.323
ELSE ! if LHN not selected ABM3F400.324
! initialise dummy heating rate array to pass to AC ABM3F400.325
DO K=1,Q_LEVELS ABM3F400.326
DO J=1,P_FIELD ABM3F400.327
WORK(J,K) = 0.0 ABM3F400.328
END DO ABM3F400.329
END DO ABM3F400.330
ABM3F400.331
END IF ! L_LHN ABM3F400.332
ABM3F400.333
CL---------------------------------------------------------------------- AC_CTL1.121
CL 2. --- Section 18 Data Assimilation ------ AC_CTL1.122
AC_CTL1.123
IF (LTIMER) THEN AC_CTL1.124
CALL TIMER('AC ', 3) AC_CTL1.125
AC_CTL1.126
END IF AC_CTL1.127
AC_CTL1.128
im_index=internal_model_index(A_IM) ABM3F400.334
IF (LSINGLE_HYDROL) THEN AFF2F401.4
IADDR_SMC = JSMC AFF2F401.5
IADDR_TSURF = JTSTAR AFF2F401.6
LEN_TSURF = P_FIELD AFF2F401.7
ELSE ! multi-level or MOSES/PENMAN MONTEITH scheme AFF2F401.8
IADDR_SMC = JSMCL(1) AFF2F401.9
IADDR_TSURF = J_DEEP_SOIL_TEMP(1) AFF2F401.10
LEN_TSURF = LAND_FIELD AFF2F401.11
ENDIF AFF2F401.12
ABM3F400.335
*IF DEF,MPP ASB1F403.7
! Update Haloes ASB1F403.8
CALL SWAPBOUNDS_shmem(D1(JT1P5M), ASB1F403.9
& ROW_LENGTH,P_ROWS,1,1,1) ASB1F403.10
CALL SWAPBOUNDS_shmem(D1(JRH1P5M), ASB1F403.11
& ROW_LENGTH,P_ROWS,1,1,1) ASB1F403.12
! Use non-shmem swapbounds for visibility to set superpolar rows. ARB0F404.12
CALL SWAPBOUNDS(D1(JVS1P5M), ARB0F404.13
& ROW_LENGTH,P_ROWS,1,1,1) ASB1F403.14
CALL SWAPBOUNDS_shmem(D1(JU10M), ASB1F403.15
& ROW_LENGTH,U_ROWS,1,1,1) ASB1F403.16
CALL SWAPBOUNDS_shmem(D1(JV10M), ASB1F403.17
& ROW_LENGTH,U_ROWS,1,1,1) ASB1F403.18
CALL SWAPBOUNDS_shmem(D1(JLSRR), ASB1F403.19
& ROW_LENGTH,P_ROWS,1,1,1) ASB1F403.20
CALL SWAPBOUNDS_shmem(D1(JLSSR), ASB1F403.21
& ROW_LENGTH,P_ROWS,1,1,1) ASB1F403.22
CALL SWAPBOUNDS_shmem(D1(JCVRR), ASB1F403.23
& ROW_LENGTH,P_ROWS,1,1,1) ASB1F403.24
CALL SWAPBOUNDS_shmem(D1(JCVSR), ASB1F403.25
& ROW_LENGTH,P_ROWS,1,1,1) ASB1F403.26
CALL SWAPBOUNDS_shmem(D1(JCONVCC), ASB1F403.27
& ROW_LENGTH,P_ROWS,1,1,Q_LEVELS) ASB1F403.28
*ENDIF ASB1F403.29
ASB1F403.30
IF( L_LHN ) THEN ABM3F400.336
ABM3F400.337
CALL AC (P_LEVELS, Q_LEVELS, ROW_LENGTH, P_ROWS, U_ROWS, AC_CTL1.129
& BL_LEVELS, APC0F405.804
& A_MAX_OBS_SIZE, A_MAX_NO_OBS, P_FIELD, U_FIELD, !tracer ARSAF304.62
& TR_SIZE, TR_VARS, TR_LEVELS, STEPim(atmos_im), GDR5F305.1
& SECS_PER_STEPim(atmos_im), ADR1F305.4
& A_LEVDEPC(JAK), A_LEVDEPC(JBK), AKH, BKH, ADR1F305.5
& D1(JP_EXNER(1)), D1(JPSTAR), D1(JTHETA(1)), D1(JQ(1)), SB230293.246
& D1(JQCL(1)), D1(JQCF(1)), AFF1F405.3
& D1(JU(1)), D1(JV(1)), D1(JMURK(1)), ABM1F304.57
& D1(JCANOPY_WATER), D1(JSURF_CAP), D1(IADDR_SMC), D1(JSNODEP), GDR6F405.84
& LAND_LIST, LAND_FIELD, D1(JSRA), D1(JCONVCC), ABM1F304.59
& D1(JLSRR), D1(JLSSR), D1(JCVRR), D1(JCVSR), AFF2F401.14
& D1(IADDR_TSURF),LEN_TSURF, AFF2F401.15
& D1(JLAND), D1(JU10M), D1(JV10M), D1(JT1P5M), D1(JRH1P5M), @DYALLOC.229
& D1(JVS1P5M), D1(JOROG), ABM1F304.60
& D1(JTIC),WORK, ABM3F400.338
& LOW_BOT_LEVEL, LOW_TOP_LEVEL, ABM1F304.61
& MED_BOT_LEVEL, MED_TOP_LEVEL, ABM1F304.62
& HIGH_BOT_LEVEL, HIGH_TOP_LEVEL, ABM1F304.63
& D1(JTRACER(1,1)), !tracer ARSAF304.64
& RHCRIT, I_TRACER_ADDRESS, I_TRACER_ITEM, ADR1F305.6
& IFAX, TRIGS, F3, F3_P, STINDEX(1,1,18,im_index), GSS2F305.110
& STLIST, LEN_STLIST, SI(1,18,im_index), SF(1,18), GSS2F305.111
& STASHWORK, STASH_LEVELS, GSS2F305.112
& NUM_STASH_LEVELS, STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, SB230293.251
& MODEL_STATUS, COS_U_LATITUDE, COS_P_LATITUDE, SEC_U_LATITUDE, SB230293.252
& SEC_P_LATITUDE, COS_LONGITUDE, SIN_LONGITUDE, SB230293.253
& A_LEVDEPC(JDELTA_AK), A_LEVDEPC(JDELTA_BK), GDG0F401.10
*CALL ARGPPX GDG0F401.11
& ICODE, CMESSAGE) GDG0F401.12
AC_CTL1.149
! repeat section 1.24 to re-balance thermodynamic fields after AC AFF2F405.8
! "1.24.1" calculate thetal and qt from theta,q,qc AFF2F405.9
! If using mixed phase precip scheme then do not want ice in the call AFF2F405.10
! to THETL_QT. AFF2F405.11
IF (L_LSPICE) THEN AFF2F405.12
! Mixed phase precip scheme. Define an array of zeros instead AFF2F405.13
! of using QCF. AFF2F405.14
DO K=1,Q_LEVELS AFF2F405.15
DO J=1,P_FIELD AFF2F405.16
ZERO_FIELD(J,K)=0.0 AFF2F405.17
END DO AFF2F405.18
END DO AFF2F405.19
! Now call THETL_QT with the zero field AFF2F405.20
CALL THETL_QT( AFF2F405.21
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),ZERO_FIELD, AFF2F405.22
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) AFF2F405.23
! Else the call to THETL_QT does contain the QCF field AFF2F405.24
ELSE AFF2F405.25
CALL THETL_QT( AFF2F405.26
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),D1(JQCF(1)), AFF2F405.27
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) AFF2F405.28
! END IF for L_LSPICE AFF2F405.29
END IF AFF2F405.30
! "1.24.2" convert thetal to tl AFF2F405.31
DO K=1,Q_LEVELS AFF2F405.32
DO J=1,P_FIELD AFF2F405.33
PU=D1(JPSTAR+J-1)*BKH(K+1)+AKH(K+1) AFF2F405.34
PL=D1(JPSTAR+J-1)*BKH(K)+AKH(K) AFF2F405.35
D1(JTHETA(K)+J-1)=D1(JTHETA(K)+J-1) * AFF2F405.36
& P_EXNER_C(D1(JP_EXNER(K+1)+J-1),D1(JP_EXNER(K)+J-1), AFF2F405.37
& PU,PL,KAPPA) AFF2F405.38
END DO AFF2F405.39
END DO AFF2F405.40
! "1.24.3" call glue_cld to convert tl and qt to t,q,qc AFF2F405.41
CALL GLUE_CLD(A_LEVDEPC(JAK),A_LEVDEPC(JBK),D1(JPSTAR), AFF2F405.42
& RHCRIT,Q_LEVELS,D1(JRHC(1)),P_FIELD,P_FIELD,D1(JTHETA(1)), AFF2F405.43
& WORK,D1(JQ(1)),D1(JQCF(1)),D1(JQCL(1)),WORK2,WORK3,ERROR) AFF2F405.44
! "1.24.4" convert t back to theta AFF2F405.45
DO K=1,Q_LEVELS AFF2F405.46
DO J=1,P_FIELD AFF2F405.47
PU=D1(JPSTAR+J-1)*BKH(K+1)+AKH(K+1) AFF2F405.48
PL=D1(JPSTAR+J-1)*BKH(K)+AKH(K) AFF2F405.49
D1(JTHETA(K)+J-1)=D1(JTHETA(K)+J-1) / AFF2F405.50
& P_EXNER_C(D1(JP_EXNER(K+1)+J-1),D1(JP_EXNER(K)+J-1), AFF2F405.51
& PU,PL,KAPPA) AFF2F405.52
END DO AFF2F405.53
END DO AFF2F405.54
AFF2F405.55
AFF2F405.56
ELSE ! if LHN not selected ABM3F400.339
ABM3F400.340
CALL AC (P_LEVELS, Q_LEVELS, ROW_LENGTH, P_ROWS, U_ROWS, ABM3F400.341
& BL_LEVELS, APC0F405.805
& A_MAX_OBS_SIZE, A_MAX_NO_OBS, P_FIELD, U_FIELD, !tracer ABM3F400.342
& TR_SIZE, TR_VARS, TR_LEVELS, STEPim(atmos_im), !tracer ABM3F400.343
& SECS_PER_STEPim(atmos_im), ABM3F400.344
& A_LEVDEPC(JAK), A_LEVDEPC(JBK), AKH, BKH, ABM3F400.345
& D1(JP_EXNER(1)), D1(JPSTAR), D1(JTHETA(1)), D1(JQ(1)), ABM3F400.346
& D1(JQCL(1)), D1(JQCF(1)), AFF1F405.4
& D1(JU(1)), D1(JV(1)), D1(JMURK(1)), ABM3F400.347
& D1(JCANOPY_WATER), D1(JSURF_CAP), D1(IADDR_SMC), D1(JSNODEP), GDR6F405.85
& LAND_LIST, LAND_FIELD, D1(JSRA), D1(JCONVCC), ABM3F400.349
& D1(JLSRR), D1(JLSSR), D1(JCVRR), D1(JCVSR), AFF2F401.17
& D1(IADDR_TSURF), LEN_TSURF, AFF2F401.18
& D1(JLAND), D1(JU10M), D1(JV10M), D1(JT1P5M), D1(JRH1P5M), ABM3F400.351
& D1(JVS1P5M), D1(JOROG), ABM3F400.352
& WORK,WORK, ABM3F400.353
& LOW_BOT_LEVEL, LOW_TOP_LEVEL, ABM3F400.354
& MED_BOT_LEVEL, MED_TOP_LEVEL, ABM3F400.355
& HIGH_BOT_LEVEL, HIGH_TOP_LEVEL, ABM3F400.356
& D1(JTRACER(1,1)), !tracer ABM3F400.357
& RHCRIT, I_TRACER_ADDRESS, I_TRACER_ITEM, ABM3F400.358
& IFAX, TRIGS, F3, F3_P, STINDEX(1,1,18,im_index), ABM3F400.359
& STLIST, LEN_STLIST, SI(1,18,im_index), SF(1,18), ABM3F400.360
& STASHWORK, STASH_LEVELS, ABM3F400.361
& NUM_STASH_LEVELS, STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, ABM3F400.362
& MODEL_STATUS, COS_U_LATITUDE, COS_P_LATITUDE, SEC_U_LATITUDE, ABM3F400.363
& SEC_P_LATITUDE, COS_LONGITUDE, SIN_LONGITUDE, ABM3F400.364
& A_LEVDEPC(JDELTA_AK), A_LEVDEPC(JDELTA_BK), GDG0F401.13
*CALL ARGPPX GDG0F401.14
& ICODE, CMESSAGE) GDG0F401.15
ABM3F400.366
END IF ! L_LHN ABM3F400.367
ABM3F400.368
*IF DEF,MPP ARB0F404.14
! This swapbounds on p_exner was found necessary to get bit ARB0F404.15
! reproducibility in LAM & Mes runs with assimilation. ARB0F404.16
CALL SWAPBOUNDS(D1(JP_EXNER(1)), ARB0F404.17
& ROW_LENGTH,P_ROWS,1,1,P_LEVELS+1) ARB0F404.18
*ENDIF ARB0F404.19
ARB0F404.20
IF (LTIMER) THEN AC_CTL1.152
CALL TIMER('AC ', 4) AC_CTL1.153
AC_CTL1.154
END IF AC_CTL1.155
AAM1F404.14
IF (ICODE.GT.0) GOTO 999 AAM1F404.15
AC_CTL1.156
CALL STASH(a_sm, a_im, 18, STASHWORK, GKR0F305.876
*CALL ARGSIZE @DYALLOC.231
*CALL ARGD1 @DYALLOC.232
*CALL ARGDUMA @DYALLOC.233
*CALL ARGDUMO @DYALLOC.234
*CALL ARGDUMW GKR1F401.165
*CALL ARGSTS @DYALLOC.235
*CALL ARGPPX GKR0F305.877
& ICODE, CMESSAGE) @DYALLOC.239
AC_CTL1.158
IF (ICODE.GT.0) GOTO 999 AC_CTL1.159
AC_CTL1.160
CL---------------------------------------------------------------------- AC_CTL1.161
CL 3.0 Overwrite stratospheric humidities with climatology AC_CTL1.162
C call at A_ASSIM_END_HR and A_ASSIM_START_HR + MODEL_ANALYSIS_HRS AC_CTL1.163
IF (STEPim(atmos_im) .EQ. GDR5F305.2
& ASSIM_FIRSTSTEPim(atmos_im)+ASSIM_STEPSim(atmos_im) GDR5F305.3
& .OR. GDR5F305.4
& STEPim(atmos_im) .EQ. ASSIM_FIRSTSTEPim(atmos_im) + GDR5F305.5
& ASSIM_STEPSim(atmos_im) + ASSIM_EXTRASTEPSim(atmos_im)) GDR5F305.6
& THEN AC_CTL1.166
CALL STRATQ (D1(JPSTAR), D1(JQ(1)), D1(JTHETA(1)), D1(JOROG), AC_CTL1.167
& D1(JP_EXNER(1)), P_LEVELS, ABM1F304.64
& Q_LEVELS, P_FIELD, A_LEVDEPC(JAK), A_LEVDEPC(JBK), AKH, AC_CTL1.169
& BKH, BL_LEVELS+1, ICODE, CMESSAGE) ABM1F304.65
AC_CTL1.171
IF (ICODE.GT.0) GOTO 999 AC_CTL1.172
AC_CTL1.173
END IF AC_CTL1.174
AC_CTL1.175
999 CONTINUE AC_CTL1.176
RETURN AC_CTL1.177
END AC_CTL1.178
*ENDIF AC_CTL1.179