SUBROUTINE LWPTSC (H2O,CO2,O3,N2O,CH4,CFC11,CFC12, 2LWPTSC1C.6
& PSTAR, AC, BC, AB, BB, TAC, LWPTSC1C.7
& L2, GSS2F402.35
& NWET, NOZONE, NLEVS, L1, DPATH) LWPTSC1C.11
! LWPTSC1C.12
IMPLICIT NONE LWPTSC1C.13
! LWPTSC1C.14
! Description: LWPTSC1C.15
! LWPTSC1C.16
! LWPTSC calculates the scaled pathlength for each of the absorbing LWPTSC1C.17
! gases in the longwave. It takes account of temperature and LWPTSC1C.18
! pressure scaling . CFCs are assumed to be in the weak limit so LWPTSC1C.19
! the scaled pathlength is set to the unscaled value. LWPTSC1C.20
! It is called by LWMAST. ( The pathlengths are later summed in LWPTSC1C.21
! LWMAST to obtain the total pathlength between pairs of layers LWPTSC1C.22
! which is then used in the calculation of transmissivities) LWPTSC1C.23
! LWPTSC1C.24
! Method: LWPTSC1C.25
! LWPTSC1C.26
! The structure of the code is not completely straightforward, as it LWPTSC1C.27
! has been written for efficiency LWPTSC1C.28
! LWPTSC1C.29
! The aim is to calculate the scaled pathlength ( dpath ) ... LWPTSC1C.30
! (NB corrections for doppler broadening are included LWPTSC1C.31
! in the P terms ) LWPTSC1C.32
! LWPTSC1C.33
! for self-broadened continuum (scaled) LWPTSC1C.34
! 1.66 * mmr * mmr * T**(b-1) * delta(P**(a+2)) / LWPTSC1C.35
! Tref**b *g *Pref**a *(a+2) LWPTSC1C.36
! LWPTSC1C.37
! for foreign-broadened continuum (scaled) LWPTSC1C.38
! 1.66 * mmr * ( 1 - mmr) * T**(b-1) * delta(P**(a+2)) / LWPTSC1C.39
! Tref**b *g *Pref**a *(a+2) LWPTSC1C.40
! LWPTSC1C.41
! for lines (scaled) LWPTSC1C.42
! 1.66 *mmr * T**b * delta(P**(a+1)) / LWPTSC1C.43
! Tref**b * g * Pref**a * (a+1) LWPTSC1C.44
! LWPTSC1C.45
! for CFCs LWPTSC1C.46
! 2. * mmr * deltaP / g LWPTSC1C.47
! LWPTSC1C.48
! for unscaled self-broadened continuum LWPTSC1C.49
! 1.66* mmr * mmr * deltaP**2 /(2 * g * R * T) LWPTSC1C.50
! LWPTSC1C.51
! for unscaled foreign-broadened continuum LWPTSC1C.52
! 1.66* mmr * (1 - mmr ) * deltaP**2 /(2 * g * R * T) LWPTSC1C.53
! LWPTSC1C.54
! for unscaled lines LWPTSC1C.55
! 1.66 * mmr * deltaP / g LWPTSC1C.56
! LWPTSC1C.57
! LWPTSC1C.58
! Doppler broadening is included within the tables LWPTSC1C.59
! LWPTSC1C.60
! The scaled pathlengths are returned in DPATH , to LWMAST. LWPTSC1C.61
! LWPTSC1C.62
! Offline documentation on the radiation code is in UMDP23 LWPTSC1C.63
! LWPTSC1C.64
! Current Code Owner: Stephanie Woodward LWPTSC1C.65
! LWPTSC1C.66
! History: LWPTSC1C.67
! Version Date Comment LWPTSC1C.68
! ------- ---- ------- LWPTSC1C.69
! 3.0 28/9/94 Original code. Stephanie Woodward LWPTSC1C.70
! 4.2 Sept.96 T3E migration: *DEF CRAY removed; GSS2F402.36
! *DEF T3E used for T3E library functions; GSS2F402.37
! dynamic allocation no longer *DEF controlled; GSS2F402.38
! cray HF functions replaced by T3E lib functions. GSS2F402.39
! S.J.Swarbrick GSS2F402.40
! LWPTSC1C.71
! Code Description: LWPTSC1C.72
! Language: FORTRAN 77 + common extensions. LWPTSC1C.73
! This code is written to UMDP3 v6 programming standards. LWPTSC1C.74
! LWPTSC1C.75
! System component covered: A LWPTSC1C.76
! System Task: P23 LWPTSC1C.77
! LWPTSC1C.78
! Declarations: LWPTSC1C.79
! LWPTSC1C.80
! Global variables (*CALLed COMDECKs etc...): LWPTSC1C.81
*CALL C_G 
LWPTSC1C.82
*CALL C_EPSLON LWPTSC1C.83
*CALL C_R_CP LWPTSC1C.84
*CALL LWNGASES LWPTSC1C.85
*CALL LWNBANDS LWPTSC1C.86
*CALL LWGSINBS LWPTSC1C.87
! LWPTSC1C.91
! Subroutine arguments LWPTSC1C.92
! Scalar arguments with intent(in): LWPTSC1C.93
! LWPTSC1C.94
! LWPTSC1C.95
REAL LWPTSC1C.96
& CO2 ! mmr for CO2 ! LWPTSC1C.97
! LWPTSC1C.98
INTEGER LWPTSC1C.99
& L2, LWPTSC1C.101
! ! number of points to be treated LWPTSC1C.102
& NLEVS, ! number of levels LWPTSC1C.104
& L1, ! number of points LWPTSC1C.105
& NOZONE, ! number of ozone levels LWPTSC1C.106
& NWET ! number of wet levels LWPTSC1C.107
! LWPTSC1C.108
! Array arguments with intent(in): LWPTSC1C.109
REAL LWPTSC1C.110
& H2O(L1,NWET), ! m.m.r.'s of gases LWPTSC1C.111
& O3(L1,NOZONE), ! LWPTSC1C.112
& N2O(NLEVS), ! LWPTSC1C.113
& CH4(NLEVS), ! LWPTSC1C.114
& CFC11(NLEVS), ! LWPTSC1C.115
& CFC12(NLEVS), ! LWPTSC1C.116
& TAC(L1,NLEVS), ! mid-layer temperatures LWPTSC1C.117
& PSTAR(L1), ! surface pressure LWPTSC1C.118
& AC(NLEVS), BC(NLEVS), ! a & b for layer centres and LWPTSC1C.119
& AB(NLEVS+1), BB(NLEVS+1) !...and boundaries LWPTSC1C.120
! LWPTSC1C.121
! LWPTSC1C.122
REAL LWPTSC1C.123
& DPATH(L2,NLEVS,NGASUS,NBANDS) ! Scaled Pathlengths LWPTSC1C.124
! LWPTSC1C.125
! Local parameters: LWPTSC1C.126
INTEGER LWPTSC1C.127
& NGXB ! total number of gas-band LWPTSC1C.128
! ! combinations LWPTSC1C.129
PARAMETER (NGXB = NGASUS*NBANDS) LWPTSC1C.130
! LWPTSC1C.131
REAL LWPTSC1C.132
& H2OMIN ! min val for h2o, to avoid LWPTSC1C.133
! ! underflow exceptions LWPTSC1C.134
! LWPTSC1C.135
PARAMETER (H2OMIN = 1.E-20) LWPTSC1C.136
! LWPTSC1C.137
! Local scalars: LWPTSC1C.138
! LWPTSC1C.139
INTEGER LWPTSC1C.140
& INDXB(NGXB), ! index to bands in gas_band LWPTSC1C.141
! ! combinations for scaling LWPTSC1C.142
& INDXG(NGXB), ! index to gases as indxb LWPTSC1C.143
& NGBCOM, ! number of gas-band LWPTSC1C.144
! ! combinations for scaling LWPTSC1C.145
& LEVEL, ! level index LWPTSC1C.146
& J, ! point index LWPTSC1C.147
& GAS, ! gas index LWPTSC1C.148
& BAND, ! band index LWPTSC1C.149
& GBCOM, ! gas-band combination index LWPTSC1C.150
& ONETWO, ! 'flipper' takes val 1 or 2 LWPTSC1C.151
& GASOLD ! gas number in previous calc LWPTSC1C.152
! LWPTSC1C.153
REAL LWPTSC1C.154
& PTOP, ! pressure at top of current layer LWPTSC1C.155
& DP, ! pressure thickness of current layer LWPTSC1C.156
& COCOTM, ! const term in contin calcs(unscaled) LWPTSC1C.157
& DSTRNG, !Diffusivity factor in strong limit(1.6) LWPTSC1C.158
& DWEAK ! Diffusivity factor in weak limit (2.0) LWPTSC1C.159
! LWPTSC1C.160
PARAMETER ( DSTRNG = 1.66) LWPTSC1C.161
PARAMETER ( DWEAK = 2.0) LWPTSC1C.162
LWPTSC1C.163
! Local dynamic arrays: LWPTSC1C.164
! ! WORK IS THE ONLY DYNAMICALLY ALLOCATED ARRAY GSS2F402.41
REAL WORK(L2,2,NGXB) LWPTSC1C.169
! ! work is used to hold powers of layer boundary pressures used LWPTSC1C.170
! ! in 2.3.1 and passed from one level to the next to save LWPTSC1C.171
! ! re-calculation. (this does prevent autotasking over levels.) LWPTSC1C.172
! LWPTSC1C.173
REAL LWPTSC1C.174
& PSCALE(NGASMX,NBANDS), ! pressure scaling terms LWPTSC1C.175
& TSCALE(NGASMX,NBANDS), ! temp scaling terms LWPTSC1C.176
& PREFS(NSCGMX), ! reference p for scaled gases LWPTSC1C.177
& TREFS(NSCGMX), ! reference tmp for scaled gases LWPTSC1C.178
& ALPHA(NGASMX,NBANDS), ! P scaling power factors LWPTSC1C.179
& BETA(NGASMX,NBANDS), ! T scaling power factors LWPTSC1C.180
& DAB(NLEVS), ! diffs of A across levels LWPTSC1C.181
& DBB(NLEVS), ! diffs of B across levels LWPTSC1C.182
& TMPGAS(L1), ! temporary space LWPTSC1C.183
& GBTM(NSCGMX,NBANDS), ! gas/band dep. term in cont calcs LWPTSC1C.184
& DOPPL(NSCGUS) ! doppler broadening terms LWPTSC1C.185
! LWPTSC1C.186
LOGICAL SCALE(NSCGMX,NBANDS) ! true for gas/band combinations LWPTSC1C.187
! ! to be scaled LWPTSC1C.188
! LWPTSC1C.189
! Function & Subroutine calls: LWPTSC1C.190
! External LWPTSC1C.191
! LWPTSC1C.192
!- End of header LWPTSC1C.193
!---------------------------------------------------------------------- LWPTSC1C.194
! LWPTSC1C.195
! LWPTSC1C.196
! Data statements: LWPTSC1C.197
! ! PREFS & TREFS shouldbe set to 0 for those gases which are LWPTSC1C.198
! ! not scaled LWPTSC1C.199
! LWPTSC1C.200
! ...gas..... s f l co2 o3 n20 ch4 LWPTSC1C.201
DATA PREFS/5.e4 , 5.e4 ,5.e4 , 2.5e4, 2.5e4 ,2.5e4, 2.5e4/ LWPTSC1C.202
DATA TREFS/ 250., 250., 250., 225., 225. , 225., 225./ LWPTSC1C.203
! LWPTSC1C.204
DATA ALPHA/ LWPTSC1C.205
! self forn h2o co2 o3 n2o ch4 cfc11 cfc12 LWPTSC1C.206
& 0.0, 0.0, .97, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.207
& -.05, 0.0, .97, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.208
& -.06, 0.0, .97, .82, .17, .81, 0.0, 0.0, 0.0, LWPTSC1C.209
& 0.0, 0.0, .96, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.210
& 0.0, 0.0, .94, .68, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.211
& 0.0, 0.0, .93, .68, .32, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.212
& 0.0, 0.0, .92, 0.0, 0.0, .82, 0.0, 0.0, 0.0, LWPTSC1C.213
& -.03, 0.0, .90, 0.0, 0.0, .82, .83, 0.0, 0.0, LWPTSC1C.214
& 0.0, 0.0, .95, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/ LWPTSC1C.215
! LWPTSC1C.216
DATA BETA/ LWPTSC1C.217
! self forn h2o co2 o3 n2o ch4 cfc11 cfc12 LWPTSC1C.218
& 0.0,-1.4, .82, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.219
& -2.0,-1.2, 3.5, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.220
& -2.8,-2.3, 4.3, 2.4, .13, -3.1, 0.0, 0.0, 0.0, LWPTSC1C.221
& -3.5,-.27, 6.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.222
& -3.5, 0.0, 7.2, 8.9, 0.0, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.223
& -3.6, 0.0, 7.5, 8.3, .02, 0.0, 0.0, 0.0, 0.0, LWPTSC1C.224
& -3.0, 0.0, 5.5, 0.0, 0.0, 5.1, 0.0, 0.0, 0.0, LWPTSC1C.225
& -1.2,-.62, 4.7, 0.0, 0.0, -2.4, .68, 0.0, 0.0, LWPTSC1C.226
& 0.0, 0.0,-1.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/ LWPTSC1C.227
! LWPTSC1C.228
DATA SCALE/ LWPTSC1C.229
& .FALSE. ,.TRUE. ,.TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE., LWPTSC1C.230
& .TRUE. ,.TRUE. ,.TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE., LWPTSC1C.231
& .TRUE. ,.TRUE. ,.TRUE.,.TRUE. ,.TRUE. ,.TRUE. ,.FALSE., LWPTSC1C.232
& .TRUE. ,.TRUE. ,.TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE., LWPTSC1C.233
& .TRUE. ,.FALSE. ,.TRUE.,.TRUE. ,.FALSE.,.FALSE.,.FALSE., LWPTSC1C.234
& .TRUE. ,.FALSE. ,.TRUE.,.TRUE. ,.TRUE. ,.FALSE.,.FALSE., LWPTSC1C.235
& .TRUE. ,.FALSE. ,.TRUE.,.FALSE.,.FALSE.,.TRUE. ,.FALSE., LWPTSC1C.236
& .TRUE. ,.TRUE. ,.TRUE.,.FALSE.,.FALSE.,.TRUE. ,.TRUE. , LWPTSC1C.237
& .FALSE. ,.FALSE. ,.TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE./ LWPTSC1C.238
! LWPTSC1C.239
DATA DOPPL/0.0, 0.0, 3.E3, 150., 1E5, 0.0 , 0.0/ LWPTSC1C.240
! LWPTSC1C.241
!...................................................................... LWPTSC1C.242
! LWPTSC1C.243
! LWPTSC1C.244
!...Set up dab's and dbb's LWPTSC1C.245
! LWPTSC1C.246
DO LEVEL = 1, NLEVS LWPTSC1C.247
DAB(LEVEL) = AB(LEVEL) - AB(LEVEL+1) LWPTSC1C.248
DBB(LEVEL) = BB(LEVEL) - BB(LEVEL+1) LWPTSC1C.249
ENDDO ! LEVELS LWPTSC1C.250
! LWPTSC1C.251
! LWPTSC1C.252
!...For the gas-band combinations for which scaling is required: LWPTSC1C.253
! - set up index arrays to point to the gases and bands LWPTSC1C.254
! For others LWPTSC1C.255
! - set dpath = absamt * diffusivity factor straight away LWPTSC1C.256
! LWPTSC1C.257
NGBCOM = 0 LWPTSC1C.258
! LWPTSC1C.259
! LWPTSC1C.260
DO BAND = 1,NBANDS LWPTSC1C.261
DO GAS = 1,NSCGUS LWPTSC1C.262
IF ((GSINBS(GAS,BAND).EQ.1).AND.(SCALE(GAS,BAND))) THEN LWPTSC1C.263
NGBCOM = NGBCOM + 1 LWPTSC1C.264
INDXB(NGBCOM) = BAND LWPTSC1C.265
INDXG(NGBCOM) = GAS LWPTSC1C.266
ENDIF LWPTSC1C.267
ENDDO ! GAS LWPTSC1C.268
ENDDO ! BAND LWPTSC1C.269
! LWPTSC1C.270
!... for unscaled combinations.... LWPTSC1C.271
! LWPTSC1C.272
COCOTM=DSTRNG/(2.*G*RMOL) LWPTSC1C.273
DO BAND=1,NBANDS LWPTSC1C.274
! ...H2OS LWPTSC1C.275
IF((GSINBS(NH2OS,BAND).EQ.1).AND.(.NOT.SCALE(NH2OS,BAND)))THEN LWPTSC1C.276
DO LEVEL = 1,NWET LWPTSC1C.277
DO J=1,L2 LWPTSC1C.278
DPATH(J,LEVEL,NH2OS,BAND)= LWPTSC1C.279
& H2O(J,LEVEL)*H2O(J,LEVEL) * LWPTSC1C.280
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.281
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.282
& COCOTM / TAC(J,LEVEL) LWPTSC1C.283
ENDDO ! J LWPTSC1C.284
ENDDO ! LEVEL LWPTSC1C.285
! LWPTSC1C.286
DO LEVEL = NWET+1,NLEVS LWPTSC1C.287
DO J=1,L2 LWPTSC1C.288
DPATH(J,LEVEL,NH2OS,BAND)= LWPTSC1C.289
& H2OMIN*H2OMIN * LWPTSC1C.290
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.291
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.292
& COCOTM / TAC(J,LEVEL) LWPTSC1C.293
ENDDO ! J LWPTSC1C.294
ENDDO ! LEVEL LWPTSC1C.295
END IF LWPTSC1C.296
! LWPTSC1C.297
! H2O-foreign LWPTSC1C.298
! LWPTSC1C.299
IF((GSINBS(NH2OF,BAND).EQ.1).AND.(.NOT.SCALE(NH2OF,BAND)))THEN LWPTSC1C.300
DO LEVEL = 1,NWET LWPTSC1C.301
DO J=1,L2 LWPTSC1C.302
DPATH(J,LEVEL,NH2OS,BAND)= LWPTSC1C.303
& H2O(J,LEVEL)*(1.-H2O(J,LEVEL)) * LWPTSC1C.304
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.305
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.306
& COCOTM / TAC(J,LEVEL) LWPTSC1C.307
ENDDO ! J LWPTSC1C.308
ENDDO ! LEVEL LWPTSC1C.309
! LWPTSC1C.310
DO LEVEL = NWET+1,NLEVS LWPTSC1C.311
DO J=1,L2 LWPTSC1C.312
DPATH(J,LEVEL,NH2OS,BAND)= LWPTSC1C.313
& H2OMIN*(1.-H2OMIN) * LWPTSC1C.314
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.315
& (DAB(LEVEL)+DBB(LEVEL)*PSTAR(J))* LWPTSC1C.316
& COCOTM / TAC(J,LEVEL) LWPTSC1C.317
ENDDO ! J LWPTSC1C.318
ENDDO ! LEVEL LWPTSC1C.319
END IF LWPTSC1C.320
! LWPTSC1C.321
! H2O-line LWPTSC1C.322
! LWPTSC1C.323
IF((GSINBS(NH2OL,BAND).EQ.1).AND.(.NOT.SCALE(NH2OL,BAND)))THEN LWPTSC1C.324
DO LEVEL = 1,NWET LWPTSC1C.325
DO J=1,L2 LWPTSC1C.326
DPATH(J,LEVEL,NH2OL,BAND) = DSTRNG * H2O(J,LEVEL) * LWPTSC1C.327
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.328
ENDDO ! J LWPTSC1C.329
ENDDO ! LEVEL LWPTSC1C.330
! LWPTSC1C.331
DO LEVEL = NWET+1,NLEVS LWPTSC1C.332
DO J=1,L2 LWPTSC1C.333
DPATH(J,LEVEL,NH2OL,BAND) = DSTRNG * H2OMIN * LWPTSC1C.334
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.335
ENDDO ! J LWPTSC1C.336
ENDDO ! LEVEL LWPTSC1C.337
END IF LWPTSC1C.338
! LWPTSC1C.339
! CO2 LWPTSC1C.340
! LWPTSC1C.341
IF((GSINBS(NCO2,BAND).EQ.1).AND.(.NOT.SCALE(NCO2,BAND)))THEN LWPTSC1C.342
DO LEVEL = 1,NLEVS LWPTSC1C.343
DO J=1,L2 LWPTSC1C.344
DPATH(J,LEVEL,NCO2,BAND) = DSTRNG * CO2 * LWPTSC1C.345
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.346
ENDDO ! J LWPTSC1C.347
ENDDO !LEVEL LWPTSC1C.348
END IF LWPTSC1C.349
! LWPTSC1C.350
! O3 LWPTSC1C.351
! LWPTSC1C.352
IF((GSINBS(NO3,BAND).EQ.1).AND.(.NOT.SCALE(NO3,BAND)))THEN LWPTSC1C.353
DO LEVEL = 1,NLEVS-NOZONE LWPTSC1C.354
DO J=1,L2 LWPTSC1C.355
DPATH(J,LEVEL,NO3,BAND)=DSTRNG*O3(J,1) * LWPTSC1C.356
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.357
ENDDO ! J LWPTSC1C.358
ENDDO ! LEVEL LWPTSC1C.359
! LWPTSC1C.360
DO LEVEL = NLEVS-NOZONE+1,NLEVS LWPTSC1C.361
DO J=1,L2 LWPTSC1C.362
DPATH(J,LEVEL,NO3,BAND)=DSTRNG*O3(J,LEVEL+NOZONE-NLEVS)* LWPTSC1C.363
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.364
ENDDO ! J LWPTSC1C.365
ENDDO ! LEVEL LWPTSC1C.366
END IF LWPTSC1C.367
! LWPTSC1C.368
! N2O LWPTSC1C.369
! LWPTSC1C.370
IF((GSINBS(NN2O,BAND).EQ.1).AND.(.NOT.SCALE(NN2O,BAND)))THEN LWPTSC1C.371
DO LEVEL = 1,NLEVS LWPTSC1C.372
DO J=1,L2 LWPTSC1C.373
DPATH(J,LEVEL,NN2O,BAND) = DSTRNG * N2O(LEVEL) * LWPTSC1C.374
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.375
ENDDO ! J LWPTSC1C.376
ENDDO ! LEVEL LWPTSC1C.377
END IF LWPTSC1C.378
! LWPTSC1C.379
! CH4 LWPTSC1C.380
IF((GSINBS(NCH4,BAND).EQ.1).AND.(.NOT.SCALE(NCH4,BAND)))THEN LWPTSC1C.381
DO LEVEL = 1,NLEVS LWPTSC1C.382
DO J=1,L2 LWPTSC1C.383
DPATH(J,LEVEL,NCH4,BAND) = DSTRNG * CH4(LEVEL) * LWPTSC1C.384
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.385
ENDDO ! J LWPTSC1C.386
ENDDO ! LEVEL LWPTSC1C.387
END IF LWPTSC1C.388
! LWPTSC1C.389
ENDDO ! BAND LWPTSC1C.390
! LWPTSC1C.391
! LWPTSC1C.392
!...for CFCs just set up pathlength * diffusivity factor LWPTSC1C.393
! LWPTSC1C.394
DO BAND = 1,NBANDS LWPTSC1C.395
! LWPTSC1C.396
IF (GSINBS(NCFC11,BAND).EQ.1) THEN LWPTSC1C.397
DO LEVEL = 1,NLEVS LWPTSC1C.398
DO J = 1,L2 LWPTSC1C.399
DPATH(J,LEVEL,NCFC11,BAND) = DWEAK *CFC11(LEVEL)* LWPTSC1C.400
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.401
ENDDO ! J LWPTSC1C.402
ENDDO ! LEVEL LWPTSC1C.403
END IF LWPTSC1C.404
LWPTSC1C.405
IF (GSINBS(NCFC12,BAND).EQ.1) THEN LWPTSC1C.406
DO LEVEL = 1,NLEVS LWPTSC1C.407
DO J = 1,L2 LWPTSC1C.408
DPATH(J,LEVEL,NCFC12,BAND) = DWEAK * CFC12(LEVEL)* LWPTSC1C.409
& (PSTAR(J)*DBB(LEVEL)+DAB(LEVEL)) / G LWPTSC1C.410
ENDDO ! J LWPTSC1C.411
ENDDO ! LEVEL LWPTSC1C.412
END IF LWPTSC1C.413
LWPTSC1C.414
ENDDO ! BAND LWPTSC1C.415
! LWPTSC1C.416
!.....calculate constant terms in scaling calc LWPTSC1C.417
! and initialise work array at surface for start of scaling loop LWPTSC1C.418
! LWPTSC1C.419
COCOTM=DSTRNG/G LWPTSC1C.420
! LWPTSC1C.421
DO GBCOM = 1,NGBCOM LWPTSC1C.422
GAS = INDXG(GBCOM) LWPTSC1C.423
BAND = INDXB(GBCOM) LWPTSC1C.424
GBTM(GAS,BAND) = TREFS(GAS)**BETA(GAS,BAND) LWPTSC1C.425
& *(PREFS(GAS)+DOPPL(GAS))**ALPHA(GAS,BAND) LWPTSC1C.426
& *(ALPHA(GAS,BAND)+ALPADD(GAS)) LWPTSC1C.427
& * MULTR(GAS) LWPTSC1C.428
! LWPTSC1C.429
DO J = 1,L2 LWPTSC1C.430
WORK(J,1,GBCOM) = (PSTAR(J)+DOPPL(GAS)) ** LWPTSC1C.431
& (ALPHA(GAS,BAND)+ALPADD(GAS)) LWPTSC1C.432
ENDDO ! J LWPTSC1C.433
! LWPTSC1C.434
ENDDO ! GBCOM LWPTSC1C.435
! LWPTSC1C.436
!...calculate other terms for scaled gases LWPTSC1C.437
! LWPTSC1C.438
! first get the gas dependent terms LWPTSC1C.439
! LWPTSC1C.440
! LWPTSC1C.441
ONETWO = 1 LWPTSC1C.442
C LWPTSC1C.443
DO LEVEL = 1,NLEVS LWPTSC1C.444
GASOLD = 0 LWPTSC1C.445
LWPTSC1C.446
DO GBCOM = 1,NGBCOM LWPTSC1C.447
BAND = INDXB(GBCOM) LWPTSC1C.448
GAS = INDXG(GBCOM) LWPTSC1C.449
C LWPTSC1C.450
IF (GAS.NE.GASOLD) THEN LWPTSC1C.451
! LWPTSC1C.452
IF (GAS.EQ.NH2OS) THEN LWPTSC1C.453
IF (LEVEL.LE.NWET) THEN LWPTSC1C.454
DO J=1,L2 LWPTSC1C.455
TMPGAS(J)= H2O(J,LEVEL)*H2O(J,LEVEL) LWPTSC1C.456
ENDDO ! J LWPTSC1C.457
ELSE LWPTSC1C.458
DO J=1,L2 LWPTSC1C.459
TMPGAS(J)= H2OMIN LWPTSC1C.460
ENDDO ! J LWPTSC1C.461
END IF LWPTSC1C.462
! LWPTSC1C.463
ELSE IF (GAS.EQ.NH2OF) THEN LWPTSC1C.464
IF (LEVEL.LE.NWET) THEN LWPTSC1C.465
DO J=1,L2 LWPTSC1C.466
TMPGAS(J)= H2O(J,LEVEL)*(1.-H2O(J,LEVEL)) LWPTSC1C.467
ENDDO ! J LWPTSC1C.468
ELSE LWPTSC1C.469
DO J=1,L2 LWPTSC1C.470
TMPGAS(J)= H2OMIN LWPTSC1C.471
ENDDO ! J LWPTSC1C.472
END IF LWPTSC1C.473
! LWPTSC1C.474
ELSE IF (GAS.EQ.NH2OL) THEN LWPTSC1C.475
IF (LEVEL.LE.NWET) THEN LWPTSC1C.476
DO J = 1,L2 LWPTSC1C.477
TMPGAS(J) = H2O(J,LEVEL) LWPTSC1C.478
ENDDO ! J LWPTSC1C.479
ELSE LWPTSC1C.480
DO J = 1,L2 LWPTSC1C.481
TMPGAS(J) = H2OMIN LWPTSC1C.482
ENDDO ! J LWPTSC1C.483
END IF LWPTSC1C.484
! LWPTSC1C.485
ELSE IF (GAS.EQ.NCO2) THEN LWPTSC1C.486
DO J = 1,L2 LWPTSC1C.487
TMPGAS(J) = CO2 LWPTSC1C.488
ENDDO ! J LWPTSC1C.489
! LWPTSC1C.490
ELSE IF (GAS.EQ.NO3) THEN LWPTSC1C.491
IF (LEVEL.LE.NLEVS-NOZONE) THEN LWPTSC1C.492
DO J = 1,L2 LWPTSC1C.493
TMPGAS(J) = O3(J,1) LWPTSC1C.494
ENDDO ! J LWPTSC1C.495
ELSE LWPTSC1C.496
DO J = 1,L2 LWPTSC1C.497
TMPGAS(J) = O3(J,LEVEL+NOZONE-NLEVS) LWPTSC1C.498
ENDDO ! J LWPTSC1C.499
END IF LWPTSC1C.500
! LWPTSC1C.501
ELSE IF (GAS.EQ.NN2O) THEN LWPTSC1C.502
DO J = 1,L2 LWPTSC1C.503
TMPGAS(J) = N2O(LEVEL) LWPTSC1C.504
ENDDO ! J LWPTSC1C.505
! LWPTSC1C.506
ELSE IF (GAS.EQ.NCH4) THEN LWPTSC1C.507
DO J = 1,L2 LWPTSC1C.508
TMPGAS(J) = CH4(LEVEL) LWPTSC1C.509
ENDDO ! J LWPTSC1C.510
END IF LWPTSC1C.511
! LWPTSC1C.512
END IF LWPTSC1C.513
! LWPTSC1C.514
!...now the rest, and put everything together LWPTSC1C.515
! LWPTSC1C.516
DO J = 1,L2 LWPTSC1C.517
! LWPTSC1C.518
PTOP = PSTAR(J) * BB(LEVEL+1) + AB(LEVEL+1) LWPTSC1C.519
WORK(J,3-ONETWO,GBCOM)=(PTOP+DOPPL(GAS)) LWPTSC1C.520
& **(ALPHA(GAS,BAND)+ALPADD(GAS)) LWPTSC1C.521
DPATH(J,LEVEL,GAS,BAND) = LWPTSC1C.522
& ( (WORK(J,ONETWO,GBCOM) - WORK(J,3-ONETWO,GBCOM)) LWPTSC1C.523
& * TAC(J,LEVEL)**(BETA(GAS,BAND)-BETMIN(GAS)) LWPTSC1C.524
& * TMPGAS(J) * COCOTM / GBTM(GAS,BAND) ) LWPTSC1C.525
! LWPTSC1C.526
ENDDO ! J LWPTSC1C.527
GASOLD = GAS LWPTSC1C.528
! LWPTSC1C.529
ENDDO ! GBCOM LWPTSC1C.530
ONETWO = 3 - ONETWO LWPTSC1C.531
! LWPTSC1C.532
ENDDO ! LEVEL LWPTSC1C.533
! LWPTSC1C.534
! LWPTSC1C.535
! LWPTSC1C.536
RETURN LWPTSC1C.537
END LWPTSC1C.538
! LWPTSC1C.539
*ENDIF A02_1C LWPTSC1C.540