SUBROUTINE CHEM_CTL(CLOUDF, 1,8CHEMCTL1.31
& DMS_LEN, CHEMCTL1.32
& Q_LEVELSDA,P_LEVELSDA,P_FIELDDA,ROW_LENGTHDA, CHEMCTL1.33
& COSZA2D,INT17, CHEMCTL1.34
*CALL ARGSIZE 
CHEMCTL1.35
*CALL ARGD1 CHEMCTL1.36
*CALL ARGDUMA CHEMCTL1.37
*CALL ARGDUMO CHEMCTL1.38
*CALL ARGSTS CHEMCTL1.39
*CALL ARGPTRA CHEMCTL1.40
*CALL ARGPTRO CHEMCTL1.41
*CALL ARGCONA CHEMCTL1.42
*CALL ARGPPX CHEMCTL1.43
*CALL ARGFLDPT CHEMCTL1.44
& ICODE,CMESSAGE) CHEMCTL1.45
! CHEMCTL1.46
IMPLICIT NONE CHEMCTL1.47
! CHEMCTL1.48
*CALL CMAXSIZE CHEMCTL1.49
*CALL CSUBMODL CHEMCTL1.50
*CALL TYPSIZE CHEMCTL1.51
*CALL TYPD1 CHEMCTL1.52
*CALL TYPDUMA CHEMCTL1.53
*CALL TYPDUMO CHEMCTL1.54
*CALL TYPSTS CHEMCTL1.55
*CALL TYPPTRA CHEMCTL1.56
*CALL TYPPTRO CHEMCTL1.57
*CALL TYPCONA CHEMCTL1.58
*CALL TYPFLDPT CHEMCTL1.59
*CALL PPXLOOK CHEMCTL1.60
! CHEMCTL1.61
INTEGER CHEMCTL1.62
& DMS_LEN, !IN length of dimethyl sulphide array CHEMCTL1.63
& Q_LEVELSDA, !IN no. of wet levels CHEMCTL1.64
& P_LEVELSDA, !IN no. of pressure levels CHEMCTL1.65
& P_FIELDDA, !IN no. of pts in 2_D field CHEMCTL1.66
& ROW_LENGTHDA, !IN no. of pts in a row CHEMCTL1.67
& INT17 !IN dummy for STASH_MAXLEN(17) CHEMCTL1.68
INTEGER ICODE !OUT Return code ( >0 for ERROR) CHEMCTL1.69
! CHEMCTL1.70
REAL CLOUDF(P_FIELDDA*Q_LEVELSDA), !IN cloud fraction (0-1) CHEMCTL1.71
& COSZA2D(P_FIELDDA) !IN cos(zenith angle) CHEMCTL1.72
! CHEMCTL1.73
CHARACTER*80 CMESSAGE !OUT Error message CHEMCTL1.74
! CHEMCTL1.75
! Include COMDECKS CHEMCTL1.76
! CHEMCTL1.77
*IF DEF,MPP CHEMCTL1.78
! Parameters and Common blocks CHEMCTL1.79
*CALL PARVARS CHEMCTL1.80
*ENDIF CHEMCTL1.81
*CALL CHSUNITS CHEMCTL1.82
*CALL CCONTROL CHEMCTL1.83
*CALL CHISTORY CHEMCTL1.84
*CALL CRUNTIMC CHEMCTL1.85
*CALL CTIME CHEMCTL1.86
*CALL C_SULCHM AWO2F404.3
! CHEMCTL1.87
! External subroutines called CHEMCTL1.88
EXTERNAL GRAVSETT, SULPHUR, NEW2OLD, SOOTSCAV ALR2F405.8
! AWO2F404.5
! CHEMCTL1.90
! Local variables CHEMCTL1.91
! CHEMCTL1.92
INTEGER I,J,K ! loop variables CHEMCTL1.93
INTEGER FIRST_POINT, ! First and last pts on which calcns done CHEMCTL1.94
& LAST_POINT ! (omits N and S polar rows) CHEMCTL1.95
INTEGER CHEMCTL1.96
& NPNTS, ! no. of pts in 3D array on P LEVS CHEMCTL1.97
& QPNTS ! no. of pts in 3D array on Q LEVS CHEMCTL1.98
! CHEMCTL1.99
REAL CHEMSTEP ! chemistry timestep CHEMCTL1.100
! CHEMCTL1.101
! Dynamically allocated space CHEMCTL1.102
! CHEMCTL1.103
REAL DMS(P_FIELDDA*P_LEVELSDA), ! filled dimethyl sulphide array CHEMCTL1.104
& PAML(P_FIELDDA*P_LEVELSDA) ! pressure at model level CHEMCTL1.105
REAL O3(P_FIELDDA*P_LEVELSDA), ! 3_D ozone field AWO6F405.5
& NH3(P_FIELDDA*P_LEVELSDA), ! 3_D NH3 field AWO6F405.6
& NH3_DEP(P_FIELDDA*P_LEVELSDA) ! NH3 depleted by buffering AWO6F405.7
REAL MSA(P_FIELDDA*P_LEVELSDA), ! Methyl sulphonic acid CHEMCTL1.106
& STASHWORK(INT17) ! for STASH processing CHEMCTL1.107
! AWO2F404.6
REAL SETTDEP(P_FIELDDA) ! settlement depn flux from lev 2 AWO2F404.7
! CHEMCTL1.108
! CHEMCTL1.109
FIRST_POINT = START_POINT_NO_HALO CHEMCTL1.110
LAST_POINT = END_P_POINT_NO_HALO CHEMCTL1.111
! CHEMCTL1.112
NPNTS=P_FIELDDA*P_LEVELSDA CHEMCTL1.113
QPNTS=P_FIELDDA*Q_LEVELSDA CHEMCTL1.114
! ALR2F405.9
IF (L_SULPC_SO2) THEN ALR2F405.10
! AWO2F404.8
! Call routine GRAVSETT to do settlement of Aitken and accumulation AWO2F404.9
! mode sulphate particles AWO2F404.10
! AWO2F404.11
CALL GRAVSETT( AWO2F404.12
& P_FIELD,P_LEVELS,D1(JSO4_AITKEN(1)) AWO2F404.13
& ,DIAM_AIT,RHO_SO4,D1(JPSTAR),A_LEVDEPC(JAK),A_LEVDEPC(JBK) AWO2F404.14
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK),D1(JTHETA(1)) AWO2F404.15
& ,FIRST_POINT,LAST_POINT AWO2F404.16
& ,SECS_PER_STEPim(atmos_im),SETTDEP) AWO2F404.17
! AWO2F404.18
! AWO6F405.8
IF (SF(201,17)) THEN ! write depn flux for SO4 AIT to stash AWO6F405.9
CALL COPYDIAG( AWO6F405.10
& STASHWORK(SI(201,17,internal_model_index(atmos_im))), AWO6F405.11
& SETTDEP, AWO6F405.12
& FIRST_POINT,LAST_POINT, AWO6F405.13
& P_FIELD,ROW_LENGTH, AWO6F405.14
& atmos_im,17,201, AWO6F405.15
*CALL ARGPPX AWO6F405.16
& ICODE,CMESSAGE) AWO6F405.17
ENDIF AWO6F405.18
! AWO6F405.19
! AWO2F404.19
CALL GRAVSETT( AWO2F404.20
& P_FIELD,P_LEVELS,D1(JSO4_ACCU(1)) AWO2F404.21
& ,DIAM_ACC,RHO_SO4,D1(JPSTAR),A_LEVDEPC(JAK),A_LEVDEPC(JBK) AWO2F404.22
& ,A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK),D1(JTHETA(1)) AWO2F404.23
& ,FIRST_POINT,LAST_POINT AWO2F404.24
& ,SECS_PER_STEPim(atmos_im),SETTDEP) AWO2F404.25
! AWO2F404.26
! AWO6F405.20
IF (SF(202,17)) THEN ! write depn flux for SO4 ACC to stash AWO6F405.21
CALL COPYDIAG( AWO6F405.22
& STASHWORK(SI(202,17,internal_model_index(atmos_im))), AWO6F405.23
& SETTDEP, AWO6F405.24
& FIRST_POINT,LAST_POINT, AWO6F405.25
& P_FIELD,ROW_LENGTH, AWO6F405.26
& atmos_im,17,202, AWO6F405.27
*CALL ARGPPX AWO6F405.28
& ICODE,CMESSAGE) AWO6F405.29
ENDIF AWO6F405.30
! AWO6F405.31
! AWO2F404.27
! CHEMCTL1.115
! Calculate pressure at model level for use in SULPHUR CHEMCTL1.116
DO K=1,P_LEVELSDA CHEMCTL1.117
DO I=FIRST_POINT,LAST_POINT CHEMCTL1.118
PAML((K-1)*P_FIELDDA+I)=A_LEVDEPC(JAK+K-1)+ CHEMCTL1.119
& A_LEVDEPC(JBK+K-1)*D1(JPSTAR+I-1) CHEMCTL1.120
END DO CHEMCTL1.121
END DO CHEMCTL1.122
! CHEMCTL1.123
ENDIF ! L_SULPC_SO2 ALR2F405.11
! ALR2F405.12
! Fill DMS array for passing to SULPHATE CHEMCTL1.124
IF (L_SULPC_DMS) THEN CHEMCTL1.125
! CHEMCTL1.126
IF (DMS_LEN.EQ.NPNTS) THEN CHEMCTL1.127
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA CHEMCTL1.128
DO I=FIRST_POINT,LAST_POINT CHEMCTL1.129
K=I+J-1 CHEMCTL1.130
DMS(K)=D1(JDMS(1)+K-1) ! Fill DMS from values in D1 CHEMCTL1.131
END DO CHEMCTL1.132
END DO CHEMCTL1.133
ELSE CHEMCTL1.134
ICODE=1 CHEMCTL1.135
CMESSAGE='DMS_LEN.NE.NPNTS FOR DMS=T, CANNOT CALL SULPHATE' CHEMCTL1.136
RETURN CHEMCTL1.137
END IF CHEMCTL1.138
! CHEMCTL1.139
ELSE CHEMCTL1.140
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA CHEMCTL1.141
DO I=FIRST_POINT,LAST_POINT CHEMCTL1.142
K=I+J-1 CHEMCTL1.143
DMS(K)=0.0 ! Fill DMS array with zeros CHEMCTL1.144
END DO CHEMCTL1.145
END DO CHEMCTL1.146
! CHEMCTL1.147
END IF ! END L_SULPC_DMS IF CHEMCTL1.148
! Fill O3 and NH3 arrays for passing to SULPHUR AWO6F405.32
! AWO6F405.33
IF (L_SULPC_OZONE) THEN AWO6F405.34
! AWO6F405.35
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.36
DO I=FIRST_POINT,LAST_POINT AWO6F405.37
K=I+J-1 AWO6F405.38
O3(K)=D1(JO3_CHEM(1)+K-1) ! Fill O3 from values in D1 AWO6F405.39
END DO AWO6F405.40
END DO AWO6F405.41
ELSE AWO6F405.42
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.43
DO I=FIRST_POINT,LAST_POINT AWO6F405.44
K=I+J-1 AWO6F405.45
O3(K)=0.0 ! Fill O3 array with zeros AWO6F405.46
END DO AWO6F405.47
END DO AWO6F405.48
! AWO6F405.49
END IF ! END L_SULPC_OZONE condition AWO6F405.50
! AWO6F405.51
IF (L_SULPC_NH3) THEN AWO6F405.52
! AWO6F405.53
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.54
DO I=FIRST_POINT,LAST_POINT AWO6F405.55
K=I+J-1 AWO6F405.56
NH3(K)=D1(JNH3(1)+K-1) ! Fill NH3 from values in D1 AWO6F405.57
END DO AWO6F405.58
END DO AWO6F405.59
ELSE AWO6F405.60
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.61
DO I=FIRST_POINT,LAST_POINT AWO6F405.62
K=I+J-1 AWO6F405.63
NH3(K)=0.0 ! Fill NH3 array with zeros AWO6F405.64
END DO AWO6F405.65
END DO AWO6F405.66
! AWO6F405.67
END IF ! END L_SULPC_NH3 condition AWO6F405.68
! AWO6F405.69
! CHEMCTL1.149
! Call routine SULPHUR to do sulphur chemistry, in-cloud scavenging CHEMCTL1.150
! and production of accumulation mode aerosol by evaporation of CHEMCTL1.151
! cloud droplets. CHEMCTL1.152
! Routine may be called several times per physics timestep CHEMCTL1.153
! CHEMCTL1.154
CHEMSTEP=SECS_PER_STEPim(atmos_im)/CALL_CHEM_FREQ CHEMCTL1.155
! CHEMCTL1.156
DO I=1,CALL_CHEM_FREQ CHEMCTL1.157
! CHEMCTL1.158
IF ( L_SULPC_SO2 ) THEN ALR2F405.13
CALL SULPHUR(D1(JSO2(1)), CHEMCTL1.159
& D1(JSO4_AITKEN(1)), CHEMCTL1.160
& D1(JSO4_ACCU(1)), CHEMCTL1.161
& D1(JSO4_DISS(1)), CHEMCTL1.162
& NH3,NH3_DEP,O3,L_SULPC_OZONE, AWO6F405.70
& DMS, AWO1F403.1
& D1(JH2O2(1)), CHEMCTL1.164
& CLOUDF, CHEMCTL1.165
& NPNTS,QPNTS,P_FIELDDA,CHEMSTEP, CHEMCTL1.166
& D1(JQCL(1)),D1(JQCF(1)), CHEMCTL1.167
& D1(JLAND), CHEMCTL1.168
& COSZA2D, CHEMCTL1.169
& PAML, CHEMCTL1.170
& D1(JTHETA(1)), ! Temperature (not theta) CHEMCTL1.171
& D1(JQ(1)), CHEMCTL1.172
& D1(JOH(1)),D1(JH2O2_LIMIT(1)),D1(JHO2(1)), CHEMCTL1.173
& FIRST_POINT,LAST_POINT, CHEMCTL1.174
& MSA,L_SULPC_DMS) CHEMCTL1.175
! CHEMCTL1.176
ENDIF ! Test on L_SULPC_SO2 ALR2F405.14
ALR2F405.15
IF (L_SOOT) THEN ! Call the routines to convert fresh to aged ALR2F405.16
! soot and to scavenge some aged soot within ALR2F405.17
! cloud droplets. ALR2F405.18
! ALR2F405.19
CALL NEW2OLD(NPNTS, ALR2F405.20
& FIRST_POINT, ALR2F405.21
& LAST_POINT, ALR2F405.22
& P_FIELD, ALR2F405.23
& D1(JSOOT_NEW(1)), ALR2F405.24
& D1(JSOOT_AGD(1)), ALR2F405.25
& SECS_PER_STEPim(atmos_im)) ALR2F405.26
! ALR2F405.27
CALL SOOTSCAV( ALR2F405.28
& D1(JSOOT_AGD(1)), ALR2F405.29
& D1(JSOOT_CLD(1)), ALR2F405.30
& CLOUDF, ! Cloud fraction ALR2F405.31
& NPNTS,QPNTS,P_FIELD, ALR2F405.32
& SECS_PER_STEPim(atmos_im), ALR2F405.33
& D1(JQCL(1)),D1(JQCF(1)), ALR2F405.34
& FIRST_POINT,LAST_POINT ALR2F405.35
& ) ALR2F405.36
! ALR2F405.37
ENDIF ! L_SOOT test ALR2F405.38
END DO CHEMCTL1.177
! CHEMCTL1.178
! Read DMS values back to D1 array if DMS=T CHEMCTL1.179
! CHEMCTL1.180
IF (L_SULPC_DMS) THEN CHEMCTL1.181
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA CHEMCTL1.182
DO I=FIRST_POINT,LAST_POINT CHEMCTL1.183
K=I+J-1 CHEMCTL1.184
D1(JDMS(1)+K-1)=DMS(K) CHEMCTL1.185
END DO CHEMCTL1.186
END DO CHEMCTL1.187
END IF CHEMCTL1.188
! AWO6F405.71
! Read NH3 values back into D1 array if L_SULPC_NH3 AWO6F405.72
! (O3 is unchanged so need not be read back to D1) AWO6F405.73
! AWO6F405.74
IF (L_SULPC_NH3) THEN AWO6F405.75
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.76
DO I=FIRST_POINT,LAST_POINT AWO6F405.77
K=I+J-1 AWO6F405.78
D1(JNH3(1)+K-1)=NH3(K) AWO6F405.79
END DO AWO6F405.80
END DO AWO6F405.81
END IF AWO6F405.82
! AWO6F405.83
! AWO6F405.84
! Write MSA to STASH if DMS included AWO6F405.85
IF (L_SULPC_DMS) THEN AWO6F405.86
! AWO6F405.87
IF (SF(203,17)) THEN AWO6F405.88
! AWO6F405.89
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.90
DO I=FIRST_POINT,LAST_POINT AWO6F405.91
K=I+J-1 AWO6F405.92
STASHWORK(SI(203,17,internal_model_index(atmos_im))+K-1)=MSA(K) AWO6F405.93
END DO AWO6F405.94
END DO AWO6F405.95
! AWO6F405.96
! Copy FIRST_POINT values to unfilled locations AWO6F405.97
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.98
DO I=1,FIRST_POINT AWO6F405.99
K=I+J-1 AWO6F405.100
STASHWORK(SI(203,17,internal_model_index(atmos_im))+K-1) = AWO6F405.101
& STASHWORK(SI(203,17,internal_model_index(atmos_im))+ AWO6F405.102
& J+FIRST_POINT-2) AWO6F405.103
END DO AWO6F405.104
END DO AWO6F405.105
! AWO6F405.106
! Copy LAST_POINT values to unfilled locations AWO6F405.107
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.108
DO I=LAST_POINT,P_FIELDDA AWO6F405.109
K=I+J-1 AWO6F405.110
STASHWORK(SI(203,17,internal_model_index(atmos_im))+K-1) = AWO6F405.111
& STASHWORK(SI(203,17,internal_model_index(atmos_im))+ AWO6F405.112
& J+LAST_POINT-2) AWO6F405.113
END DO AWO6F405.114
END DO AWO6F405.115
! AWO6F405.116
END IF AWO6F405.117
! AWO6F405.118
END IF ! END L_SULPC_DMS condition AWO6F405.119
! AWO6F405.120
! AWO6F405.121
! Write NH3_DEP to STASH if NH3 included AWO6F405.122
IF (L_SULPC_OZONE) THEN AWO6F405.123
! AWO6F405.124
IF (SF(204,17)) THEN AWO6F405.125
! AWO6F405.126
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.127
DO I=FIRST_POINT,LAST_POINT AWO6F405.128
K=I+J-1 AWO6F405.129
STASHWORK(SI(204,17,internal_model_index(atmos_im))+K-1)= AWO6F405.130
& NH3_DEP(K) AWO6F405.131
END DO AWO6F405.132
END DO AWO6F405.133
! AWO6F405.134
! Copy FIRST_POINT values to unfilled locations AWO6F405.135
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.136
DO I=1,FIRST_POINT AWO6F405.137
K=I+J-1 AWO6F405.138
STASHWORK(SI(204,17,internal_model_index(atmos_im))+K-1) = AWO6F405.139
& STASHWORK(SI(204,17,internal_model_index(atmos_im))+ AWO6F405.140
& J+FIRST_POINT-2) AWO6F405.141
END DO AWO6F405.142
END DO AWO6F405.143
! AWO6F405.144
! Copy LAST_POINT values to unfilled locations AWO6F405.145
DO J=1,NPNTS-P_FIELDDA+1,P_FIELDDA AWO6F405.146
DO I=LAST_POINT,P_FIELDDA AWO6F405.147
K=I+J-1 AWO6F405.148
STASHWORK(SI(204,17,internal_model_index(atmos_im))+K-1) = AWO6F405.149
& STASHWORK(SI(204,17,internal_model_index(atmos_im))+ AWO6F405.150
& J+LAST_POINT-2) AWO6F405.151
END DO AWO6F405.152
END DO AWO6F405.153
! AWO6F405.154
END IF AWO6F405.155
! AWO6F405.156
END IF ! END L_SULPC_OZONE condition AWO6F405.157
! AWO6F405.158
! CHEMCTL1.189
! AWO6F405.159
! Call STASH AWO6F405.160
CALL STASH(a_sm,a_im,17,STASHWORK, AWO6F405.161
*CALL ARGSIZE AWO6F405.162
*CALL ARGD1 AWO6F405.163
*CALL ARGDUMA AWO6F405.164
*CALL ARGDUMO AWO6F405.165
*CALL ARGDUMW AWO6F405.166
*CALL ARGSTS AWO6F405.167
*CALL ARGPPX AWO6F405.168
& ICODE,CMESSAGE) AWO6F405.169
! AWO6F405.170
RETURN CHEMCTL1.190
END CHEMCTL1.191
! CHEMCTL1.192
*ENDIF CHEMCTL1.193