SUBROUTINE RAD_CTL(CLOUD_FRACTION,SIN_TRUE_LATITUDE,DAY_FRACTION, 1,101RAD_CTL1.49
& COS_ZENITH_ANGLE, NETSW, SURF_RADFLUX, LIST, SWITCH, RAD_CTL1.50
& AREA_CLOUD_FRACTION, ASK1F405.262
& RAD_NO_SNOW, RAD_SNOW, SNOW_FRAC_LAND, ARE2F404.72
& PHOTOSYNTH_ACT_RAD,RADHEAT_RATE, ARN1F404.120
& P_FIELDDA,P_LEVELSDA,Q_LEVELSDA,OZONE_LEVELSDA, @DYALLOC.2995
& CLOUD_LEVELSDA,BL_LEVELSDA,L_RADHEAT,RADHEAT_DIM1, ARN1F404.121
& SWBANDS, STASHLEN, CO2_DIM1, CO2_DIM2, ACN2F405.44
& SULP_DIM1, SULP_DIM2, SOOT_DIM1, SOOT_DIM2, ALR3F405.19
& NLALBS, W1236_DIM, SAL_DIM, ALR3F405.20
*CALL ARGSIZE 
@DYALLOC.2997
*CALL ARGD1 @DYALLOC.2998
*CALL ARGDUMA @DYALLOC.2999
*CALL ARGDUMO @DYALLOC.3000
*CALL ARGDUMW GKR1F401.252
*CALL ARGSTS @DYALLOC.3001
*CALL ARGPTRA @DYALLOC.3002
*CALL ARGPTRO @DYALLOC.3003
*CALL ARGCONA @DYALLOC.3004
*CALL ARGPPX GKR0F305.973
*CALL ARGFLDPT APBBF401.3
*IF DEF,FRADIO GGH3F401.26
& RADINCS, @DYALLOC.3006
*ENDIF @DYALLOC.3007
& ICODE,CMESSAGE) @DYALLOC.3008
RAD_CTL1.52
IMPLICIT NONE RAD_CTL1.53
@DYALLOC.3009
*CALL CMAXSIZE @DYALLOC.3010
*CALL CSUBMODL GSS1F305.935
*CALL TYPSIZE @DYALLOC.3011
*CALL TYPD1 @DYALLOC.3012
*CALL TYPDUMA @DYALLOC.3013
*CALL TYPDUMO @DYALLOC.3014
*CALL TYPDUMW GKR1F401.253
*CALL TYPSTS @DYALLOC.3015
*CALL TYPPTRA @DYALLOC.3016
*CALL TYPPTRO @DYALLOC.3017
*CALL TYPCONA @DYALLOC.3018
*CALL PPXLOOK GKR0F305.974
*CALL TYPFLDPT APBBF401.4
RAD_CTL1.54
INTEGER RAD_CTL1.55
& ICODE, ! Return code : 0 Normal Exit RAD_CTL1.56
C ! : >0 Error RAD_CTL1.57
& P_FIELDDA, ! IN: Extra values of P_FIELD @DYALLOC.3019
& P_LEVELSDA, ! and P_LEVELS @DYALLOC.3020
& Q_LEVELSDA, ! and Q_LEVELS @DYALLOC.3021
& OZONE_LEVELSDA,! and OZONE_LEVELS @DYALLOC.3022
& CLOUD_LEVELSDA,! and CLOUD_LEVELS @DYALLOC.3023
& BL_LEVELSDA, ! and BL_LEVELS ARN1F404.123
& RADHEAT_DIM1, ! Dimension for RADHEAT_RATE ARN1F404.124
& STASHLEN, ! Maximum length for diagnostic space for RAD_CTL1.60
C ! sections 1 and 2 RAD_CTL1.61
& SOOT_DIM1,SOOT_DIM2, !IN, dimensions for soot arrays ALR3F405.21
& SULP_DIM1,SULP_DIM2, !IN, dimensions for _SULPHATE arrays ADB1F401.770
& CO2_DIM1,CO2_DIM2, !IN, dimensions for CO2_3D array ACN2F405.45
& NLALBS, ! IN Number of fields of land surface albedo AWI1F403.140
& W1236_DIM, ! IN Dimensions array used only if SF(236,1) AWI1F404.13
& SAL_DIM, ! IN Dimensions arrays used only if ARE2F404.74
C ! L_SNOW_ALBEDO = .TRUE. ARE2F404.75
& LIST(P_FIELDDA) @DYALLOC.3024
& ,SWBANDS !IN No of short wave bands used in rad scheme AD080293.5
RAD_CTL1.63
REAL RAD_CTL1.64
& CLOUD_FRACTION(P_FIELDDA,Q_LEVELSDA), @DYALLOC.3025
& RADHEAT_RATE(RADHEAT_DIM1,BL_LEVELSDA), ARN1F404.125
& AREA_CLOUD_FRACTION(P_FIELDDA,Q_LEVELSDA), ASK1F405.263
! Radiation only cloud fraction (always >= cloud_fraction) ASK1F405.264
! ASK1F405.265
& SIN_TRUE_LATITUDE(P_FIELDDA), @DYALLOC.3026
& DAY_FRACTION(P_FIELDDA), @DYALLOC.3027
& COS_ZENITH_ANGLE(P_FIELDDA), @DYALLOC.3028
& NETSW(P_FIELDDA), @DYALLOC.3029
& NET_ATM_FLUX(P_FIELDDA), GSS1F304.768
& SURF_RADFLUX(P_FIELDDA) @DYALLOC.3031
& ,RAD_NO_SNOW(P_FIELDDA) ! Surface net radiation, ARE2F404.76
C ! snow-free fraction ARE2F404.77
& ,RAD_SNOW(P_FIELDDA) ! Surface net radiation, ARE2F404.78
C ! snow-covered fraction ARE2F404.79
& ,SNOW_FRAC_LAND(LAND_FIELD) ! Snow cover fraction on ARE2F404.80
C ! land points ARE2F404.81
& ,PHOTOSYNTH_ACT_RAD(P_FIELDDA) ! Photosynthetically active AJS1F401.956
C ! radiation AJS1F401.957
RAD_CTL1.74
LOGICAL RAD_CTL1.75
& SWITCH(P_FIELDDA) @DYALLOC.3032
LOGICAL L_RADHEAT ! True if RADHEAT_RATE to be calculated. ARN1F404.126
RAD_CTL1.77
CHARACTER*(80) TS150793.143
& CMESSAGE ! Error message if return code >0 RAD_CTL1.79
RAD_CTL1.80
*IF DEF,MPP APB1F305.363
! Parameters and Common blocks APB1F305.364
*CALL PARVARS APB1F305.365
*ENDIF APB1F305.366
*CALL CHSUNITS RS030293.129
*CALL CCONTROL RAD_CTL1.82
*CALL CTIME RAD_CTL1.86
*CALL CHISTORY GDR3F305.158
*CALL C_OMEGA RAD_CTL1.88
*CALL C_MDI RAD_CTL1.89
*CALL SWSC RAD_CTL1.90
*CALL C_R_CP AWI1F402.1
*CALL RAD_COM AWA1F304.1394
*IF DEF,FRADIO GGH3F401.27
*CALL CRADINCS RAD_CTL1.92
*ENDIF RAD_CTL1.93
*CALL CRUNTIMC ADR1F305.115
*CALL CSENARIO AWI1F403.142
*CALL NSTYPES ARE2F404.82
*CALL CSIGMA ARE2F404.83
*CALL MXSIZE3A ADB2F404.907
RAD_CTL1.94
CL Subroutines called RAD_CTL1.95
RAD_CTL1.96
EXTERNAL RAD_CTL1.97
& SOLPOS, SOLANG, FTSA, SWRAD, LWRAD, TIMER, STASH GSS1F403.54
& ,SETPOS,COPYDIAG,COPYDIAG_3D,EXTDIAG,BUFFIN,BUFFOUT RAD_CTL1.99
& ,SET_PSEUDO_LIST, SET_LEVELS_LIST RAD_CTL1.100
& ,TROPIN ADB2F404.908
& ,FLUX_DIAG GSS1F304.769
& ,R2_SWRAD, R2_LWRAD ADB2F404.909
RAD_CTL1.104
ADB1F400.62
CL Dynamically allocated area for stash processing RAD_CTL1.105
RAD_CTL1.106
REAL RAD_CTL1.107
& STASHWORK(STASHLEN) RAD_CTL1.108
RAD_CTL1.109
CL Other dynamically allocated space RAD_CTL1.110
RAD_CTL1.111
REAL RAD_CTL1.112
*IF -DEF,FRADIO GGH3F401.28
C Include extra levels in RADINCS to hold band 1 net surface SW before ARE2F404.84
C zenith angle adjustment and surface albedo or surface radiative temp ARE2F404.85
& RADINCS((P_FIELDDA*(P_LEVELSDA+3)+511)/512*512), ARE2F404.86
*ENDIF RAD_CTL1.115
& OZONE_1(P_FIELDDA,OZONE_LEVELSDA), GDR3F305.159
& MEAN_COSZ(P_FIELDDA), ! Mean cos(solar zenith angle) @DYALLOC.3035
C ! over the whole SW timestep (including any night time) RAD_CTL1.118
& SAL_VIS(SAL_DIM,2), ARE2F404.87
& SAL_NIR(SAL_DIM,2), ARE2F404.88
& LAND_AND_ICE_ALBEDO(P_FIELDDA,NLALBS), AWI1F403.143
& NO_SULPHATE_ALBEDO(W1236_DIM,2), AWI1F403.144
& OPEN_SEA_ALBEDO(P_FIELDDA,2), @DYALLOC.3037
& OLR(P_FIELDDA) @DYALLOC.3038
& ,ALBSNF(P_FIELDDA) ARE2F404.89
& ,SNOW_FRAC(P_FIELDDA) ARE2F404.90
& ,TSTAR_RAD(P_FIELDDA) ARE2F404.91
& ,TSTAR_SNOW(P_FIELDDA) ARE2F404.92
& ,CO2_3D(CO2_DIM1,CO2_DIM2) ACN2F405.46
RAD_CTL1.122
C RADINCS dimensioned for 512word blocking RAD_CTL1.123
AWI1F402.3
INTEGER TRINDX(P_FIELDDA) AWI1F402.4
C RAD_CTL1.124
C Levels Lists & Pseudo-levels Lists for diagnostics which are the RAD_CTL1.125
C product of Layer & Convective cloud Amounts * Albedos to diRect & RAD_CTL1.126
C diFfuse light. RAD_CTL1.127
LOGICAL LLLAAR(CLOUD_LEVELSDA), LLLAAF(CLOUD_LEVELSDA), @DYALLOC.3039
& PLLAAR(SWBANDS), PLLAAF(SWBANDS), AD080293.6
& PLCAAR(SWBANDS), PLCAAF(SWBANDS) AD080293.7
RAD_CTL1.131
C Local variables RAD_CTL1.132
! ADB1F400.63
LOGICAL ADB1F400.64
& L_3_CLOUD !Logical for reduction to 3-clouds ADB1F400.65
& ,L_FLUX_BELOW_690NM_SURF !Logical to calculate surface flux ADB1F401.771
!below 690 nm ADB1F401.772
& ,L_GLOBAL_CLOUD_TOP !Logical to use a global value for the ADB1F402.834
& !topmost cloudy layer under 3A-radiation. ADB1F402.835
& ,L_CLOUD_WATER_PARTITION AYY1F404.248
! Logical for cloud ice/water partition AYY1F404.249
& ,L_MOSES_II !Logical for MOSES II land-surface scheme ARE2F404.93
& ,L_CO2_3D ! local logical to control use of 3D co2 field ACN2F405.47
! ADB1F401.773
! Local Arrays for the Sulphur Cycle ADB1F401.774
REAL ADB1F401.775
& ACCUM_SULPHATE(SULP_DIM1,SULP_DIM2) ADB1F401.776
! Local array of accumulation-mode Sulphate ADB1F401.777
& , AITKEN_SULPHATE(SULP_DIM1,SULP_DIM2) ADB1F401.778
! Local array of Aitken-mode Sulphate ADB1F401.779
& , DISS_SULPHATE(SULP_DIM1,SULP_DIM2) ADB2F404.910
! Local array of dissolved sulphate ADB2F404.911
&,FRESH_SOOT(SOOT_DIM1,SOOT_DIM2),AGED_SOOT(SOOT_DIM1,SOOT_DIM2) ALR3F405.23
! Fresh and aged soot MMRs. ALR3F405.24
! ADB1F401.780
INTEGER SEG_POINTS_TEMP(MAX_NO_OF_SEGS), AAD1F304.87
& FIRST_POINT_TEMP(MAX_NO_OF_SEGS), AAD1F304.88
& JS_TEMP(MAX_NO_OF_SEGS) AAD1F304.89
AAD1F304.90
INTEGER RAD_CTL1.134
& JS,JS_LOCAL(MAX_NO_OF_SEGS), AAD1F304.91
& FIRST_POINT,FP_LOCAL(MAX_NO_OF_SEGS), AAD1F304.92
& LAST_POINT, RAD_CTL1.138
& FIRST_POINT_SAL, ARE2F404.94
& LAND1, ! First land point to be processed ABX1F405.117
& LAND_PTS, ! Number of land points to be processed ABX1F405.118
& I,J,L,N, ARE2F404.95
& ROW, RAD_CTL1.140
& MIN_TROP, MAX_TROP, AWI1F402.5
& POINT, RAD_CTL1.141
& POINTS, RAD_CTL1.142
& STEP, RAD_CTL1.143
& N_SW_SEGMENTS, RAD_CTL1.144
& DAYLIGHT_POINTS, RAD_CTL1.145
& D1236_DIM, AWI1F404.14
& SEG_START, RAD_CTL1.146
& LIT_POINTS, RAD_CTL1.147
& RAD_ARRAY_SIZE, ADB1F400.66
! ACTUAL SIZE OF RADIATIVE ARRAY ADB1F400.67
& START_POINT, RAD_CTL1.148
& SEG_POINTS,SP_LOCAL(MAX_NO_OF_SEGS), AAD1F304.93
& LEN, RAD_CTL1.150
& NFTSWAP, RAD_CTL1.151
& LEN_IO, RAD_CTL1.152
& BAND, RAD_CTL1.153
& OFFSET, RAD_CTL1.154
& LEVEL RAD_CTL1.155
& ,IM_IDENT ! internal model identifier GRB4F305.346
& ,IM_INDEX ! internal model index for STASH arrays GRB4F305.347
& , FIRST_POINT_SULPC ! First point of array of sulphate ADB1F402.586
& ,FIRST_POINT_SOOT ALR3F405.22
! passed to subroutine ADB1F402.587
& , FIRST_POINT_CO2 ! First point of array of CO2 ACN2F405.48
& , GLOBAL_CLOUD_TOP ! Global topmost cloudy layer ADB1F402.588
& ! (for 3A-radiation) ADB1F402.589
& , INFO ! Return Code from GCOM routines. ADR3F403.3
RAD_CTL1.156
REAL RAD_CTL1.157
& SINDEC, ! Sin of the solar declination RAD_CTL1.158
& SCS, ! Solar constant scaling factor RAD_CTL1.159
& SULPH_C(NSULPAT), AWI1F403.145
! ! Coefficients of sulphate loading patterns if L_H2_SULPH. AWI1F403.146
& TIME, RAD_CTL1.160
& TIMESTEP, RAD_CTL1.161
& A_IO RAD_CTL1.162
! ADB1F400.70
INTEGER ADB1F400.71
& NPDWD_CL_PROFILE ADB2F404.912
! Dimension for work space in radiation ADB2F404.913
! ADB2F404.914
! ADB2F404.915
! Declaration of spectral files for 3A-radiation. ADB2F404.916
*CALL SWSPDL3A ADB2F404.917
*CALL LWSPDL3A ADB2F404.918
! Common blocks of spectral data for 3A-radiation. ADB2F404.919
*CALL SWSPCM3A ADB2F404.920
*CALL LWSPCM3A ADB2F404.921
! Declaration of algorithmic options for 3A-radiation. ADB2F404.922
*CALL SWOPT3A ADB2F404.923
*CALL LWOPT3A ADB2F404.924
! Common blocks of algorithmic options for 3A-radiation. ADB2F404.925
*CALL SWCOPT3A ADB2F404.926
*CALL LWCOPT3A ADB2F404.927
! ADB2F404.928
! ADB2F404.929
ADB1F400.88
CL--- SECTION 0 --- INITIALISATION -------------------- RAD_CTL1.164
GRB4F305.348
C Set up internal model identifier and STASH index GRB4F305.349
im_ident = atmos_im GRB4F305.350
im_index = internal_model_index(im_ident) GRB4F305.351
RAD_CTL1.165
FIRST_POINT = START_POINT_NO_HALO APBBF401.5
LAST_POINT = END_P_POINT_NO_HALO APBBF401.6
POINTS = LAST_POINT-FIRST_POINT+1 APBBF401.7
JS = FIRST_POINT-1 APBBF401.8
RAD_CTL1.171
! Set land points to be processed ABX1F405.119
LAND1 = 1 ABX1F405.120
LAND_PTS = 0 ABX1F405.121
DO L=1,LAND_FIELD ABX1F405.122
IF ( LAND_LIST(L) .LT. FIRST_POINT ) THEN ABX1F405.123
LAND1 = LAND1 + 1 ABX1F405.124
ELSEIF ( LAND_LIST(L) .LE. FIRST_POINT+POINTS-1 ) THEN ABX1F405.125
LAND_PTS = LAND_PTS + 1 ABX1F405.126
ENDIF ABX1F405.127
ENDDO ABX1F405.128
ABX1F405.129
C SAL arrays not accessed (removes bounds checking messages) ARE2F404.96
ARE2F404.97
IF( L_SNOW_ALBEDO ) THEN ARE2F404.98
FIRST_POINT_SAL = FIRST_POINT ARE2F404.99
ELSE ARE2F404.100
FIRST_POINT_SAL = 1 ARE2F404.101
ENDIF ARE2F404.102
ARE2F404.103
C INITIALISE OUTPUT ARRAYS TO ZERO RAD_CTL1.172
RAD_CTL1.173
DO I=1,P_FIELD RAD_CTL1.174
SURF_RADFLUX(I) = 0.0 RAD_CTL1.175
RAD_NO_SNOW(I) = 0.0 ARE2F404.104
RAD_SNOW(I) = 0.0 ARE2F404.105
PHOTOSYNTH_ACT_RAD(I) = 0.0 AJS1F401.961
END DO RAD_CTL1.176
DO I=1,STASHLEN RAD_CTL1.177
STASHWORK(I)=0.0 RAD_CTL1.178
END DO RAD_CTL1.179
RAD_CTL1.180
CL 0.0 Set the polar points in PHOTOSYNTH_ACT_RAD to MDI AJS1F401.962
AJS1F401.963
DO I=1,FIRST_POINT-1 AJS1F401.964
PHOTOSYNTH_ACT_RAD(I) = RMDI AJS1F401.965
ENDDO AJS1F401.966
AJS1F401.967
DO I=LAST_POINT+1,P_FIELD AJS1F401.968
PHOTOSYNTH_ACT_RAD(I) = RMDI AJS1F401.969
ENDDO AJS1F401.970
AJS1F401.971
CL 0.1 Calculate mixing ratio of well-mixed greenhouse gases from the AWI1F403.147
CL scenarios (unless they are constant). AWI1F403.148
AWI1F403.149
IF ( CLIM_FCG_NYEARS(S_CO2) .GT. 0 ) THEN ! CO2 level calculated AWI1F403.150
AWI1F403.151
IF ( LTIMER ) THEN AWI1F403.152
CALL TIMER ('GAS_CALC', 3) AWI1F403.153
END IF AWI1F403.154
AWI1F403.155
CALL GAS_CALC ( CO2_MMR, AWI1F403.156
& CLIM_FCG_NYEARS(S_CO2), CLIM_FCG_YEARS(1,S_CO2), AWI1F403.157
& CLIM_FCG_LEVLS(1,S_CO2), CLIM_FCG_RATES(1,S_CO2), AWI1F403.158
& LENSCEN, ICODE, CMESSAGE) AWI1F403.159
AWI1F403.160
IF ( LTIMER ) THEN AWI1F403.161
CALL TIMER ('GAS_CALC', 4) AWI1F403.162
END IF AWI1F403.163
AWI1F403.164
IF ( ICODE .NE. 0 ) RETURN AWI1F403.165
AWI1F403.166
ENDIF AWI1F403.167
AWI1F403.168
IF ( CLIM_FCG_NYEARS(S_N2O) .GT. 0 ) THEN ! N2O level calculated AWI1F403.169
AWI1F403.170
IF ( LTIMER ) THEN AWI1F403.171
CALL TIMER ('GAS_CALC', 3) AWI1F403.172
END IF AWI1F403.173
AWI1F403.174
CALL GAS_CALC ( N2OMMR, AWI1F403.175
& CLIM_FCG_NYEARS(S_N2O), CLIM_FCG_YEARS(1,S_N2O), AWI1F403.176
& CLIM_FCG_LEVLS(1,S_N2O), CLIM_FCG_RATES(1,S_N2O), AWI1F403.177
& LENSCEN, ICODE, CMESSAGE) AWI1F403.178
AWI1F403.179
IF ( LTIMER ) THEN AWI1F403.180
CALL TIMER ('GAS_CALC', 4) AWI1F403.181
END IF AWI1F403.182
AWI1F403.183
IF ( ICODE .NE. 0 ) RETURN AWI1F403.184
AWI1F403.185
ENDIF AWI1F403.186
AWI1F403.187
IF ( CLIM_FCG_NYEARS(S_CH4) .GT. 0 ) THEN ! CH4 level calculated AWI1F403.188
AWI1F403.189
IF ( LTIMER ) THEN AWI1F403.190
CALL TIMER ('GAS_CALC', 3) AWI1F403.191
END IF AWI1F403.192
AWI1F403.193
CALL GAS_CALC ( CH4MMR, AWI1F403.194
& CLIM_FCG_NYEARS(S_CH4), CLIM_FCG_YEARS(1,S_CH4), AWI1F403.195
& CLIM_FCG_LEVLS(1,S_CH4), CLIM_FCG_RATES(1,S_CH4), AWI1F403.196
& LENSCEN, ICODE, CMESSAGE) AWI1F403.197
AWI1F403.198
IF ( LTIMER ) THEN AWI1F403.199
CALL TIMER ('GAS_CALC', 4) AWI1F403.200
END IF AWI1F403.201
AWI1F403.202
IF ( ICODE .NE. 0 ) RETURN AWI1F403.203
AWI1F403.204
ENDIF AWI1F403.205
AWI1F403.206
IF ( CLIM_FCG_NYEARS(S_CFC11) .GT. 0 ) THEN ! Same for "CFC11" AWI1F403.207
AWI1F403.208
IF ( LTIMER ) THEN AWI1F403.209
CALL TIMER ('GAS_CALC', 3) AWI1F403.210
END IF AWI1F403.211
AWI1F403.212
CALL GAS_CALC ( C11MMR, AWI1F403.213
& CLIM_FCG_NYEARS(S_CFC11), CLIM_FCG_YEARS(1,S_CFC11), AWI1F403.214
& CLIM_FCG_LEVLS(1,S_CFC11), CLIM_FCG_RATES(1,S_CFC11), AWI1F403.215
& LENSCEN, ICODE, CMESSAGE) AWI1F403.216
AWI1F403.217
IF ( LTIMER ) THEN AWI1F403.218
CALL TIMER ('GAS_CALC', 4) AWI1F403.219
END IF AWI1F403.220
AWI1F403.221
IF ( ICODE .NE. 0 ) RETURN AWI1F403.222
AWI1F403.223
ENDIF AWI1F403.224
AWI1F403.225
IF ( CLIM_FCG_NYEARS(S_CFC12) .GT. 0 ) THEN ! Same for "CFC12" AWI1F403.226
AWI1F403.227
IF ( LTIMER ) THEN AWI1F403.228
CALL TIMER ('GAS_CALC', 3) AWI1F403.229
END IF AWI1F403.230
AWI1F403.231
CALL GAS_CALC ( C12MMR, AWI1F403.232
& CLIM_FCG_NYEARS(S_CFC12), CLIM_FCG_YEARS(1,S_CFC12), AWI1F403.233
& CLIM_FCG_LEVLS(1,S_CFC12), CLIM_FCG_RATES(1,S_CFC12), AWI1F403.234
& LENSCEN, ICODE, CMESSAGE) AWI1F403.235
AWI1F403.236
IF ( LTIMER ) THEN AWI1F403.237
CALL TIMER ('GAS_CALC', 4) AWI1F403.238
END IF AWI1F403.239
AWI1F403.240
IF ( ICODE .NE. 0 ) RETURN AWI1F403.241
AWI1F403.242
ENDIF AWI1F403.243
AWI1F403.244
IF ( CLIM_FCG_NYEARS(S_CFC113) .GT. 0 ) THEN ! Same for CFC113 ADB1F405.466
ADB1F405.467
IF ( LTIMER ) THEN ADB1F405.468
CALL TIMER ('GAS_CALC', 3) ADB1F405.469
END IF ADB1F405.470
ADB1F405.471
CALL GAS_CALC ( C113MMR, ADB1F405.472
& CLIM_FCG_NYEARS(S_CFC113), CLIM_FCG_YEARS(1,S_CFC113), ADB1F405.473
& CLIM_FCG_LEVLS(1,S_CFC113), CLIM_FCG_RATES(1,S_CFC113), ADB1F405.474
& LENSCEN, ICODE, CMESSAGE) ADB1F405.475
ADB1F405.476
IF ( LTIMER ) THEN ADB1F405.477
CALL TIMER ('GAS_CALC', 4) ADB1F405.478
END IF ADB1F405.479
ADB1F405.480
IF ( ICODE .NE. 0 ) RETURN ADB1F405.481
ADB1F405.482
ENDIF ADB1F405.483
ADB1F405.484
IF ( CLIM_FCG_NYEARS(S_HCFC22) .GT. 0 ) THEN ! Same for HCFC22 ADB1F405.485
ADB1F405.486
IF ( LTIMER ) THEN ADB1F405.487
CALL TIMER ('GAS_CALC', 3) ADB1F405.488
END IF ADB1F405.489
ADB1F405.490
CALL GAS_CALC ( HCFC22MMR, ADB1F405.491
& CLIM_FCG_NYEARS(S_HCFC22), CLIM_FCG_YEARS(1,S_HCFC22), ADB1F405.492
& CLIM_FCG_LEVLS(1,S_HCFC22), CLIM_FCG_RATES(1,S_HCFC22), ADB1F405.493
& LENSCEN, ICODE, CMESSAGE) ADB1F405.494
ADB1F405.495
IF ( LTIMER ) THEN ADB1F405.496
CALL TIMER ('GAS_CALC', 4) ADB1F405.497
END IF ADB1F405.498
ADB1F405.499
IF ( ICODE .NE. 0 ) RETURN ADB1F405.500
ADB1F405.501
ENDIF ADB1F405.502
ADB1F405.503
IF ( CLIM_FCG_NYEARS(S_HFC125) .GT. 0 ) THEN ! Same for HFC125 ADB1F405.504
ADB1F405.505
IF ( LTIMER ) THEN ADB1F405.506
CALL TIMER ('GAS_CALC', 3) ADB1F405.507
END IF ADB1F405.508
ADB1F405.509
CALL GAS_CALC ( HFC125MMR, ADB1F405.510
& CLIM_FCG_NYEARS(S_HFC125), CLIM_FCG_YEARS(1,S_HFC125), ADB1F405.511
& CLIM_FCG_LEVLS(1,S_HFC125), CLIM_FCG_RATES(1,S_HFC125), ADB1F405.512
& LENSCEN, ICODE, CMESSAGE) ADB1F405.513
ADB1F405.514
IF ( LTIMER ) THEN ADB1F405.515
CALL TIMER ('GAS_CALC', 4) ADB1F405.516
END IF ADB1F405.517
ADB1F405.518
IF ( ICODE .NE. 0 ) RETURN ADB1F405.519
ADB1F405.520
ENDIF ADB1F405.521
ADB1F405.522
IF ( CLIM_FCG_NYEARS(S_HFC134A) .GT. 0 ) THEN ! Same for HFC134A ADB1F405.523
ADB1F405.524
IF ( LTIMER ) THEN ADB1F405.525
CALL TIMER ('GAS_CALC', 3) ADB1F405.526
END IF ADB1F405.527
ADB1F405.528
CALL GAS_CALC ( HFC134AMMR, ADB1F405.529
& CLIM_FCG_NYEARS(S_HFC134A), CLIM_FCG_YEARS(1,S_HFC134A), ADB1F405.530
& CLIM_FCG_LEVLS(1,S_HFC134A), CLIM_FCG_RATES(1,S_HFC134A), ADB1F405.531
& LENSCEN, ICODE, CMESSAGE) ADB1F405.532
ADB1F405.533
IF ( LTIMER ) THEN ADB1F405.534
CALL TIMER ('GAS_CALC', 4) ADB1F405.535
END IF ADB1F405.536
ADB1F405.537
IF ( ICODE .NE. 0 ) RETURN ADB1F405.538
ADB1F405.539
ENDIF ADB1F405.540
ADB1F405.541
RAD_CTL1.188
CL 0.2 IF(LEXPAND_OZONE)=.TRUE. expand ozone from zonal mean to 3-d RAD_CTL1.189
CL field in OZONE, otherwise copy into OZONE RAD_CTL1.190
RAD_CTL1.191
DO LEVEL=1,OZONE_LEVELS RAD_CTL1.192
IF(.NOT.LEXPAND_OZONE) THEN RAD_CTL1.193
RAD_CTL1.194
DO I=1,P_FIELD RAD_CTL1.195
OZONE_1(I,LEVEL)=D1(JOZONE(LEVEL)+I-1) GDR3F305.161
END DO RAD_CTL1.197
RAD_CTL1.198
ELSE RAD_CTL1.199
RAD_CTL1.200
DO ROW=1,P_ROWS RAD_CTL1.201
DO I=1,ROW_LENGTH RAD_CTL1.202
POINT=I+(ROW-1)*ROW_LENGTH RAD_CTL1.203
OZONE_1(POINT,LEVEL)=D1(JOZONE(LEVEL)+ROW-1) GDR3F305.162
END DO RAD_CTL1.205
END DO RAD_CTL1.206
RAD_CTL1.207
ENDIF RAD_CTL1.208
END DO RAD_CTL1.209
! ADB1F401.781
! ADB1F401.782
! Code for the Sulphur Cycle. We multiply by 4.125 to convert from ADB1F401.783
! mass mixing ratio of sulphur atoms to mass mixing ratio of ADB1F401.784
! ammonium sulphate. ADB1F401.785
IF (L_USE_SULPC_DIRECT .OR. L_USE_SULPC_INDIRECT_SW AAJ1F404.9
& .OR. L_USE_SULPC_INDIRECT_LW) THEN AAJ1F404.10
IF (SULP_DIM1.EQ.P_FIELD .AND. SULP_DIM2.EQ.P_LEVELS) THEN ADB1F401.787
DO LEVEL=1, P_LEVELS ADB1F401.788
DO I=1, P_FIELD ADB1F401.789
POINT=I+(LEVEL-1)*P_FIELDDA ADB1F401.790
ACCUM_SULPHATE(I, LEVEL)=D1(JSO4_ACCU(1)+POINT-1)*4.125 ADB1F401.791
AITKEN_SULPHATE(I, LEVEL)=D1(JSO4_AITKEN(1)+POINT-1)*4.125 ADB1F401.792
DISS_SULPHATE(I, LEVEL)=D1(JSO4_DISS(1)+POINT-1)*4.125 ADB2F404.930
ENDDO ADB1F401.793
ENDDO ADB1F401.794
ELSE ADB1F401.795
WRITE(6,*) ADB1F401.796
& 'SULP_DIM INCONSISTENT WITH L_USE_SULPC, EXIT RAD_CTL' ADB1F401.797
ICODE = 1 ADB1F401.798
RETURN ADB1F401.799
ENDIF ADB1F401.800
ENDIF ADB1F401.801
! ACN2F405.49
! Code for the interactive Carbon Cycle. ACN2F405.50
! ACN2F405.51
IF (L_CO2_INTERACTIVE) THEN ACN2F405.52
IF (CO2_DIM1.EQ.P_FIELD .AND. CO2_DIM2.EQ.P_LEVELS) THEN ACN2F405.53
DO LEVEL=1, P_LEVELS ACN2F405.54
DO I=1, P_FIELD ACN2F405.55
POINT=I+(LEVEL-1)*P_FIELDDA ACN2F405.56
CO2_3D(I, LEVEL) = D1(JCO2(1)+POINT-1) ACN2F405.57
ENDDO ACN2F405.58
ENDDO ACN2F405.59
ELSE ACN2F405.60
WRITE(6,*) ACN2F405.61
& 'CO2_DIM INCONSISTENT WITH L_CO2_INTERACTIVE, EXIT RAD_CTL' ACN2F405.62
CMESSAGE = ACN2F405.63
& 'ERROR RAD_CTL: CO2_DIM1,2 SET WRONGLY FOR CARBON CYCLE' ACN2F405.64
ICODE = 1 ACN2F405.65
RETURN ACN2F405.66
ENDIF ACN2F405.67
ELSE ACN2F405.68
! set an arbitrary value ACN2F405.69
CO2_3D(1,1) = 0.0 ACN2F405.70
ENDIF ACN2F405.71
! AYY1F404.250
IF (L_USE_SOOT_DIRECT) THEN ALR3F405.25
IF (SOOT_DIM1.EQ.P_FIELD .AND. SOOT_DIM2.EQ.P_LEVELS) THEN ALR3F405.26
DO LEVEL=1, P_LEVELS ALR3F405.27
DO I=1, P_FIELD ALR3F405.28
POINT=I+(LEVEL-1)*P_FIELDDA ALR3F405.29
FRESH_SOOT(I, LEVEL) ALR3F405.30
& =D1(JSOOT_NEW(1)+POINT-1) ALR3F405.31
AGED_SOOT(I, LEVEL) ALR3F405.32
& =D1(JSOOT_AGD(1)+POINT-1) ALR3F405.33
ENDDO ALR3F405.34
ENDDO ALR3F405.35
ELSE ALR3F405.36
CMESSAGE='Failure with soot. See output.' ALR3F405.37
ICODE = 1 ALR3F405.38
WRITE(*,*) ALR3F405.39
& 'SOOT_DIM1 and SOOT_DIM2 must be equal to P_FIELD' ALR3F405.40
& //'and P_LEVELS to study soot direct radiative effects.' ALR3F405.41
WRITE(*,*) 'Current values: ' ALR3F405.42
write(*,*) 'SOOT_DIM1: ',SOOT_DIM1 ALR3F405.43
write(*,*) 'SOOT_DIM2: ',SOOT_DIM2 ALR3F405.44
write(*,*) 'P_FIELD, P_LEVELS: ', P_FIELD, P_LEVELS ALR3F405.45
write(*,*) 'L_USE_SOOT_DIRECT: ',L_USE_SOOT_DIRECT ALR3F405.46
RETURN ALR3F405.47
ENDIF ALR3F405.48
END IF ALR3F405.49
ALR3F405.50
! Partitioning of ice and water cloud needs to be consistent with AYY1F404.251
! the large-scale precipitation scheme (Section 4) used. For new AYY1F404.252
! precipitation microphysics scheme use input qCL and qCF ADM0F405.304
! directly: for earlier schemes partition (qCL+qCF) using FOCWWIL. AYY1F404.254
! A. C. Bushell 12/ 3/ 1997 AYY1F404.255
! AYY1F404.256
L_CLOUD_WATER_PARTITION=L_LSPICE AYY1F404.257
! AYY1F404.258
RAD_CTL1.210
CL 0.3 Find tropopause index, needed if climatological aerosols are to AWI1F402.6
CL be used, to decide where the tropospheric aerosol stops and the AWI1F402.7
CL stratospheric starts. The index is also required for calculating ADB2F404.931
CL fluxes at the tropopause which are available only under option ADB2F404.932
CL 03A in the SW or LW. ADB2F404.933
AWI1F402.10
IF ( L_CLIMAT_AEROSOL .OR. ADB2F404.934
& ( SF(237,1) .OR. SF(238,1) ) .OR. ADB2F404.935
& ( SF(237,2) .OR. SF(238,2) ) ) THEN ADB2F404.936
C ! Find the lowest layer boundaries above eta=.7 & .05, to AWI1F402.12
C ! use as limits for the tropopause. AWI1F402.13
C ! (The latter is the same constant as used within TROPIN, but AWI1F402.14
C ! applied half a level more restrictively, and in terms of AWI1F402.15
C ! eta rather than pressure/PREF - in practice this will AWI1F402.16
C ! make no difference for standard levels as they will be AWI1F402.17
C ! pure pressure levels there. The former is apparently AWI1F402.18
C ! more generous, but is necessary to find a tropopause AWI1F402.19
C ! around 40 kPa with surface pressure less than 60 kPa, AWI1F402.20
C ! as is perfectly plausible in the Antarctic winter.) AWI1F402.21
DO LEVEL=P_LEVELS, 1, -1 AWI1F402.22
IF ( AKH(LEVEL)/PREF+BKH(LEVEL) .LT. .7 ) MIN_TROP = LEVEL AWI1F402.23
IF ( AKH(LEVEL)/PREF+BKH(LEVEL) .LT. .05 ) MAX_TROP = LEVEL AWI1F402.24
ENDDO AWI1F402.25
CALL TROPIN (D1(JPSTAR), D1(JTHETA(1)), D1(JP_EXNER(1)), AWI1F402.26
& TRINDX, P_FIELD, P_FIELD, ROW_LENGTH, P_LEVELS, AWI1F402.27
& MIN_TROP, MAX_TROP, AKH, BKH, AWI1F402.28
*IF DEF,GLOBAL,AND,-DEF,MPP AWI1F402.29
& .TRUE. ) AWI1F402.30
*ELSE AWI1F402.31
& .FALSE. ) AWI1F402.32
*ENDIF AWI1F402.33
ENDIF AWI1F402.34
! ADB2F404.937
! ADB2F404.938
IF ( (H_SECT(1).EQ."03A").OR.(H_SECT(2).EQ."03A") ) THEN ADB2F404.939
! ADB2F404.940
! To obtain reproducible results independent of the ADB2F404.941
! decomposition of the domain used on an MPP machine a global ADB2F404.942
! value for the topmost cloudy layer is used. The two polar ADB2F404.943
! rows are not searched. The use of a hardwired flag means that ADB2F404.944
! the original faster code can be restored by setting ADB2F404.945
! L_GLOBAL_CLOUD_TOP to .FALSE. as a modification: the results ADB2F404.946
! will then not be independent of the number of segments or the ADB2F404.947
! configuration of processors used. This is required if option ADB2F404.948
! 3A for the radiation is used in either section. ADB2F404.949
! ADB2F404.950
L_GLOBAL_CLOUD_TOP=.TRUE. ADB2F404.951
IF (L_GLOBAL_CLOUD_TOP) THEN ADB2F404.952
CALL R2_GLOBAL_CLOUD_TOP(POINTS, P_LEVELS, CLOUD_LEVELS ADB2F404.953
! Convective cloud Fields ADB2F404.954
& , D1(JCCA(1)+FIRST_POINT-1), D1(JCCT+FIRST_POINT-1) ADB2F404.955
! Layer cloud Fields ADB2F404.956
& , AREA_CLOUD_FRACTION(FIRST_POINT, 1) ASK1F405.266
! Calculated top of cloud fields. ADB2F404.958
& , GLOBAL_CLOUD_TOP ADB2F404.959
! Size of arrays ADB2F404.960
& , P_FIELDDA ADB2F404.961
& ) ADB2F404.962
AWI1F402.35
*IF DEF,MPP ADB2F404.963
! GLOBAL_CLOUD_TOP returned from R2_GLOBAL_CLOUD_TOP is ADB2F404.964
! the cloud top for the local domain. Derive a Global ADB2F404.965
! value from the local values. ADB2F404.966
CALL GC_IMAX(1,NPROC,INFO,GLOBAL_CLOUD_TOP) ADB2F404.967
ADB2F404.968
*ENDIF ADB2F404.969
ENDIF ADB2F404.970
! ADB2F404.971
ENDIF ADB2F404.972
! ADB2F404.973
! ADB2F404.974
CL--- SECTION 1 --- SHORTWAVE RADIATION --------------- RAD_CTL1.211
CL 1.0 If not short wave radiation timestep: RAD_CTL1.212
RAD_CTL1.213
IF(.NOT.L_SW_RADIATE) THEN RAD_CTL1.214
RAD_CTL1.215
*IF -DEF,FRADIO GGH3F401.29
CL Read in SW radiation increments, including net surface SW in band 1, ARE2F404.106
CL and surface albedo ARE2F404.107
LEN=(P_FIELDDA*(P_LEVELS+3)+511)/512*512 !no words for SW incs ARE2F404.108
RAD_CTL1.219
NFTSWAP=16 RAD_CTL1.220
CALL SETPOS(NFTSWAP,0,ICODE) GTD0F400.116
CALL BUFFIN(NFTSWAP,RADINCS,LEN,LEN_IO,A_IO) RAD_CTL1.222
RAD_CTL1.223
C Error check RAD_CTL1.224
RAD_CTL1.225
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.(LEN)) THEN RAD_CTL1.226
CMESSAGE=' RAD_CTL :Paging IO Error ' RAD_CTL1.227
ICODE=1 RAD_CTL1.228
RETURN RAD_CTL1.229
END IF RAD_CTL1.230
*ENDIF RAD_CTL1.231
RAD_CTL1.232
END IF RAD_CTL1.233
RAD_CTL1.234
CL 1.1 Shortwave-related calculations RAD_CTL1.235
RAD_CTL1.236
CL 1.1.1 Calculates sine of the solar declination and the scaling RAD_CTL1.237
C factor for solar intensity from the day number and year. RAD_CTL1.238
RAD_CTL1.239
IF(LTIMER) THEN RAD_CTL1.240
CALL TIMER('SOLPOS ',3) RAD_CTL1.241
END IF RAD_CTL1.242
RAD_CTL1.243
C ! HADCM2 physics must continue to use the wrong solar time. GHM5F405.28
GHM5F405.29
GHM5F405.30
IF ( H_SECT(1) .EQ. '02B' ) THEN GHM5F405.31
CALL SOLPOS (I_DAY_NUMBER, I_YEAR, SINDEC, SCS, LCAL360) GHM5F405.32
ELSE GHM5F405.33
CALL SOLPOS (PREVIOUS_TIME(7), PREVIOUS_TIME(1), SINDEC, SCS, GHM5F405.34
& LCAL360) AWI1F400.4
ENDIF GHM5F405.35
RAD_CTL1.245
IF(LTIMER) THEN RAD_CTL1.246
CALL TIMER('SOLPOS ',4) RAD_CTL1.247
END IF RAD_CTL1.248
RAD_CTL1.249
CL 1.1.2 Calculate day fraction and the zenith angle for each grid point RAD_CTL1.250
RAD_CTL1.251
TIMESTEP=A_SW_RADSTEP*SECS_PER_STEPim(atmos_im) ADR1F305.120
RAD_CTL1.253
C calculate sine of true latitude from Coriolis component F3 RAD_CTL1.254
RAD_CTL1.255
CALL UV_TO_P(F3(FIRST_VALID_PT), APBBF401.9
& SIN_TRUE_LATITUDE(FIRST_VALID_PT+ROW_LENGTH), APBBF401.10
& U_FIELD-FIRST_VALID_PT+1, APBBF401.11
& P_FIELD-(FIRST_VALID_PT+ROW_LENGTH)+1, APBBF401.12
& ROW_LENGTH,upd_P_ROWS+1) APBBF401.13
APBBF401.14
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.258
SIN_TRUE_LATITUDE(I)=SIN_TRUE_LATITUDE(I)*0.5/OMEGA RAD_CTL1.259
END DO RAD_CTL1.260
RAD_CTL1.261
C calculate seconds elapsed since midnight RAD_CTL1.262
RAD_CTL1.263
IF ( H_SECT(1) .EQ. '02B' ) THEN GHM5F405.36
TIME = REAL ( 3600 * I_HOUR + 60 * I_MINUTE + I_SECOND ) GHM5F405.37
ELSE GHM5F405.38
TIME = REAL ( 3600*PREVIOUS_TIME(4) + 60*PREVIOUS_TIME(5) GHM5F405.39
& + PREVIOUS_TIME(6) ) AWI1F400.6
ENDIF GHM5F405.40
RAD_CTL1.265
CL Calculations only done on a SW timestep RAD_CTL1.266
RAD_CTL1.267
IF ( L_SW_RADIATE ) THEN RAD_CTL1.268
RAD_CTL1.269
IF(LTIMER) THEN RAD_CTL1.270
CALL TIMER('SOLANG ',3) RAD_CTL1.271
END IF RAD_CTL1.272
RAD_CTL1.273
CALL SOLANG( RAD_CTL1.274
C arguments RAD_CTL1.275
C input constants RAD_CTL1.276
& SINDEC,TIME, RAD_CTL1.277
& TIMESTEP, RAD_CTL1.278
C row and column dependent constants RAD_CTL1.279
& SIN_TRUE_LATITUDE(FIRST_POINT), RAD_CTL1.280
& TRUE_LONGITUDE(FIRST_POINT), RAD_CTL1.281
C size variables RAD_CTL1.282
& POINTS, RAD_CTL1.283
C output fields RAD_CTL1.284
& DAY_FRACTION(FIRST_POINT), RAD_CTL1.285
& COS_ZENITH_ANGLE(FIRST_POINT)) RAD_CTL1.286
RAD_CTL1.287
IF(LTIMER) THEN RAD_CTL1.288
CALL TIMER('SOLANG ',4) RAD_CTL1.289
END IF RAD_CTL1.290
RAD_CTL1.291
CL Set rounding-error size values to zero - the criterion depends RAD_CTL1.292
CL on the frequency of full SW calculations because on the physics RAD_CTL1.293
CL timesteps which are not SW timesteps a test has to be done to RAD_CTL1.294
CL avoid using the unset data for such points. RAD_CTL1.295
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.296
IF ( COS_ZENITH_ANGLE(I) * DAY_FRACTION(I) RAD_CTL1.297
& .LT. ( 1.E-10 / A_SW_RADSTEP ) ) THEN RAD_CTL1.298
COS_ZENITH_ANGLE(I)=0.0 RAD_CTL1.299
DAY_FRACTION(I)=0.0 RAD_CTL1.300
ENDIF RAD_CTL1.301
ENDDO RAD_CTL1.302
CL 1.1.3 Calculate surface albedo RAD_CTL1.303
C Expand albedo, snow surface temperature and snow cover fraction ARE2F404.109
C to all points ARE2F404.110
RAD_CTL1.305
CDIR$ IVDEP RAD_CTL1.306
! Fujitsu vectorization directive GRB0F405.441
!OCL NOVREC GRB0F405.442
DO I=1,LAND_FIELD RAD_CTL1.307
STASHWORK(SI(205,1,im_index)+LAND_LIST(I)-1)=D1(JSFA+I-1) GRB4F305.352
STASHWORK(SI(206,1,im_index)+LAND_LIST(I)-1)=D1(JMDSA+I-1) GRB4F305.353
END DO RAD_CTL1.310
RAD_CTL1.311
L_MOSES_II = .FALSE. ARE2F404.111
IF ( H_SECT(3) .EQ. '07A' ) THEN ARE2F404.112
L_MOSES_II = .TRUE. ARE2F404.113
DO I=FIRST_POINT,LAST_POINT ARE2F404.114
ALBSNF(I) = 0. ARE2F404.115
TSTAR_SNOW(I) = 0. ARE2F404.116
SNOW_FRAC(I) = 0. ARE2F404.117
ENDDO ARE2F404.118
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.130
ALBSNF(LAND_LIST(L)) = D1(JSFA+L-1) ABX1F405.131
TSTAR_SNOW(LAND_LIST(L)) = ABX1F405.132
& D1(JTSTAR_TYP+(NTYPE-1)*LAND_FIELD+L-1) ABX1F405.133
SNOW_FRAC(LAND_LIST(L)) = SNOW_FRAC_LAND(L) ABX1F405.134
ENDDO ABX1F405.135
ELSE ABX1F405.136
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.137
TSTAR_SNOW(LAND_LIST(L)) = D1(JTSTAR+LAND_LIST(L)-1) ABX1F405.138
SNOW_FRAC(LAND_LIST(L)) = 1. ABX1F405.139
ENDDO ABX1F405.140
ENDIF ABX1F405.141
ARE2F404.131
IF ( H_SECT(1) .EQ. '02B' ) THEN AWI1F403.245
AWI1F403.246
IF ( L_H2_SULPH ) THEN AWI1F403.247
AWI1F403.248
DO J=1, NSULPAT AWI1F403.249
AWI1F403.250
IF ( LTIMER ) THEN AWI1F403.251
CALL TIMER ('GAS_CALC', 3) AWI1F403.252
END IF AWI1F403.253
AWI1F403.254
CALL GAS_CALC (SULPH_C(J), AWI1F403.255
& CLIM_FCG_NYEARS(S_SO4+J-1), CLIM_FCG_YEARS(1,S_SO4+J-1), AWI1F403.256
& CLIM_FCG_LEVLS(1,S_SO4+J-1), CLIM_FCG_RATES(1,S_SO4+J-1), AWI1F403.257
& LENSCEN, ICODE, CMESSAGE) AWI1F403.258
AWI1F403.259
IF ( ICODE .NE. 0 ) RETURN AWI1F403.260
AWI1F403.261
IF ( LTIMER ) THEN AWI1F403.262
CALL TIMER ('GAS_CALC', 4) AWI1F403.263
END IF AWI1F403.264
AWI1F403.265
ENDDO AWI1F403.266
AWI1F403.267
DO POINT=FIRST_POINT-1, LAST_POINT-1 AWI1F403.268
STASHWORK(SI(234,1,im_index)+POINT) = AWI1F403.269
& SULPH_C(1) * D1(JHadCM2_SO4(1)+POINT) AWI1F403.270
ENDDO AWI1F403.271
AWI1F403.272
DO J=2, NSULPAT AWI1F403.273
DO POINT=FIRST_POINT-1, LAST_POINT-1 AWI1F403.274
STASHWORK(SI(234,1,im_index)+POINT) = AWI1F403.275
& STASHWORK(SI(234,1,im_index)+POINT) + AWI1F403.276
& SULPH_C(J) * D1(JHadCM2_SO4(J)+POINT) AWI1F403.277
ENDDO AWI1F403.278
ENDDO AWI1F403.279
AWI1F403.280
ENDIF AWI1F403.281
AWI1F403.282
IF ( LTIMER ) THEN AWI1F403.283
CALL TIMER ('FTSA ', 3) AWI1F403.284
END IF AWI1F403.285
AWI1F403.286
CALL FTSA ( AWI1F403.287
C arguments AWI1F403.288
C input fields AWI1F403.289
& D1(JLAND+JS),D1(JICE_FRACTION+JS),D1(JTSTAR+JS), AWI1F403.290
& STASHWORK(SI(205,1,im_index)+JS), AWI1F403.291
& STASHWORK(SI(206,1,im_index)+JS), AWI1F403.292
& COS_ZENITH_ANGLE(FIRST_POINT),D1(JSNODEP+JS), AWI1F403.293
C sulphate loading - space always allocated if L_H2_SULPH, not otherwise AWI1F403.294
& STASHWORK(SI(234,1,im_index)+JS), AWI1F403.295
C max and min sea ice albedo specifications AWI1F403.296
& ALPHAC,ALPHAM,DTICE, AWI1F403.297
C size and control variables - flag to indicate if NO_SULPHATE_ALBEDO AWI1F403.298
C should be filled; NLALBS, which is 2 if sulphate is used, 1 if not AWI1F403.299
C & then straightforward dimensions: AWI1F403.300
& SF(236,1), NLALBS, NSULPAT, P_FIELD, POINTS, AWI1F403.301
C output arguments AWI1F403.302
& LAND_AND_ICE_ALBEDO(FIRST_POINT,1), AWI1F403.303
& OPEN_SEA_ALBEDO(FIRST_POINT,1), AWI1F403.304
& NO_SULPHATE_ALBEDO(FIRST_POINT,1) ) AWI1F403.305
GHM5F405.3
ELSE GHM5F405.7
GHM5F405.8
IF ( LTIMER ) THEN GHM5F405.14
CALL TIMER ('FTSA ', 3) GHM5F405.15
END IF GHM5F405.20
GHM5F405.21
CALL FTSA ( GHM5F405.22
C arguments RAD_CTL1.317
C input fields RAD_CTL1.318
& D1(JLAND+JS),D1(JICE_FRACTION+JS),D1(JTSTAR+JS), @DYALLOC.3042
& TSTAR_SNOW(FIRST_POINT),SNOW_FRAC(FIRST_POINT), ARE2F404.132
& STASHWORK(SI(205,1,im_index)+JS), GRB4F305.354
& STASHWORK(SI(206,1,im_index)+JS), GRB4F305.355
& COS_ZENITH_ANGLE(FIRST_POINT),D1(JSNODEP+JS), RAD_CTL1.321
& D1(JRGRAIN+JS), D1(JSNSOOT+JS), ARE2F404.133
C Constants to determine the albedo of sea-ice and snow on sea-ice AJG1F405.30
& ALPHAM,ALPHAC,ALPHAB,DTICE,L_SSICE_ALBEDO, AJG1F405.31
! Version of Shortwave ADB1F400.89
& H_SECT(1), ADB1F400.90
C size and control variables RAD_CTL1.322
& P_FIELD, POINTS, AWI2F400.2
& L_SNOW_ALBEDO, SAL_DIM, ARE2F404.134
C output arguments RAD_CTL1.324
& SAL_VIS(FIRST_POINT_SAL,1), ARE2F404.135
& SAL_NIR(FIRST_POINT_SAL,1), GHM5F405.4
& LAND_AND_ICE_ALBEDO(FIRST_POINT,1), GHM5F405.5
& OPEN_SEA_ALBEDO(FIRST_POINT,1) ) GHM5F405.6
GHM5F405.9
GHM5F405.10
ENDIF GHM5F405.11
GHM5F405.12
IF(LTIMER) THEN GHM5F405.13
CALL TIMER ('FTSA ',4) RAD_CTL1.329
END IF RAD_CTL1.330
! ADB1F400.91
! If Version 5 of the boundary layer scheme (MOSES) is used ADB1F401.802
! the net SW flux at the surface below 690nm ADB1F401.803
! is required, whether the STASH flag is set or not. ADB1F401.804
IF ( (H_SECT(3).EQ."05A").OR. ADB1F404.1
& (H_SECT(3).EQ."05B").OR. ADB1F404.2
& (H_SECT(3).EQ."06A").OR. ADB1F404.3
& (H_SECT(3).EQ."07A") ) THEN ADB1F404.4
L_FLUX_BELOW_690NM_SURF=.TRUE. ADB1F401.806
ELSE IF ( H_SECT(3).EQ."07A" ) THEN ARE2F404.137
L_FLUX_BELOW_690NM_SURF=.TRUE. ARE2F404.138
ELSE IF ( (H_SECT(3).EQ."02C").OR. ADB1F401.807
& (H_SECT(3).EQ."03A").OR. ADB1F401.808
& (H_SECT(3).EQ."03B").OR. ADB1F401.809
& (H_SECT(3).EQ."04A") ) THEN ADB1F401.810
L_FLUX_BELOW_690NM_SURF=SF(204, 1) ADB1F401.811
ELSE ADB1F401.812
ICODE=1 ADB1F401.813
CMESSAGE='RAD_CTL: Unknown version of Section 3 ' ADB1F401.814
& //'encountered.' ADB1F401.815
RETURN ADB1F401.816
ENDIF ADB1F401.817
IF ( L_SNOW_ALBEDO ) L_FLUX_BELOW_690NM_SURF=.TRUE. ARE2F404.139
! ADB1F400.92
! ADB1F401.818
! Pre-calculate variables depending on the version of the ADB1F400.93
! radiation used outside the loops over segments to allow ADB1F400.94
! macrotasking to proceed. ADB1F400.95
! GHM5F405.16
! Cloud is reduced to three layers under versions 2A & 2B. GHM5F405.17
L_3_CLOUD = H_SECT(1) .EQ. "02A" .OR. H_SECT(1) .EQ. "02B" GHM5F405.18
! GHM5F405.19
! ADB2F404.975
CL 1.1.4 Calculate index to allow data to be compressed to sunlit points RAD_CTL1.332
RAD_CTL1.333
*IF -DEF,MPP APBBF401.15
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.334
SWITCH(I)=DAY_FRACTION(I).GT.0. RAD_CTL1.335
END DO RAD_CTL1.336
*ELSE APBBF401.16
! Switch off SW radiation wherever there is no sunlight, and in APBBF401.17
! all halo areas. APBBF401.18
DO I=1,P_FIELD APBBF401.19
SWITCH(I)=.FALSE. APBBF401.20
ENDDO APBBF401.21
! {Note that DAY_FRACTION is not initialised outside FIRST_POINT to ARR0F403.3
! LAST_POINT. Hence this loop is separated from the following loop.} ARR0F403.4
DO I=FIRST_POINT,LAST_POINT ARR0F403.5
SWITCH(I)=DAY_FRACTION(I).GT.0. ARR0F403.6
ENDDO ARR0F403.7
DO J=NS_Halo+1,P_ROWS-NS_Halo APBBF401.22
DO I=1+EW_Halo,ROW_LENGTH-EW_Halo APBBF401.23
POINT=I+(J-1)*ROW_LENGTH APBBF401.24
SWITCH(POINT)=((POINT .GE. FIRST_POINT) .AND. APBBF401.25
& (POINT .LE. LAST_POINT ) .AND. ARR0F403.8
& SWITCH(POINT) ) ARR0F403.9
ENDDO APBBF401.28
ENDDO APBBF401.29
APBBF401.30
! QAN fix : Set RADINCS array to zero everywhere - to ensure the APBBF401.31
! unset halos don't contain anything dangerous - ie. NaNs APBBF401.32
DO LEVEL=0,P_LEVELS+2 ARE2F404.140
DO I=1,P_FIELD APBBF401.34
RADINCS(I+LEVEL*P_FIELD)=0.0 APBBF401.35
ENDDO APBBF401.36
ENDDO APBBF401.37
APBBF401.38
*ENDIF APBBF401.39
RAD_CTL1.337
DAYLIGHT_POINTS = 0 GSS9F402.145
DO I=1,POINTS GSS9F402.146
IF(SWITCH(FIRST_POINT+I-1))THEN GSS9F402.147
DAYLIGHT_POINTS = DAYLIGHT_POINTS + 1 GSS9F402.148
LIST(DAYLIGHT_POINTS) = I GSS9F402.149
END IF GSS9F402.150
END DO GSS9F402.151
C GSS9F402.152
C RAD_CTL1.341
IF (LTIMER) THEN GPB8F405.58
CALL TIMER('SW_RAD',5) GPB8F405.59
CALL TIMER('SWRAD ',3) GPB8F405.60
ENDIF GPB8F405.61
IF ( DAYLIGHT_POINTS .GT. 0 ) THEN RAD_CTL1.342
CL Calculate length of segments into which to split RAD_CTL1.343
CL short wave calculations. RAD_CTL1.344
RAD_CTL1.345
CNC RF Load balance STEP so that last segment does the same or AAD1F304.94
CNC RF less work than the others AAD1F304.95
N_SW_SEGMENTS = MIN(NCPU*A_SW_SEGMENTS,DAYLIGHT_POINTS) AAD1F304.96
STEP = DAYLIGHT_POINTS/N_SW_SEGMENTS AAD1F304.97
SEG_START=1 RAD_CTL1.355
C RAD_CTL1.375
C Set levels lists and pseudo-levels lists for diagnostics that need RAD_CTL1.376
C them. RAD_CTL1.377
IF ( SF(214,1) ) THEN RAD_CTL1.378
CALL SET_LEVELS_LIST (CLOUD_LEVELS, LEN_STLIST, RAD_CTL1.379
& STLIST(1,STINDEX(1,214,1,im_index)), LLLAAR, GRB4F305.356
& STASH_LEVELS, NUM_STASH_LEVELS+1, ICODE, CMESSAGE) RAD_CTL1.381
IF ( ICODE .GT. 0 ) RETURN RAD_CTL1.382
CALL SET_PSEUDO_LIST (H_SWBANDS, LEN_STLIST, RAD_CTL1.383
& STLIST(1,STINDEX(1,214,1,im_index)), PLLAAR, GRB4F305.357
& STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, ICODE, CMESSAGE) RAD_CTL1.385
IF ( ICODE .GT. 0 ) RETURN RAD_CTL1.386
ENDIF RAD_CTL1.387
IF ( SF(215,1) ) THEN RAD_CTL1.388
CALL SET_LEVELS_LIST (CLOUD_LEVELS, LEN_STLIST, RAD_CTL1.389
& STLIST(1,STINDEX(1,215,1,im_index)), LLLAAF, GRB4F305.358
& STASH_LEVELS, NUM_STASH_LEVELS+1, ICODE, CMESSAGE) RAD_CTL1.391
IF ( ICODE .GT. 0 ) RETURN RAD_CTL1.392
CALL SET_PSEUDO_LIST (H_SWBANDS, LEN_STLIST, RAD_CTL1.393
& STLIST(1,STINDEX(1,215,1,im_index)), PLLAAF, GRB4F305.359
& STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, ICODE, CMESSAGE) RAD_CTL1.395
IF ( ICODE .GT. 0 ) RETURN RAD_CTL1.396
ENDIF RAD_CTL1.397
IF ( SF(216,1) ) THEN RAD_CTL1.398
CALL SET_PSEUDO_LIST (H_SWBANDS, LEN_STLIST, RAD_CTL1.399
& STLIST(1,STINDEX(1,216,1,im_index)), PLCAAR, GRB4F305.360
& STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, ICODE, CMESSAGE) RAD_CTL1.401
IF ( ICODE .GT. 0 ) RETURN RAD_CTL1.402
ENDIF RAD_CTL1.403
IF ( SF(217,1) ) THEN RAD_CTL1.404
CALL SET_PSEUDO_LIST (H_SWBANDS, LEN_STLIST, RAD_CTL1.405
& STLIST(1,STINDEX(1,217,1,im_index)), PLCAAF, GRB4F305.361
& STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, ICODE, CMESSAGE) RAD_CTL1.407
IF ( ICODE .GT. 0 ) RETURN RAD_CTL1.408
ENDIF RAD_CTL1.409
WI250593.10
CL 1.1.6 Short wave radiation calculations called in segments AAD1F304.98
AAD1F304.99
CNC RF To run SWRAD in parallel, need to pre-calculate and scalar expand AAD1F304.100
CNC RF SEG_POINTS, JS and FIRST_POINT. Also need to rejig LIST(). AAD1F304.101
JS_TEMP(1) = JS AAD1F304.102
FIRST_POINT_TEMP(1) = FIRST_POINT AAD1F304.103
DO I = 1,N_SW_SEGMENTS AAD1F304.104
LIT_POINTS = STEP AAD1F304.105
START_POINT = 1+(I-1)*STEP AAD1F304.106
SEG_POINTS = LIST(I*STEP)-SEG_START+1 AAD1F304.107
IF ( I .EQ. N_SW_SEGMENTS ) THEN AAD1F304.108
LIT_POINTS = DAYLIGHT_POINTS - STEP * ( N_SW_SEGMENTS - 1 ) AAD1F304.109
SEG_POINTS = POINTS-SEG_START+1 AAD1F304.110
END IF AAD1F304.111
DO J = START_POINT,START_POINT+LIT_POINTS-1 AAD1F304.112
LIST(J) = LIST(J)-SEG_START+1 AAD1F304.113
END DO AAD1F304.114
SEG_POINTS_TEMP(I) = SEG_POINTS AAD1F304.115
IF ( I .LT. N_SW_SEGMENTS ) THEN AAD1F304.116
JS_TEMP(I+1) = JS_TEMP(I)+SEG_POINTS AAD1F304.117
FIRST_POINT_TEMP(I+1) = FIRST_POINT_TEMP(I)+SEG_POINTS AAD1F304.118
ENDIF AAD1F304.119
SEG_START = SEG_START+SEG_POINTS AAD1F304.120
END DO AAD1F304.121
AAD1F304.122
RAD_CTL1.410
! CALL AN APPROPRIATE TOP_LEVEL ROUTINE AS DIRECTED BY H_SECT. ADB1F400.122
! ADB1F400.123
IF ( (H_SECT(1).EQ.'01A').OR. ADB2F404.976
& (H_SECT(1).EQ.'01B').OR. ADB2F404.977
& (H_SECT(1).EQ.'02A').OR. ADB2F404.978
& (H_SECT(1).EQ.'02B') ) THEN ADB2F404.979
! ADB1F400.125
! NB Cloud extent modification not available with this option. ASK1F405.267
! ASK1F405.268
! THE ORIGINAL CODE: ADB1F405.542
! ADB1F400.127
*IF DEF,MACRO AAD1F304.123
CFPP$ CNCALL AAD1F304.124
*ENDIF AAD1F304.125
DO I = 1,N_SW_SEGMENTS ADB1F400.128
LIT_POINTS = STEP ADB1F400.129
START_POINT = 1+(I-1)*STEP ADB1F400.130
IF ( I .EQ. N_SW_SEGMENTS ) THEN ADB1F400.131
LIT_POINTS = DAYLIGHT_POINTS ADB1F400.132
& - STEP * ( N_SW_SEGMENTS - 1 ) ADB1F400.133
END IF ADB1F400.134
FIRST_POINT = FIRST_POINT_TEMP(I) ADB1F400.135
JS = JS_TEMP(I) ADB1F400.136
GHM5F405.23
IF ( H_SECT(1) .NE. '02B' ) THEN GHM5F405.24
GHM5F405.25
CALL SWRAD ( GHM5F405.26
C arguments GHM5F405.27
C primary data inputs RAD_CTL1.413
RAD_CTL1.414
& D1(JQ(1)+JS),CO2_MMR,OZONE_1(FIRST_POINT,1), GDR3F305.163
& D1(JPSTAR+JS),AKH,BKH,CLOUD_FRACTION(FIRST_POINT,1), RAD_CTL1.416
& D1(JQCL(1)+JS),D1(JQCF(1)+JS), RAD_CTL1.417
& D1(JCCA(1)+JS),D1(JCCLWP+JS),D1(JCCB+JS),D1(JCCT+JS), AJX0F404.7
& LAND_AND_ICE_ALBEDO(FIRST_POINT,1), AWI1F403.314
& OPEN_SEA_ALBEDO(FIRST_POINT,1), @DYALLOC.3045
& D1(JICE_FRACTION+JS),COS_ZENITH_ANGLE(FIRST_POINT), RAD_CTL1.421
& DAY_FRACTION(FIRST_POINT),D1(JLAND+JS), RAD_CTL1.422
& LIST(START_POINT), RAD_CTL1.423
& D1(JTHETA(1)+JS),SCS, RAD_CTL1.424
RAD_CTL1.425
C Size and control variables RAD_CTL1.426
RAD_CTL1.427
& SW_TABLES,SECS_PER_STEPim(atmos_im), ADR1F305.122
& STASHWORK(JS+SI(208,1,im_index)), SF(208,1), GRB4F305.362
& STASHWORK(JS+SI(209,1,im_index)), SF(209,1), GRB4F305.363
& STASHWORK(JS+SI(204,1,im_index)), L_FLUX_BELOW_690NM_SURF, ADB1F401.819
& STASHWORK(JS+SI(235,1,im_index)), SF(235,1), GRB4F305.365
& STASHWORK(SI(210,1,im_index)+JS), SF(210,1), GRB4F305.366
& STASHWORK(SI(211,1,im_index)+JS), SF(211,1), GRB4F305.367
& STASHWORK(SI(212,1,im_index)+JS), SF(212,1), GRB4F305.368
& STASHWORK(SI(213,1,im_index)+JS), SF(213,1), GRB4F305.369
& STASHWORK(SI(214,1,im_index)+JS), SF(214,1), GRB4F305.370
& LLLAAR, PLLAAR, GRB4F305.371
& STASHWORK(SI(215,1,im_index)+JS), SF(215,1), GRB4F305.372
& LLLAAF, PLLAAF, GRB4F305.373
& STASHWORK(SI(216,1,im_index)+JS), SF(216,1), PLCAAR, GRB4F305.374
& STASHWORK(SI(217,1,im_index)+JS), SF(217,1), PLCAAF, GRB4F305.375
& STASHWORK(SI(219,1,im_index)+JS), SF(219,1), GRB4F305.376
& STASHWORK(JS+SI(220,1,im_index)), SF(220,1), GRB4F305.377
& STASHWORK(JS+SI(221,1,im_index)), SF(221,1), GRB4F305.378
& STASHWORK(JS+SI(222,1,im_index)), SF(222,1), GRB4F305.379
& STASHWORK(JS+SI(223,1,im_index)), SF(223,1), GRB4F305.380
& STASHWORK(JS+SI(224,1,im_index)), SF(224,1), GRB4F305.381
& LMICROPHY, AAJ1F304.6
& STASHWORK(JS+SI(218,1,im_index)), SF(218,1), GRB4F305.382
& L_3_CLOUD, ADB1F400.138
& L_CLOUD_WATER_PARTITION, AYY1F404.259
& LIT_POINTS, RAD_CTL1.445
& SEG_POINTS_TEMP(I),P_LEVELS,CLOUD_LEVELS, AAD1F304.135
& Q_LEVELS,OZONE_LEVELS,P_FIELD, RAD_CTL1.447
RAD_CTL1.448
C Output data RAD_CTL1.449
RAD_CTL1.450
& NETSW(FIRST_POINT), RAD_CTL1.451
& STASHWORK(SI(203,1,im_index)+JS), RADINCS(FIRST_POINT) ADB1F400.139
& ) ADB1F400.140
RAD_CTL1.453
ELSE AWI1F403.315
AWI1F403.316
IF ( SF(236,1) ) THEN AWI1F404.15
D1236_DIM = LIT_POINTS AWI1F404.16
ELSE AWI1F404.17
D1236_DIM = 1 AWI1F404.18
ENDIF AWI1F404.19
AWI1F404.20
CALL SWRAD ( AWI1F403.317
C arguments AWI1F403.318
C primary data inputs AWI1F403.319
AWI1F403.320
& D1(JQ(1)+JS),CO2_MMR,OZONE_1(FIRST_POINT,1), AWI1F403.321
& D1(JPSTAR+JS),AKH,BKH,CLOUD_FRACTION(FIRST_POINT,1), AWI1F403.322
& D1(JQCL(1)+JS),D1(JQCF(1)+JS), AWI1F403.323
& D1(JCCA(1)+JS),D1(JCCLWP+JS),D1(JCCB+JS),D1(JCCT+JS), GHM5F405.41
& LAND_AND_ICE_ALBEDO(FIRST_POINT,1), GHM5F405.42
& OPEN_SEA_ALBEDO(FIRST_POINT,1), GHM5F405.43
& D1(JICE_FRACTION+JS),COS_ZENITH_ANGLE(FIRST_POINT), GHM5F405.44
& DAY_FRACTION(FIRST_POINT),D1(JLAND+JS), GHM5F405.45
& LIST(START_POINT), GHM5F405.46
& D1(JTHETA(1)+JS),SCS, GHM5F405.47
GHM5F405.48
C Size and control variables GHM5F405.49
GHM5F405.50
& SW_TABLES,SECS_PER_STEPim(atmos_im), GHM5F405.51
& NO_SULPHATE_ALBEDO(FIRST_POINT,1), GHM5F405.52
& STASHWORK(JS+SI(208,1,im_index)), SF(208,1), GHM5F405.53
& STASHWORK(JS+SI(209,1,im_index)), SF(209,1), GHM5F405.54
& STASHWORK(JS+SI(204,1,im_index)), L_FLUX_BELOW_690NM_SURF, GHM5F405.55
& STASHWORK(JS+SI(235,1,im_index)), SF(235,1), GHM5F405.56
& STASHWORK(SI(210,1,im_index)+JS), SF(210,1), GHM5F405.57
& STASHWORK(SI(211,1,im_index)+JS), SF(211,1), GHM5F405.58
& STASHWORK(SI(212,1,im_index)+JS), SF(212,1), GHM5F405.59
& STASHWORK(SI(213,1,im_index)+JS), SF(213,1), GHM5F405.60
& STASHWORK(SI(214,1,im_index)+JS), SF(214,1), GHM5F405.61
& LLLAAR, PLLAAR, GHM5F405.62
& STASHWORK(SI(215,1,im_index)+JS), SF(215,1), GHM5F405.63
& LLLAAF, PLLAAF, GHM5F405.64
& STASHWORK(SI(216,1,im_index)+JS), SF(216,1), PLCAAR, GHM5F405.65
& STASHWORK(SI(217,1,im_index)+JS), SF(217,1), PLCAAF, GHM5F405.66
& STASHWORK(SI(219,1,im_index)+JS), SF(219,1), GHM5F405.67
& STASHWORK(JS+SI(220,1,im_index)), SF(220,1), GHM5F405.68
& STASHWORK(JS+SI(221,1,im_index)), SF(221,1), GHM5F405.69
& STASHWORK(JS+SI(222,1,im_index)), SF(222,1), GHM5F405.70
& STASHWORK(JS+SI(223,1,im_index)), SF(223,1), GHM5F405.71
& STASHWORK(JS+SI(224,1,im_index)), SF(224,1), GHM5F405.72
& LMICROPHY, GHM5F405.73
& STASHWORK(SI(236,1,im_index)+JS), SF(236,1), GHM5F405.74
& NLALBS, D1236_DIM, GHM5F405.75
& STASHWORK(JS+SI(218,1,im_index)), SF(218,1), AWI1F403.359
& L_3_CLOUD, AWI1F403.360
& L_CLOUD_WATER_PARTITION, AYY1F404.260
& LIT_POINTS, AWI1F403.361
& SEG_POINTS_TEMP(I),P_LEVELS,CLOUD_LEVELS, AWI1F403.362
& Q_LEVELS,OZONE_LEVELS,P_FIELD, AWI1F403.363
AWI1F403.364
C Output data AWI1F403.365
AWI1F403.366
& NETSW(FIRST_POINT), AWI1F403.367
& STASHWORK(SI(203,1,im_index)+JS), RADINCS(FIRST_POINT) AWI1F403.368
& ) AWI1F403.369
AWI1F403.370
ENDIF AWI1F403.371
AWI1F403.372
END DO ADB1F400.141
! ADB1F400.142
ELSE IF (H_SECT(1).EQ.'03A') THEN ADB2F404.980
! ADB1F400.144
! THE GENERAL TWO-STREAM CODE: ADB1F400.145
! ADB1F400.146
*IF DEF,MACRO ADB1F400.147
CFPP$ CNCALL ADB1F400.148
*ENDIF ADB1F400.149
DO I = 1,N_SW_SEGMENTS ADB1F400.150
LIT_POINTS = STEP ADB1F400.151
START_POINT = 1+(I-1)*STEP ADB1F400.152
IF ( I .EQ. N_SW_SEGMENTS ) THEN ADB1F400.153
LIT_POINTS = DAYLIGHT_POINTS ADB1F400.154
& - STEP * ( N_SW_SEGMENTS - 1 ) ADB1F400.155
END IF ADB1F400.156
FIRST_POINT = FIRST_POINT_TEMP(I) ADB1F400.157
JS = JS_TEMP(I) ADB1F400.158
! ADB1F402.590
! Set the first point of the array of sulphate to be used. ADB1F402.591
! A separate assignment is necessary since this array will ADB1F402.592
! not be of the full size unless the sulphur cycle is on. ADB1F402.593
IF (L_USE_SULPC_DIRECT .OR. L_USE_SULPC_INDIRECT_SW) THEN AAJ1F404.11
FIRST_POINT_SULPC=FIRST_POINT ADB1F402.595
ELSE ADB1F402.596
FIRST_POINT_SULPC=1 ADB1F402.597
ENDIF ADB1F402.598
IF (L_USE_SOOT_DIRECT) THEN ALR3F405.51
FIRST_POINT_SOOT=FIRST_POINT ALR3F405.52
ELSE ALR3F405.53
FIRST_POINT_SOOT=1 ALR3F405.54
ENDIF ALR3F405.55
! Similarly for the carbon cycle ACN2F405.72
L_CO2_3D = L_CO2_INTERACTIVE ACN2F405.73
IF (L_CO2_INTERACTIVE) THEN ACN2F405.74
FIRST_POINT_CO2=FIRST_POINT ACN2F405.75
ELSE ACN2F405.76
FIRST_POINT_CO2=1 ACN2F405.77
ENDIF ACN2F405.78
! SAL arrays not accessed (removes bounds checking messages) ARE2F404.141
IF( L_SNOW_ALBEDO ) THEN ARE2F404.142
FIRST_POINT_SAL = FIRST_POINT ARE2F404.143
ELSE ARE2F404.144
FIRST_POINT_SAL = 1 ARE2F404.145
ENDIF ARE2F404.146
ARE2F404.147
! Set the actual sizes of the arrays to an odd number to ADB1F400.159
! avoid memory bank conflicts. ADB1F400.160
RAD_ARRAY_SIZE=2*(LIT_POINTS/2)+1 ADB1F400.161
! ADB1F400.162
! ADB2F404.981
! Set dimensions for diagnostic workspace. ADB2F404.982
IF (SF(219, 1)) THEN ADB2F404.983
NPDWD_CL_PROFILE=SEG_POINTS_TEMP(I) ADB2F404.984
ELSE ADB2F404.985
NPDWD_CL_PROFILE=1 ADB2F404.986
ENDIF ADB2F404.987
! ADB2F404.988
! ADB2F404.989
CALL R2_SWRAD(ICODE, ADB1F400.163
C arguments ADB1F400.164
C primary data inputs ADB1F400.165
AAD1F304.136
! Mixing Ratios ADB1F400.166
& D1(JQ(1)+JS),CO2_MMR,OZONE_1(FIRST_POINT,1),O2MMR, ADB2F404.990
& CO2_DIM1, CO2_DIM2, CO2_3D(FIRST_POINT_CO2,1), ACN2F405.79
& L_CO2_3D, ACN2F405.80
! AC and BC added for conformity at lower levels ADB1F400.168
! Pressure Fields ADB1F400.169
& D1(JPSTAR+JS),AKH,BKH,A_LEVDEPC(JAK),A_LEVDEPC(JBK), ADB1F400.170
! Temperatures ADB1F400.171
& D1(JTHETA(1)+JS), ADB1F400.172
! Options for treating clouds ADB1F402.860
& L_GLOBAL_CLOUD_TOP, GLOBAL_CLOUD_TOP, ADB1F402.861
! Stratiform Cloud Fields ADB1F400.173
& L_CLOUD_WATER_PARTITION, AYY1F404.261
& AREA_CLOUD_FRACTION(FIRST_POINT,1), ASK1F405.269
& CLOUD_FRACTION(FIRST_POINT,1), ADB1F400.174
& D1(JQCL(1)+JS),D1(JQCF(1)+JS), ADB1F400.175
! Convective Cloud Fields ADB1F400.176
& D1(JCCA(1)+JS),D1(JCCLWP+JS),D1(JCCB+JS),D1(JCCT+JS), AJX0F404.9
& L_3D_CCA, AJX0F404.10
! Surface Fields ADB1F400.178
& SAL_VIS(FIRST_POINT_SAL,1),SAL_NIR(FIRST_POINT_SAL,1), GHM5F405.76
& LAND_AND_ICE_ALBEDO(FIRST_POINT,1), GHM5F405.77
& OPEN_SEA_ALBEDO(FIRST_POINT,1), GHM5F405.78
& D1(JICE_FRACTION+JS),D1(JLAND+JS),D1(JSNODEP+JS), ADB2F404.991
! Prognostic Snow Albedo flag ARE2F404.149
& L_SNOW_ALBEDO, SAL_DIM, ARE2F404.150
! Solar Fields ADB1F400.182
& COS_ZENITH_ANGLE(FIRST_POINT), ADB1F400.183
& DAY_FRACTION(FIRST_POINT),LIST(START_POINT),SCS, ADB2F404.992
! Aerosol Fields ADB1F400.186
& L_CLIMAT_AEROSOL, BL_LEVELS, ADB1F402.600
& L_USE_SULPC_DIRECT, L_USE_SULPC_INDIRECT_SW, AAJ1F404.12
& SULP_DIM1,SULP_DIM2,ACCUM_SULPHATE(FIRST_POINT_SULPC, 1), ADB2F404.993
& AITKEN_SULPHATE(FIRST_POINT_SULPC, 1), ADB1F402.602
& DISS_SULPHATE(FIRST_POINT_SULPC, 1), ADB2F404.994
& L_USE_SOOT_DIRECT,SOOT_DIM1,SOOT_DIM2, ALR3F405.56
& FRESH_SOOT(FIRST_POINT_SOOT, 1),AGED_SOOT(FIRST_POINT_SOOT, 1), ALR3F405.57
! Level of tropopause ADB1F402.603
& TRINDX(FIRST_POINT) ADB2F404.995
ADB1F400.188
C Size and control variables ADB1F400.189
ADB1F400.190
! Spectrum ADB1F400.191
*CALL SWSARG3A ADB2F404.996
! Algorithmic options ADB2F404.997
*CALL SWCARG3A ADB2F404.998
& , ADB2F404.999
& SECS_PER_STEPim(atmos_im), ADB2F404.1000
ADB1F400.193
! General Diagnostics ADB1F400.194
& STASHWORK(JS+SI(208,1,im_index)), SF(208,1), ADB1F400.195
& STASHWORK(JS+SI(209,1,im_index)), SF(209,1), ADB1F400.196
& STASHWORK(JS+SI(204,1,im_index)), L_FLUX_BELOW_690NM_SURF, ADB1F401.823
& STASHWORK(JS+SI(235,1,im_index)), SF(235,1), ADB1F400.198
& STASHWORK(SI(210,1,im_index)+JS), SF(210,1), ADB1F400.199
& STASHWORK(SI(211,1,im_index)+JS), SF(211,1), ADB1F400.200
& STASHWORK(SI(212,1,im_index)+JS), SF(212,1), ADB1F400.201
& STASHWORK(SI(213,1,im_index)+JS), SF(213,1), ADB1F400.202
& STASHWORK(SI(219,1,im_index)+JS), SF(219,1), ADB1F400.204
& STASHWORK(SI(233,1,im_index)+JS), SF(233,1), ADB1F400.205
& STASHWORK(SI(237,1,im_index)+JS), SF(237,1), ADB2F404.1001
& STASHWORK(SI(238,1,im_index)+JS), SF(238,1), ADB2F404.1002
! Microphysical Flag ADB1F400.206
& LMICROPHY, ADB1F400.207
! Microphysical Diagnostics ADB1F400.208
& STASHWORK(JS+SI(225,1,im_index)), SF(225,1), ADB1F400.209
& STASHWORK(JS+SI(221,1,im_index)), SF(221,1), ADB1F400.210
& STASHWORK(JS+SI(226,1,im_index)), SF(226,1), ADB1F400.211
& STASHWORK(JS+SI(223,1,im_index)), SF(223,1), ADB1F400.212
& STASHWORK(JS+SI(224,1,im_index)), SF(224,1), ADB1F400.213
& STASHWORK(JS+SI(245,1,im_index)), SF(245,1), AAJ3F404.4
& STASHWORK(JS+SI(246,1,im_index)), SF(246,1), AAJ3F404.5
& STASHWORK(JS+SI(241,1,im_index)), SF(241,1), AAJ3F404.6
& STASHWORK(JS+SI(242,1,im_index)), SF(242,1), AAJ3F404.7
& STASHWORK(JS+SI(243,1,im_index)), SF(243,1), AAJ3F404.8
& STASHWORK(JS+SI(244,1,im_index)), SF(244,1), AAJ3F404.9
! Physical Dimensions ADB2F404.1003
& LIT_POINTS,SEG_POINTS_TEMP(I),P_LEVELS,CLOUD_LEVELS, ADB2F404.1004
& Q_LEVELS,OZONE_LEVELS, ADB1F400.217
& P_FIELD, RAD_ARRAY_SIZE, P_LEVELS, 1,N_CCA_LEV, AJX0F404.11
! Working Dimensions for Diagnostics ADB2F404.1005
& NPDWD_CL_PROFILE, ADB2F404.1006
! ADB2F404.1007
! Output data ADB1F400.228
! ADB2F404.1008
& NETSW(FIRST_POINT), ADB1F400.230
& STASHWORK(SI(203,1,im_index)+JS), RADINCS(FIRST_POINT) ADB1F400.231
& ) ADB1F400.232
IF (ICODE.NE.0) RETURN ADB1F401.824
! ADB1F400.233
ENDDO ADB1F400.234
! ADB1F400.235
ELSE ADB2F404.1009
! ADB2F404.1010
ICODE=1 ADB2F404.1011
CMESSAGE='Unknown option for SW radiation in RAD_CTL1' ADB2F404.1012
RETURN ADB2F404.1013
! ADB2F404.1014
ENDIF ADB1F400.236
! ADB1F400.237
ADB1F400.238
AAD1F304.138
C RAD_CTL1.463
ELSE ! IF ( DAYLIGHT_POINTS .EQ. 0 ) THEN RAD_CTL1.464
DO LEVEL=0, P_LEVELS+1 ! extra level is net surf SW in band 1 AJS1F401.974
DO POINT=FIRST_POINT, LAST_POINT RAD_CTL1.466
RADINCS(POINT+LEVEL*P_FIELD) = 0. RAD_CTL1.467
ENDDO RAD_CTL1.468
ENDDO RAD_CTL1.469
DO POINT = FIRST_POINT, LAST_POINT RAD_CTL1.470
NETSW(POINT) = 0. RAD_CTL1.471
ENDDO RAD_CTL1.472
ARR2F401.8
C Note that SW diagnostics 203-204,207-217,235 are implicitly ARR2F401.9
C set to zero when the whole domain is dark, since STASHWORK is ARR2F401.10
C initialised to 0.0 at the start of this routine. ARR2F401.11
ARR2F401.12
C The following diagnostics are not naturally zero at night AWI2F403.1
C points, & as SWRAD cannot be CALLed for a completely dark domain, AWI2F403.2
C they have a routine of their own for such cases. AWI2F403.3
AWI2F403.4
C As with FTSA & SOLANG, RAD_CTL does not bother to batch SWDKDI. AWI2F403.5
AWI2F403.6
IF ( SF(218,1) .OR. SF(219,1) ) CALL SWDKDI (AKH, BKH, AWI2F403.7
& AREA_CLOUD_FRACTION(START_POINT_NO_HALO,1), ASK1F405.270
& D1(JCCA(1)+START_POINT_NO_HALO-1), AJX0F404.12
& STASHWORK(SI(218,1,im_index)+START_POINT_NO_HALO-1), SF(218,1), AWI2F403.10
& STASHWORK(SI(219,1,im_index)+START_POINT_NO_HALO-1), SF(219,1), AWI2F403.11
& L_3_CLOUD, POINTS, P_LEVELS, CLOUD_LEVELS, P_FIELD) AWI2F403.12
ENDIF RAD_CTL1.586
IF (LTIMER) THEN GPB8F405.62
CALL TIMER('SWRAD ',4) GPB8F405.63
CALL TIMER('SW_RAD',6) GPB8F405.64
ENDIF GPB8F405.65
RAD_CTL1.587
FIRST_POINT = START_POINT_NO_HALO APBBF401.40
LAST_POINT = END_P_POINT_NO_HALO APBBF401.41
POINTS = LAST_POINT-FIRST_POINT+1 APBBF401.42
JS = FIRST_POINT-1 APBBF401.43
RAD_CTL1.594
CL Store surface albedo ARE2F404.151
ARE2F404.152
DO I=FIRST_POINT,LAST_POINT ARE2F404.153
RADINCS(I+(P_LEVELS+2)*P_FIELD) = LAND_AND_ICE_ALBEDO(I,1) ARE2F404.154
END DO ARE2F404.155
ARE2F404.156
*IF -DEF,FRADIO GGH3F401.30
CL Write out SW radiation increments, including net surface SW band 1 AJS1F401.975
CL and surface albedo ARE2F404.157
LEN=(P_FIELDDA*(P_LEVELS+3)+511)/512*512 !no words for SW incs ARE2F404.158
NFTSWAP=16 RAD_CTL1.598
CALL SETPOS(NFTSWAP,0,ICODE) GTD0F400.117
CALL BUFFOUT(NFTSWAP,RADINCS,LEN,LEN_IO,A_IO) RAD_CTL1.600
RAD_CTL1.601
C Error check RAD_CTL1.602
RAD_CTL1.603
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.(LEN)) THEN RAD_CTL1.604
CMESSAGE=' RAD_CTL :Paging IO Error ' RAD_CTL1.605
ICODE=2 RAD_CTL1.606
RETURN RAD_CTL1.607
END IF RAD_CTL1.608
*ENDIF RAD_CTL1.609
RAD_CTL1.610
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.611
MEAN_COSZ(I) = COS_ZENITH_ANGLE(I) * DAY_FRACTION(I) RAD_CTL1.612
ENDDO RAD_CTL1.613
RAD_CTL1.614
IF (LEMCORR) THEN GSS1F304.771
C RAD_CTL1.616
C SUM SHORT WAVE FLUXES INTO THE ATMOSPHERE AND RAD_CTL1.617
C ADD INTO THE NET DIABATIC FLUXES INTO THE RAD_CTL1.618
C ATMOSPHERE FOR USE IN THE ENERGY CORRECTION RAD_CTL1.619
C PROCEDURE RAD_CTL1.620
C RAD_CTL1.621
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.622
NET_ATM_FLUX(I) = NETSW(I) RAD_CTL1.623
& - MEAN_COSZ(I) * RADINCS(I) RAD_CTL1.624
& - STASHWORK(SI(203,1,im_index)+I-1) GRB4F305.400
END DO RAD_CTL1.626
C RAD_CTL1.627
IF (LTIMER) THEN RAD_CTL1.628
CALL TIMER ('FLX_DIAG',3) RAD_CTL1.629
END IF RAD_CTL1.630
C RAD_CTL1.631
CALL FLUX_DIAG(NET_ATM_FLUX,COS_P_LATITUDE, APB5F401.150
& P_FIELD,FIRST_POINT,POINTS, APB5F401.151
& 1.0,A_SW_RADSTEP*SECS_PER_STEPim(atmos_im), APB5F401.152
& D1(JNET_FLUX)) GSM3F404.47
C RAD_CTL1.635
IF (LTIMER) THEN RAD_CTL1.636
CALL TIMER ('FLX_DIAG',4) RAD_CTL1.637
END IF RAD_CTL1.638
C RAD_CTL1.639
END IF ! LEMCORR GSS1F304.772
C GSS1F304.773
CL End of branch depending on whether shortwave radiation timestep. RAD_CTL1.641
C GSS1F304.774
ENDIF RAD_CTL1.643
RAD_CTL1.644
CL 1.1.7 Remaining "astronomy" RAD_CTL1.645
RAD_CTL1.646
CL Calculate day fraction and mean cos(solar zenith angle while RAD_CTL1.647
CL the sun is up) for each grid point for this physics timestep: RAD_CTL1.648
C (if in fact full SW calculations are being done every timestep, this RAD_CTL1.649
C is of course unnecessary, as are various calculations later on) RAD_CTL1.650
RAD_CTL1.651
IF ( A_SW_RADSTEP .GT. 1 ) THEN RAD_CTL1.652
RAD_CTL1.653
IF ( LTIMER ) THEN RAD_CTL1.654
CALL TIMER('SOLANG ',3) RAD_CTL1.655
END IF RAD_CTL1.656
RAD_CTL1.657
CALL SOLANG( RAD_CTL1.658
C input constants RAD_CTL1.659
& SINDEC, TIME, SECS_PER_STEPim(atmos_im), ADR1F305.125
C row and column dependent constants RAD_CTL1.661
& SIN_TRUE_LATITUDE(FIRST_POINT), TRUE_LONGITUDE(FIRST_POINT), RAD_CTL1.662
C size variables RAD_CTL1.663
& POINTS, RAD_CTL1.664
C output fields RAD_CTL1.665
& DAY_FRACTION(FIRST_POINT), COS_ZENITH_ANGLE(FIRST_POINT) ) RAD_CTL1.666
RAD_CTL1.667
IF ( LTIMER ) THEN RAD_CTL1.668
CALL TIMER('SOLANG ',4) RAD_CTL1.669
END IF RAD_CTL1.670
RAD_CTL1.671
ENDIF ! ( was A_SW_RADSTEP > 1 ? ) RAD_CTL1.672
C RAD_CTL1.673
CL ! Combine the two terms to give the mean cos zenith angle over the RAD_CTL1.674
CL ! whole of the physics timestep. AWI1F400.13
DO I=FIRST_POINT, LAST_POINT RAD_CTL1.679
COS_ZENITH_ANGLE(I) = COS_ZENITH_ANGLE(I) * DAY_FRACTION(I) RAD_CTL1.680
ENDDO RAD_CTL1.682
RAD_CTL1.683
CL 1.2 add SW radiative heating to temperatures WI200893.29
RAD_CTL1.685
DO 12 LEVEL=1,P_LEVELS RAD_CTL1.686
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.687
D1(JTHETA(LEVEL)+I-1) = D1(JTHETA(LEVEL)+I-1) + RAD_CTL1.688
& RADINCS(I+LEVEL*P_FIELD) * COS_ZENITH_ANGLE(I) RAD_CTL1.689
! ARN1F404.127
!! Calculate the SW heating rates for layers 1 to BL_LEVELS ARN1F404.128
!! for A03_6A ARN1F404.129
! ARN1F404.130
IF (L_RADHEAT .AND. LEVEL .LE. BL_LEVELS) THEN ARN1F404.131
RADHEAT_RATE(I,LEVEL) = ARN1F404.132
& (RADINCS(I+LEVEL*P_FIELD) * COS_ZENITH_ANGLE(I)) ARN1F404.133
& / SECS_PER_STEPim(atmos_im) ARN1F404.134
ENDIF ARN1F404.135
END DO RAD_CTL1.690
12 CONTINUE RAD_CTL1.691
RAD_CTL1.692
CL Set up net down surface SW radiation flux in SURF_RADFLUX WI200893.30
RAD_CTL1.694
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.695
SURF_RADFLUX(I) = RADINCS(I) * COS_ZENITH_ANGLE(I) RAD_CTL1.696
END DO RAD_CTL1.697
AJS1F401.977
CL Set up net down surface SW radiation flux for snow-free and ARE2F404.159
CL snow-covered fractions of gridboxes ARE2F404.160
ARE2F404.161
IF ( L_MOSES_II ) THEN ABX1F405.142
ABX1F405.143
CL Set the SW flux over the snow-free surface to the gridbox mean ABX1F405.144
CL SW flux (valid for sea points but corrected below for land points) ABX1F405.145
DO I=FIRST_POINT,LAST_POINT ABX1F405.146
RAD_NO_SNOW(I) = SURF_RADFLUX(I) ABX1F405.147
ENDDO ABX1F405.148
ABX1F405.149
CL Derive fluxes over snow-free and snow-covered fraction on land points ABX1F405.150
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.151
I = LAND_LIST(L) ABX1F405.152
IF ( LAND_AND_ICE_ALBEDO(I,1) .LT. 1. ) ABX1F405.153
& RAD_NO_SNOW(I) = (1. - ALBSNF(I)) * SURF_RADFLUX(I) / ABX1F405.154
& (1. - LAND_AND_ICE_ALBEDO(I,1)) ABX1F405.155
IF ( SNOW_FRAC(I) .GT. 0. ) ABX1F405.156
& RAD_SNOW(I) = ( SURF_RADFLUX(I) - ABX1F405.157
& (1. - SNOW_FRAC(I))*RAD_NO_SNOW(I) ) ABX1F405.158
& / SNOW_FRAC(I) ABX1F405.159
ENDDO ABX1F405.160
ENDIF ABX1F405.161
ARE2F404.173
CL Set up photosynthetically active surface radiation, if calculated AJS1F401.978
AJS1F401.979
IF(L_FLUX_BELOW_690NM_SURF) THEN AJS1F401.980
DO I=FIRST_POINT,LAST_POINT AJS1F401.981
PHOTOSYNTH_ACT_RAD(I) = RADINCS(I+(P_LEVELS+1)*P_FIELD) AJS1F401.982
& * COS_ZENITH_ANGLE(I) AJS1F401.983
END DO AJS1F401.984
ENDIF AJS1F401.985
RAD_CTL1.698
CL 1.3 Copy radiation diagnostics into position RAD_CTL1.699
RAD_CTL1.700
CL Copy diagnostic information to STASHWORK for processing. RAD_CTL1.701
RAD_CTL1.702
CL 1.3.1 Surface fluxes RAD_CTL1.703
RAD_CTL1.704
IF(SF(202,1)) THEN RAD_CTL1.705
DO I=FIRST_POINT, LAST_POINT RAD_CTL1.706
STASHWORK(SI(202,1,im_index)+I-1) = GRB4F305.401
& RADINCS(I)*COS_ZENITH_ANGLE(I) GRB4F305.402
ENDDO RAD_CTL1.708
END IF RAD_CTL1.709
RAD_CTL1.710
IF(SF(201,1)) THEN RAD_CTL1.711
DO I = FIRST_POINT,LAST_POINT RAD_CTL1.712
STASHWORK(SI(201,1,im_index)+I-1)=RADINCS(I)*MEAN_COSZ(I)+ GRB4F305.403
& STASHWORK(SI(203,1,im_index)+I-1) GRB4F305.404
END DO RAD_CTL1.715
RAD_CTL1.716
END IF RAD_CTL1.717
RAD_CTL1.718
CL 1.3.2 Atmospheric heating rates RAD_CTL1.719
RAD_CTL1.720
IF (SF(232,1)) THEN RAD_CTL1.721
C ! If the atmospheric SW heating rates are diagnosed they must RAD_CTL1.722
C ! be scaled by cosz and converted from the SW radiation ARR2F401.13
C ! increments per timestep. ARR2F401.14
RAD_CTL1.740
DO LEVEL=1,STASH_LEVELS(1,-STLIST(10,STINDEX(1,232,1,im_index))) GRB4F305.408
START_POINT=SI(232,1,im_index)+(LEVEL-1)*P_FIELD GRB4F305.409
DO I = FIRST_POINT,LAST_POINT ARR2F401.15
STASHWORK(START_POINT+I-1) = RADINCS(I+LEVEL*P_FIELD) ARR2F401.16
& * COS_ZENITH_ANGLE(I) / SECS_PER_STEPim(atmos_im) ARR2F401.17
END DO RAD_CTL1.746
END DO RAD_CTL1.747
END IF RAD_CTL1.748
RAD_CTL1.749
CL 1.3.3 All other diagnostics RAD_CTL1.750
RAD_CTL1.751
C ! Incoming solar : RAD_CTL1.752
IF ( SF(207,1) ) THEN RAD_CTL1.753
DO I=FIRST_POINT, LAST_POINT RAD_CTL1.754
STASHWORK(SI(207,1,im_index)+I-1)=SC*SCS*COS_ZENITH_ANGLE(I) GRB4F305.410
ENDDO RAD_CTL1.756
ENDIF RAD_CTL1.757
RAD_CTL1.758
CALL EXTDIAG(STASHWORK,SI(1,1,im_index),SF(1,1),201,NITEMS, GRB4F305.411
& STASHLEN,ROW_LENGTH, RAD_CTL1.760
& STLIST,LEN_STLIST,STINDEX(1,1,1,im_index),2, GRB4F305.412
& STASH_LEVELS, NUM_STASH_LEVELS+1, RAD_CTL1.762
& STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, RAD_CTL1.763
& im_ident,1, GPB1F403.1509
*CALL ARGPPX GPB1F403.1510
& ICODE, CMESSAGE) RAD_CTL1.764
RAD_CTL1.765
RAD_CTL1.766
CL 1.3.4 Call STASH to process output. Even on non-radiation timesteps WI200893.23
CL (neither LW nor SW called), STASH is called for certain WI200893.24
CL radiation diagnostics from CLD_CTL. WI200893.25
RAD_CTL1.769
IF(LTIMER) THEN RAD_CTL1.770
CALL TIMER('STASH ',3) RAD_CTL1.771
END IF RAD_CTL1.772
RAD_CTL1.773
CALL STASH(a_sm,a_im,1,STASHWORK, GKR0F305.975
*CALL ARGSIZE @DYALLOC.3059
*CALL ARGD1 @DYALLOC.3060
*CALL ARGDUMA @DYALLOC.3061
*CALL ARGDUMO @DYALLOC.3062
*CALL ARGDUMW GKR1F401.254
*CALL ARGSTS @DYALLOC.3063
*CALL ARGPPX GKR0F305.976
& ICODE,CMESSAGE) @DYALLOC.3067
RAD_CTL1.775
IF(LTIMER) THEN RAD_CTL1.776
CALL TIMER('STASH ',4) RAD_CTL1.777
END IF RAD_CTL1.778
RAD_CTL1.779
RAD_CTL1.780
C ----------------------------------------------------- RAD_CTL1.781
CL RAD_CTL1.782
CL--- SECTION 2 --- LONGWAVE RADIATION ---------------- RAD_CTL1.783
CL RAD_CTL1.784
CL RAD_CTL1.785
*IF DEF,FRADIO GGH3F401.31
CL FIND OFFSET TO POINT TO LW IN RADINCS ARRAY RAD_CTL1.787
OFFSET=(P_FIELDDA*(P_LEVELS+3)+511)/512*512 ARE2F404.174
*ELSE RAD_CTL1.789
CL SET OFFSET TO 0, SW AND LW USE SAME WORK SPACE RAD_CTL1.790
OFFSET=0 RAD_CTL1.791
*ENDIF RAD_CTL1.792
CL 2.0 If not long wave timestep then: RAD_CTL1.793
RAD_CTL1.794
IF(.NOT.L_LW_RADIATE) THEN RAD_CTL1.795
RAD_CTL1.796
*IF -DEF,FRADIO GGH3F401.32
CL Read in LW radiation increments RAD_CTL1.798
LEN=(P_FIELDDA*(P_LEVELS+3)+511)/512*512 !no words for LW incs ARE2F404.175
RAD_CTL1.800
NFTSWAP=16 RAD_CTL1.801
CALL SETPOS(NFTSWAP,LEN,ICODE) GTD0F400.118
CALL BUFFIN(NFTSWAP,RADINCS,LEN,LEN_IO,A_IO) RAD_CTL1.803
RAD_CTL1.804
C Error check RAD_CTL1.805
RAD_CTL1.806
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.(LEN)) THEN RAD_CTL1.807
CMESSAGE=' RAD_CTL :Paging IO Error ' RAD_CTL1.808
ICODE=1 RAD_CTL1.809
RETURN RAD_CTL1.810
END IF RAD_CTL1.811
*ENDIF RAD_CTL1.812
RAD_CTL1.813
END IF RAD_CTL1.814
RAD_CTL1.815
CL 2.2 Long wave radiation steps RAD_CTL1.816
RAD_CTL1.817
IF(L_LW_RADIATE)THEN RAD_CTL1.818
RAD_CTL1.819
IF(LTIMER) THEN RAD_CTL1.830
CALL TIMER('LW_RAD',5) GPB1F401.21
CALL TIMER('LWRAD ',3) RAD_CTL1.831
END IF RAD_CTL1.832
RAD_CTL1.833
! Effective surface radiative temperature ARE2F404.176
DO I=1,P_FIELD ARE2F404.177
TSTAR_RAD(I) = D1(JTSTAR+I-1) ARE2F404.178
END DO ARE2F404.179
IF ( L_MOSES_II ) THEN ARE2F404.180
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.162
I = LAND_LIST(L) ARE2F404.182
J = (NTYPE-1)*LAND_FIELD + L - 1 ARE2F404.183
TSTAR_RAD(I) = SNOW_FRAC(I)*D1(JTSTAR_TYP+J)**4 ARE2F404.184
ENDDO ARE2F404.185
DO N=1,NTYPE-1 ARE2F404.186
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.163
I = LAND_LIST(L) ARE2F404.188
J = (N-1)*LAND_FIELD + L - 1 ARE2F404.189
TSTAR_RAD(I) = TSTAR_RAD(I) + (1. - SNOW_FRAC(I)) * ARE2F404.190
& D1(JFRAC_TYP+J)*D1(JTSTAR_TYP+J)**4 ARE2F404.191
ENDDO ARE2F404.192
ENDDO ARE2F404.193
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.164
I = LAND_LIST(L) ARE2F404.195
TSTAR_RAD(I) = TSTAR_RAD(I)**0.25 ARE2F404.196
ENDDO ARE2F404.197
ENDIF ARE2F404.198
ARE2F404.199
CL 2.2.1 LWRAD in segments AAD1F304.139
AAD1F304.140
*IF -DEF,MPP APBBF401.47
STEP = POINTS/(NCPU*A_LW_SEGMENTS) AAD1F304.141
DO I = 1,NCPU*A_LW_SEGMENTS AAD1F304.142
SEG_POINTS = STEP AAD1F304.143
IF (I .EQ. NCPU*A_LW_SEGMENTS) THEN AAD1F304.144
SEG_POINTS = POINTS-STEP*(NCPU*A_LW_SEGMENTS-1) AAD1F304.145
END IF AAD1F304.146
JS_LOCAL(I) = JS AAD1F304.147
FP_LOCAL(I) = FIRST_POINT AAD1F304.148
SP_LOCAL(I) = SEG_POINTS AAD1F304.149
FIRST_POINT = FIRST_POINT+STEP AAD1F304.150
JS = JS+STEP AAD1F304.151
ENDDO ADB1F400.239
*ELSE APBBF401.48
! Switch off LW radiation calculation over halo areas - we can fill in APBBF401.49
! afterwards with a swapbounds APBBF401.50
APBBF401.51
STEP=ROW_LENGTH-2*EW_Halo APBBF401.52
DO I=1,POINTS/ROW_LENGTH APBBF401.53
JS_LOCAL(I)=JS+EW_Halo APBBF401.54
FP_LOCAL(I)=FIRST_POINT+EW_Halo APBBF401.55
SP_LOCAL(I)=STEP APBBF401.56
FIRST_POINT=FIRST_POINT+ROW_LENGTH APBBF401.57
JS=JS+ROW_LENGTH APBBF401.58
ENDDO APBBF401.59
APBBF401.60
! QAN fix : Set RADINCS array to zero everywhere - to ensure the APBBF401.61
! unset halos don't contain anything dangerous - ie. NaNs APBBF401.62
DO LEVEL=0,P_LEVELS+1 ARE2F404.200
DO I=1,P_FIELD APBBF401.64
RADINCS(OFFSET+I+LEVEL*P_FIELD)=0.0 APBBF401.65
ENDDO APBBF401.66
ENDDO APBBF401.67
DO I=1,P_FIELD APBBF401.68
OLR(I)=0.0 APBBF401.69
ENDDO APBBF401.70
APBBF401.71
*ENDIF APBBF401.72
! ADB1F400.240
! ADB1F400.241
! ADB1F400.242
! CALL AN APPROPRIATE TOP LEVEL ROUTINE AS DIRECTED BY H_SECT. ADB1F400.243
! ADB1F400.244
IF ( (H_SECT(2).EQ.'01A').OR. ADB2F404.1015
& (H_SECT(2).EQ.'01B').OR. ADB2F404.1016
& (H_SECT(2).EQ.'01C') ) THEN ADB2F404.1017
! ADB1F400.246
! NB Cloud extent modification not available with this option. ASK1F405.271
! THE ORIGINAL CODE (6 OR 9-BAND VERSION): ADB1F405.543
*IF DEF,MACRO AAD1F304.153
CFPP$ CNCALL AAD1F304.154
*ENDIF AAD1F304.155
*IF -DEF,MPP APBBF401.73
DO I = 1,NCPU*A_LW_SEGMENTS ADB1F400.248
*ELSE APBBF401.74
DO I=1,POINTS/ROW_LENGTH APBBF401.75
*ENDIF APBBF401.76
! ADB1F400.249
CALL LWRAD( ADB1F400.250
RAD_CTL1.835
C Input data RAD_CTL1.836
& D1(JQ(1)+JS_LOCAL(I)),CO2_MMR,OZONE_1(FP_LOCAL(I),1), ADB1F400.251
& N2OMMR, CH4MMR, C11MMR, C12MMR, ADB1F400.252
& D1(JTHETA(1)+JS_LOCAL(I)), ADB1F400.253
& D1(JP_EXNER(1)+JS_LOCAL(I)),TSTAR_RAD(FP_LOCAL(I)), ARE2F404.201
& D1(JPSTAR+JS_LOCAL(I)),AKH,BKH, ADB1F400.255
& A_LEVDEPC(JAK),A_LEVDEPC(JBK), ADB1F400.256
& D1(JICE_FRACTION+JS_LOCAL(I)), ADB1F400.257
& CLOUD_FRACTION(FP_LOCAL(I),1), ADB1F400.258
& D1(JQCL(1)+JS_LOCAL(I)),D1(JQCF(1)+JS_LOCAL(I)), ADB1F400.259
& D1(JCCA(1)+JS_LOCAL(I)),D1(JCCLWP+JS_LOCAL(I)), AJX0F404.13
& D1(JCCB+JS_LOCAL(I)),D1(JCCT+JS_LOCAL(I)), ADB1F400.261
& D1(JLAND+JS_LOCAL(I)), ADB1F400.262
RAD_CTL1.845
C Size and control variables RAD_CTL1.846
RAD_CTL1.847
& SECS_PER_STEPim(atmos_im),LW_TABLES, ADB1F400.263
RAD_CTL1.849
C Diagnostics out RAD_CTL1.850
RAD_CTL1.851
& STASHWORK(JS_LOCAL(I)+SI(204,2,im_index)), SF(204,2), ADB1F400.264
& STASHWORK(JS_LOCAL(I)+SI(206,2,im_index)), SF(206,2), ADB1F400.265
& STASHWORK(JS_LOCAL(I)+SI(207,2,im_index)), SF(207,2), ADB1F400.266
& STASHWORK(JS_LOCAL(I)+SI(208,2,im_index)), SF(208,2), ADB1F400.267
& L_CLOUD_WATER_PARTITION, AYY1F404.262
& SP_LOCAL(I),P_LEVELS,CLOUD_LEVELS, ADB1F400.268
& Q_LEVELS,OZONE_LEVELS, ADB1F400.269
& P_FIELD, ADB1F400.270
RAD_CTL1.859
C Output data RAD_CTL1.860
RAD_CTL1.861
& OLR(FP_LOCAL(I)), ADB1F400.271
& STASHWORK(SI(203,2,im_index)+JS_LOCAL(I)), ADB1F400.272
& RADINCS(FP_LOCAL(I)+OFFSET) ADB1F400.273
& ) ADB1F400.274
! ADB1F400.275
ENDDO ADB1F400.276
! ADB1F400.277
! ADB1F400.278
ELSE IF (H_SECT(2).EQ.'03A') THEN ADB2F404.1018
! ADB1F400.280
! ADB1F400.281
! GENERAL TWO-STREAM CODE: ADB2F404.1019
! ADB1F400.296
! ADB1F400.297
! ADB1F400.301
*IF DEF,MACRO ADB1F400.302
CFPP$ CNCALL ADB1F400.303
*ENDIF ADB1F400.304
*IF -DEF,MPP APBBF401.77
DO I = 1,NCPU*A_LW_SEGMENTS ADB1F400.305
*ELSE APBBF401.78
DO I=1,POINTS/ROW_LENGTH APBBF401.79
*ENDIF APBBF401.80
! ADB1F402.606
! Set array size to an odd number to avoid memory conflicts. ADB2F403.3
RAD_ARRAY_SIZE=2*(SP_LOCAL(I)/2)+1 ADB2F403.4
! ADB2F403.5
! Set the first points of the arrays of sulphates to be used. ADB1F402.607
! A separate assignment is necessary since this array will ADB1F402.608
! not be of the full size unless the sulphur cycle is on. ADB1F402.609
IF (L_USE_SULPC_DIRECT .OR. L_USE_SULPC_INDIRECT_LW) THEN AAJ1F404.13
FIRST_POINT_SULPC=FP_LOCAL(I) ADB1F402.611
ELSE ADB1F402.612
FIRST_POINT_SULPC=1 ADB1F402.613
ENDIF ADB1F402.614
! Similarly for the carbon cycle ACN2F405.81
L_CO2_3D = L_CO2_INTERACTIVE ACN2F405.82
IF (L_CO2_INTERACTIVE) THEN ACN2F405.83
FIRST_POINT_CO2=FP_LOCAL(I) ACN2F405.84
ELSE ACN2F405.85
FIRST_POINT_CO2=1 ACN2F405.86
ENDIF ACN2F405.87
! ADB1F400.306
IF (L_USE_SOOT_DIRECT) THEN ALR3F405.58
FIRST_POINT_SOOT=FIRST_POINT ALR3F405.59
ELSE ALR3F405.60
FIRST_POINT_SOOT=1 ALR3F405.61
ENDIF ALR3F405.62
! ADB2F404.1020
! ADB2F404.1021
! ADB2F404.1022
CALL R2_LWRAD(ICODE, ADB1F400.307
ADB1F400.308
C Input data ADB1F400.309
& D1(JQ(1)+JS_LOCAL(I)),CO2_MMR,OZONE_1(FP_LOCAL(I),1), ADB1F400.310
& CO2_DIM1, CO2_DIM2, CO2_3D(FIRST_POINT_CO2,1), ACN2F405.88
& L_CO2_3D, ACN2F405.89
& N2OMMR, CH4MMR, C11MMR, C12MMR, C113MMR, ADB1F405.544
& HCFC22MMR, HFC125MMR, HFC134AMMR, ADB1F405.545
& D1(JTHETA(1)+JS_LOCAL(I)), ADB1F400.311
& D1(JP_EXNER(1)+JS_LOCAL(I)),TSTAR_RAD(FP_LOCAL(I)), ARE2F404.202
& D1(JPSTAR+JS_LOCAL(I)),AKH,BKH, ADB1F400.313
& A_LEVDEPC(JAK),A_LEVDEPC(JBK), ADB1F400.314
! Options for treating clouds ADB1F402.862
& L_GLOBAL_CLOUD_TOP, GLOBAL_CLOUD_TOP, ADB1F402.863
! Stratiform Cloud Fields ADB1F400.315
& L_CLOUD_WATER_PARTITION, AYY1F404.263
& AREA_CLOUD_FRACTION(FP_LOCAL(I),1), ASK1F405.272
& CLOUD_FRACTION(FP_LOCAL(I),1), ADB1F400.316
& D1(JQCL(1)+JS_LOCAL(I)),D1(JQCF(1)+JS_LOCAL(I)), ADB1F400.317
! Convective Cloud Fields ADB1F400.318
& D1(JCCA(1)+JS_LOCAL(I)),D1(JCCLWP+JS_LOCAL(I)), AJX0F404.14
& D1(JCCB+JS_LOCAL(I)),D1(JCCT+JS_LOCAL(I)), ADB1F400.320
& L_3D_CCA, AJX0F404.15
! Surface Fields ADB1F400.321
& D1(JLAND+JS_LOCAL(I)), ADB1F400.322
& D1(JICE_FRACTION+JS_LOCAL(I)), ADB1F400.323
& D1(JSNODEP+JS_LOCAL(I)), ADB1F402.615
! Aerosol Fields ADB1F400.324
& L_CLIMAT_AEROSOL, BL_LEVELS, ADB1F402.616
& L_USE_SULPC_DIRECT, L_USE_SULPC_INDIRECT_LW, AAJ1F404.14
& SULP_DIM1,SULP_DIM2, ADB1F401.826
& ACCUM_SULPHATE(FIRST_POINT_SULPC, 1), ADB1F402.617
& AITKEN_SULPHATE(FIRST_POINT_SULPC, 1), ADB1F402.618
& DISS_SULPHATE(FIRST_POINT_SULPC, 1), ADB2F404.1024
& L_USE_SOOT_DIRECT, ALR3F405.63
& SOOT_DIM1,SOOT_DIM2, ALR3F405.64
& FRESH_SOOT(FIRST_POINT_SOOT, 1), ALR3F405.65
& AGED_SOOT(FIRST_POINT_SOOT, 1), ALR3F405.66
! Level of tropopause ADB1F402.619
& TRINDX(FP_LOCAL(I)) ADB2F404.1025
ADB1F400.326
C Size and control variables ADB1F400.327
ADB1F400.328
! Spectral data ADB2F404.1026
*CALL LWSARG3A ADB2F404.1027
! ADB2F404.1028
! Algorithmic options ADB2F404.1029
*CALL LWCARG3A ADB2F404.1030
& , ADB2F404.1031
& SECS_PER_STEPim(atmos_im), ADB2F404.1032
C Diagnostics out ADB1F400.330
ADB1F400.331
& STASHWORK(JS_LOCAL(I)+SI(204,2,im_index)), SF(204,2), ADB1F400.332
& STASHWORK(JS_LOCAL(I)+SI(206,2,im_index)), SF(206,2), ADB1F400.333
& STASHWORK(JS_LOCAL(I)+SI(207,2,im_index)), SF(207,2), ADB1F400.334
& STASHWORK(JS_LOCAL(I)+SI(208,2,im_index)), SF(208,2), ADB1F400.335
& STASHWORK(JS_LOCAL(I)+SI(233,2,im_index)), SF(233,2), ADB1F400.336
& STASHWORK(JS_LOCAL(I)+SI(237,2,im_index)), SF(237,2), ADB2F404.1033
& STASHWORK(JS_LOCAL(I)+SI(238,2,im_index)), SF(238,2), ADB2F404.1034
! Physical Dimensions ADB1F400.337
& SP_LOCAL(I),P_LEVELS,CLOUD_LEVELS, ADB1F400.338
& Q_LEVELS,OZONE_LEVELS, ADB1F400.339
& P_FIELD, RAD_ARRAY_SIZE, P_LEVELS, 1,N_CCA_LEV, AJX0F404.16
ADB1F400.350
C Output data ADB1F400.351
ADB1F400.352
& OLR(FP_LOCAL(I)), ADB1F400.353
& STASHWORK(SI(203,2,im_index)+JS_LOCAL(I)), ADB1F400.354
& RADINCS(FP_LOCAL(I)+OFFSET) ADB1F400.355
& ) ADB1F400.356
IF (ICODE.NE.0) RETURN ADB1F401.828
! ADB1F400.357
ENDDO ADB1F400.358
! ADB1F400.359
ELSE ADB2F404.1035
! ADB2F404.1036
ICODE=0 ADB2F404.1037
CMESSAGE='Unknown version of LW radiation in RAD_CTL.' ADB2F404.1038
RETURN ADB2F404.1039
! ADB2F404.1040
ENDIF ADB2F404.1041
ADB1F400.361
ADB1F400.362
RAD_CTL1.864
IF(LTIMER) THEN RAD_CTL1.865
CALL TIMER('LWRAD ',4) RAD_CTL1.866
CALL TIMER('LW_RAD',6) GPB1F401.22
END IF RAD_CTL1.867
RAD_CTL1.868
FIRST_POINT = START_POINT_NO_HALO APBBF401.44
LAST_POINT = END_P_POINT_NO_HALO APBBF401.45
POINTS = LAST_POINT-FIRST_POINT+1 APBBF401.46
C RAD_CTL1.879
C ----------------------------------------------------- RAD_CTL1.880
C RAD_CTL1.881
RAD_CTL1.882
CL Store surface radiative temperature ARE2F404.203
ARE2F404.204
DO I=FIRST_POINT,LAST_POINT ARE2F404.205
RADINCS(I+(P_LEVELS+1)*P_FIELD+OFFSET) = TSTAR_RAD(I) ARE2F404.206
END DO ARE2F404.207
ARE2F404.208
*IF -DEF,FRADIO GGH3F401.33
CL 2.2.2 Write out LW radiation increments RAD_CTL1.884
LEN=(P_FIELDDA*(P_LEVELS+3)+511)/512*512 !no words for LW incs ARE2F404.209
NFTSWAP=16 RAD_CTL1.886
CALL SETPOS(NFTSWAP,LEN,ICODE) GTD0F400.119
CALL BUFFOUT(NFTSWAP,RADINCS,LEN,LEN_IO,A_IO) RAD_CTL1.888
RAD_CTL1.889
C Error check RAD_CTL1.890
RAD_CTL1.891
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.(LEN)) THEN RAD_CTL1.892
CMESSAGE=' RAD_CTL :Paging IO Error ' RAD_CTL1.893
ICODE=2 RAD_CTL1.894
RETURN RAD_CTL1.895
END IF RAD_CTL1.896
*ENDIF RAD_CTL1.897
RAD_CTL1.898
IF (LEMCORR) THEN GSS1F304.775
C RAD_CTL1.900
C SUM LONG WAVE FLUXES INTO THE ATMOSPHERE RAD_CTL1.901
C ADD INTO THE NET DIABATIC FLUXES INTO THE RAD_CTL1.902
C ATMOSPHERE FOR USE IN THE ENERGY CORRECTION RAD_CTL1.903
C PROCEDURE RAD_CTL1.904
C RAD_CTL1.905
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.906
NET_ATM_FLUX(I) = - OLR(I) RAD_CTL1.907
& - RADINCS(I+OFFSET) RAD_CTL1.908
& - STASHWORK(SI(203,2,im_index)+I-1) GRB4F305.419
END DO RAD_CTL1.910
C RAD_CTL1.911
IF (LTIMER) THEN RAD_CTL1.912
CALL TIMER ('FLX_DIAG',3) RAD_CTL1.913
END IF RAD_CTL1.914
C RAD_CTL1.915
CALL FLUX_DIAG(NET_ATM_FLUX,COS_P_LATITUDE, APB5F401.154
& P_FIELD,FIRST_POINT,POINTS, APB5F401.155
& 1.0,A_LW_RADSTEP*SECS_PER_STEPim(atmos_im), APB5F401.156
& D1(JNET_FLUX)) GSM3F404.48
C RAD_CTL1.919
IF (LTIMER) THEN RAD_CTL1.920
CALL TIMER ('FLX_DIAG',4) RAD_CTL1.921
END IF RAD_CTL1.922
C RAD_CTL1.923
END IF ! LEMCORR GSS1F304.776
C GSS1F304.777
CL End of branch depending whether longwave radiation is called RAD_CTL1.925
RAD_CTL1.926
END IF RAD_CTL1.927
RAD_CTL1.928
C RAD_CTL1.929
CL 2.3 add LW radiative heating to temperatures WI200893.31
RAD_CTL1.931
DO 23 LEVEL=1,P_LEVELS RAD_CTL1.932
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.933
D1(JTHETA(LEVEL)+I-1)= RAD_CTL1.934
& D1(JTHETA(LEVEL)+I-1)+RADINCS(I+LEVEL*P_FIELD+OFFSET) RAD_CTL1.935
! ARN1F404.136
!! Add LW heating rates for layers 1 to BL_LEVELS for output ARN1F404.137
!! for A03_6A ARN1F404.138
! ARN1F404.139
IF (L_RADHEAT .AND. LEVEL .LE. BL_LEVELS) THEN ARN1F404.140
RADHEAT_RATE(I,LEVEL) = RADHEAT_RATE(I,LEVEL) ARN1F404.141
& + RADINCS(I+LEVEL*P_FIELD+OFFSET) ARN1F404.142
& / SECS_PER_STEPim(atmos_im) ARN1F404.143
ENDIF ARN1F404.144
END DO RAD_CTL1.936
23 CONTINUE RAD_CTL1.937
RAD_CTL1.938
CL Set up total net down surface radiation flux in SURF_RADFLUX RAD_CTL1.939
RAD_CTL1.940
DO I=FIRST_POINT,LAST_POINT RAD_CTL1.941
SURF_RADFLUX(I)=RADINCS(I+OFFSET)+SURF_RADFLUX(I) RAD_CTL1.942
END DO RAD_CTL1.943
ARE2F404.210
CL Set up total net down surface radiation flux for snow-free and ARE2F404.211
CL snow-covered fractions of gridboxes ARE2F404.212
ARE2F404.213
IF ( L_MOSES_II ) THEN ARE2F404.214
CL Set the SW+LW flux over the snow-free surface to the gridbox mean ABX1F405.165
CL SW+LW flux (valid for sea points but corrected below for land points) ABX1F405.166
DO I=FIRST_POINT,LAST_POINT ABX1F405.167
RAD_NO_SNOW(I) = SURF_RADFLUX(I) ABX1F405.168
ENDDO ABX1F405.169
ABX1F405.170
CL Derive fluxes over snow-free and snow-covered fraction on land points ABX1F405.171
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.172
I = LAND_LIST(L) ABX1F405.173
RAD_NO_SNOW(I) = RAD_NO_SNOW(I) + RADINCS(I+OFFSET) ABX1F405.174
& + SBCON*TSTAR_RAD(I)**4 ABX1F405.175
RAD_SNOW(I) = RAD_SNOW(I) + RADINCS(I+OFFSET) ABX1F405.176
& + SBCON*TSTAR_RAD(I)**4 ABX1F405.177
ENDDO ABX1F405.178
DO N=1,NTYPE-1 ARE2F404.221
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.179
I = LAND_LIST(L) ARE2F404.223
J = (N-1)*LAND_FIELD + L - 1 ARE2F404.224
RAD_NO_SNOW(I) = RAD_NO_SNOW(I) - ARE2F404.225
& D1(JFRAC_TYP+J)*SBCON*D1(JTSTAR_TYP+J)**4 ARE2F404.226
ENDDO ARE2F404.227
ENDDO ARE2F404.228
DO L=LAND1,LAND1+LAND_PTS-1 ABX1F405.180
I = LAND_LIST(L) ARE2F404.230
J = (NTYPE-1)*LAND_FIELD + L - 1 ARE2F404.231
RAD_SNOW(I) = RAD_SNOW(I) - SBCON*D1(JTSTAR_TYP+J)**4 ABX1F405.181
ENDDO ARE2F404.234
CL Overwrite SURF_RADFLUX with the gridbox average for land points ARE1F405.9
DO L=LAND1,LAND1+LAND_PTS-1 ARE1F405.10
I = LAND_LIST(L) ARE1F405.11
SURF_RADFLUX(I) = (1. - SNOW_FRAC(I))*RAD_NO_SNOW(I) ARE1F405.12
& + SNOW_FRAC(I)*RAD_SNOW(I) ARE1F405.13
END DO ARE1F405.14
ARE1F405.15
ARE1F405.16
ENDIF ARE2F404.235
RAD_CTL1.944
CL 2.4 Copy diagnostic information to STASHWORK for processing. RAD_CTL1.945
RAD_CTL1.946
IF(L_LW_RADIATE) THEN RAD_CTL1.947
RAD_CTL1.948
CL 2.4.1 Surface fluxes RAD_CTL1.949
RAD_CTL1.950
IF(SF(202,2)) THEN RAD_CTL1.951
RAD_CTL1.952
CL Surface radiative flux over ice covered fraction RAD_CTL1.953
RAD_CTL1.954
CALL COPYDIAG (STASHWORK(SI(202,2,im_index)),RADINCS(1+OFFSET), GRB4F305.420
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1260
& im_ident,2,202, GPB1F403.1261
*CALL ARGPPX GPB1F403.1262
& ICODE,CMESSAGE) GPB1F403.1263
GPB1F403.1264
IF (ICODE .GT. 0) RETURN GPB1F403.1265
RAD_CTL1.957
END IF RAD_CTL1.958
RAD_CTL1.959
IF(SF(201,2)) THEN RAD_CTL1.960
RAD_CTL1.961
CL Total Surface radiative flux RAD_CTL1.962
RAD_CTL1.963
DO I = FIRST_POINT,LAST_POINT RAD_CTL1.964
STASHWORK(SI(201,2,im_index)+I-1) = RADINCS(I+OFFSET)+ GRB4F305.421
& STASHWORK(SI(203,2,im_index)+I-1) GRB4F305.422
END DO RAD_CTL1.967
RAD_CTL1.968
END IF RAD_CTL1.969
IF(SF(232,2)) THEN RAD_CTL1.970
RAD_CTL1.971
CL 2.4.2 Long wave atmospheric heating rates from RADINCS RAD_CTL1.972
RAD_CTL1.973
CALL COPYDIAG_3D (STASHWORK(SI(232,2,im_index)), GRB4F305.423
& RADINCS(1+P_FIELD+OFFSET), GRB4F305.424
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH,P_LEVELS, RAD_CTL1.975
& STLIST(1,STINDEX(1,232,2,im_index)),LEN_STLIST, GRB4F305.425
& STASH_LEVELS,NUM_STASH_LEVELS+1, GPB1F403.1266
& im_ident,2,232, GPB1F403.1267
*CALL ARGPPX GPB1F403.1268
& ICODE,CMESSAGE) GPB1F403.1269
RAD_CTL1.978
IF(ICODE.GT.0) THEN RAD_CTL1.979
RETURN RAD_CTL1.980
END IF RAD_CTL1.981
RAD_CTL1.982
C Convert to heating rates from increments per timestep RAD_CTL1.983
RAD_CTL1.984
DO LEVEL = 1, GRB4F305.426
& STASH_LEVELS(1,-STLIST(10,STINDEX(1,232,2,im_index))) GRB4F305.427
START_POINT=SI(232,2,im_index)+(LEVEL-1)*P_FIELD GRB4F305.428
DO I = 1,P_FIELD RAD_CTL1.987
STASHWORK(START_POINT+I-1) = STASHWORK(START_POINT+I-1) / RAD_CTL1.988
& SECS_PER_STEPim(atmos_im) ADR1F305.130
END DO RAD_CTL1.990
RAD_CTL1.991
END DO RAD_CTL1.992
END IF RAD_CTL1.993
RAD_CTL1.994
CL 2.4.3 outgoing flux RAD_CTL1.995
RAD_CTL1.996
IF(SF(205,2)) THEN RAD_CTL1.997
RAD_CTL1.998
CL toa outgoing flux RAD_CTL1.999
RAD_CTL1.1000
CALL COPYDIAG (STASHWORK(SI(205,2,im_index)),OLR, GRB4F305.429
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, GPB1F403.1270
& im_ident,2,205, GPB1F403.1271
*CALL ARGPPX GPB1F403.1272
& ICODE,CMESSAGE) GPB1F403.1273
GPB1F403.1274
IF (ICODE .GT. 0) RETURN GPB1F403.1275
RAD_CTL1.1003
END IF RAD_CTL1.1004
RAD_CTL1.1005
CL 2.4.4 All other diagnostics RAD_CTL1.1006
RAD_CTL1.1007
CALL EXTDIAG(STASHWORK,SI(1,2,im_index),SF(1,2),201,NITEMS, GRB4F305.430
& STASHLEN,ROW_LENGTH, RAD_CTL1.1009
& STLIST,LEN_STLIST,STINDEX(1,1,2,im_index),2,STASH_LEVELS, GRB4F305.431
& NUM_STASH_LEVELS+1, STASH_PSEUDO_LEVELS, RAD_CTL1.1011
& NUM_STASH_PSEUDO, GPB1F403.1511
& im_ident,2, GPB1F403.1512
*CALL ARGPPX GPB1F403.1513
& ICODE,CMESSAGE) GPB1F403.1514
RAD_CTL1.1013
IF(ICODE.GT.0) THEN RAD_CTL1.1014
RETURN RAD_CTL1.1015
END IF RAD_CTL1.1016
RAD_CTL1.1017
C Here ends "IF(L_LW_RADIATE)" RAD_CTL1.1018
RAD_CTL1.1019
ENDIF RAD_CTL1.1020
*IF DEF,MPP APBBF401.81
! Update halos of all fields updated by radiation APBBF401.82
CALL SWAPBOUNDS(RADINCS,ROW_LENGTH,P_ROWS, APBBF401.83
& EW_Halo,NS_Halo,P_LEVELS+3) ABX1F405.182
CALL SWAPBOUNDS(RADINCS(OFFSET+1), ROW_LENGTH,P_ROWS, APBBF401.85
& EW_Halo,NS_Halo,P_LEVELS+2) ABX1F405.183
CALL SWAPBOUNDS(D1(JTHETA(1)),ROW_LENGTH,P_ROWS, APBBF401.87
& EW_Halo,NS_Halo,P_LEVELS) APBBF401.88
CALL SWAPBOUNDS(SURF_RADFLUX,ROW_LENGTH,P_ROWS, APBBF401.89
& EW_Halo,NS_Halo,1) APBBF401.90
CALL SWAPBOUNDS(PHOTOSYNTH_ACT_RAD,ROW_LENGTH,P_ROWS, ADR4F403.3
& EW_Halo,NS_Halo,1) ADR4F403.4
IF (L_RADHEAT) THEN ARN1F404.145
CALL SWAPBOUNDS(RADHEAT_RATE,ROW_LENGTH,P_ROWS, ARN1F404.146
& EW_Halo,NS_Halo,BL_LEVELS) ARN1F404.147
ENDIF ARN1F404.148
IF (L_MOSES_II) THEN ABX1F405.184
CALL SWAPBOUNDS(RAD_SNOW,ROW_LENGTH,P_ROWS, ABX1F405.185
& EW_Halo,NS_Halo,1) ABX1F405.186
CALL SWAPBOUNDS(RAD_NO_SNOW,ROW_LENGTH,P_ROWS, ABX1F405.187
& EW_Halo,NS_Halo,1) ABX1F405.188
ENDIF ABX1F405.189
*ENDIF APBBF401.91
RAD_CTL1.1021
CL 2.4.5 Call STASH to process output. Even on non-radiation timesteps WI200893.26
CL (neither LW nor SW called), STASH is called for certain WI200893.27
CL radiation diagnostics from CLD_CTL. WI200893.28
RAD_CTL1.1024
IF(LTIMER) THEN RAD_CTL1.1025
CALL TIMER('STASH ',3) RAD_CTL1.1026
END IF RAD_CTL1.1027
RAD_CTL1.1028
CALL STASH(a_sm,a_im,2,STASHWORK, GKR0F305.977
*CALL ARGSIZE @DYALLOC.3078
*CALL ARGD1 @DYALLOC.3079
*CALL ARGDUMA @DYALLOC.3080
*CALL ARGDUMO @DYALLOC.3081
*CALL ARGDUMW GKR1F401.255
*CALL ARGSTS @DYALLOC.3082
*CALL ARGPPX GKR0F305.978
& ICODE,CMESSAGE) @DYALLOC.3086
RAD_CTL1.1030
IF(LTIMER) THEN RAD_CTL1.1031
CALL TIMER('STASH ',4) RAD_CTL1.1032
END IF RAD_CTL1.1033
RAD_CTL1.1034
RETURN RAD_CTL1.1035
END RAD_CTL1.1036
*ENDIF RAD_CTL1.1037