SUBROUTINE R2_ZERO_1D(N, X) 30DIAG3A.22
! DIAG3A.23
! DIAG3A.24
! DIAG3A.25
IMPLICIT NONE DIAG3A.26
! DIAG3A.27
! DIAG3A.28
! DUMMY ARGUMENTS DIAG3A.29
INTEGER !, INTENT(IN) DIAG3A.30
& N DIAG3A.31
! LENGTH OF ARRAY DIAG3A.32
REAL !, INTENT(OUT) DIAG3A.33
& X(N) DIAG3A.34
! ARRAY TO BE ZEROED DIAG3A.35
! DIAG3A.36
! LOCAL VARIABLES DIAG3A.37
INTEGER DIAG3A.38
& I DIAG3A.39
! LOOP VARIABLE DIAG3A.40
! DIAG3A.41
! DIAG3A.42
! DIAG3A.43
DO I=1, N DIAG3A.44
X(I)=0.0E+00 DIAG3A.45
ENDDO DIAG3A.46
! DIAG3A.47
! DIAG3A.48
! DIAG3A.49
RETURN DIAG3A.50
END DIAG3A.51
!+ Subroutine to initialize diagnostics and coupling arrays. DIAG3A.52
! DIAG3A.53
! Purpose: DIAG3A.54
! The coupling and diagnostic arrays are zeroed. DIAG3A.55
! DIAG3A.56
! Method: DIAG3A.57
! Straightforward. DIAG3A.58
! DIAG3A.59
! Current Owner of Code: J. M. Edwards DIAG3A.60
! DIAG3A.61
! History: DIAG3A.62
! Version Date Comment DIAG3A.63
! 4.0 27-07-95 Original Code DIAG3A.64
! (J. M. Edwards) DIAG3A.65
! DIAG3A.66
! Description of Code: DIAG3A.67
! FORTRAN 77 with extensions listed in documentation. DIAG3A.68
! DIAG3A.69
!- --------------------------------------------------------------------- DIAG3A.70
SUBROUTINE R2_INIT_COUPLE_DIAG(N_PROFILE 1,5DIAG3A.71
& , SEA_FLUX DIAG3A.72
& , L_SURFACE_DOWN_FLUX, SURFACE_DOWN_FLUX DIAG3A.73
& , L_SURF_DOWN_CLR, SURF_DOWN_CLR DIAG3A.74
& , L_SURF_UP_CLR, SURF_UP_CLR DIAG3A.75
& , L_FLUX_BELOW_690NM_SURF, FLUX_BELOW_690NM_SURF DIAG3A.76
& , NPD_PROFILE DIAG3A.77
& ) DIAG3A.78
! DIAG3A.79
! DIAG3A.80
! DIAG3A.81
IMPLICIT NONE DIAG3A.82
! DIAG3A.83
! DIAG3A.84
! DUMMY ARGUMENTS DIAG3A.85
! DIAG3A.86
! DIMENSIONS OF ARRAYS DIAG3A.87
INTEGER !, INTENT(IN) DIAG3A.88
& NPD_PROFILE DIAG3A.89
! MAXIMUM NUMBER OF ATMOSPHERIC PROFILES DIAG3A.90
! DIAG3A.91
INTEGER !, INTENT(IN) DIAG3A.92
& N_PROFILE DIAG3A.93
! NUMBER OF ATMOSPHERIC PROFILES DIAG3A.94
! DIAG3A.95
! SWITCHES FOR DIAGNOSTICS: DIAG3A.96
LOGICAL !, INTENT(IN) DIAG3A.97
& L_FLUX_BELOW_690NM_SURF DIAG3A.98
! FLUX BELOW 690NM AT SURFACE TO BE CALCULATED DIAG3A.99
& , L_SURFACE_DOWN_FLUX DIAG3A.100
! DOWNWARD SURFACE FLUX REQUIRED DIAG3A.101
& , L_SURF_DOWN_CLR DIAG3A.102
! CALCULATE DOWNWARD CLEAR FLUX DIAG3A.103
& , L_SURF_UP_CLR DIAG3A.104
! CALCULATE UPWARD CLEAR FLUX DIAG3A.105
! DIAG3A.106
! SURFACE FLUXES FOR COUPLING OR DIAGNOSTIC USE DIAG3A.107
REAL !, INTENT(OUT) DIAG3A.108
& SEA_FLUX(NPD_PROFILE) DIAG3A.109
! NET DOWNWARD FLUX INTO SEA DIAG3A.110
& , SURFACE_DOWN_FLUX(NPD_PROFILE) DIAG3A.111
! DOWNWARD FLUX AT SURFACE DIAG3A.112
& , SURF_DOWN_CLR(NPD_PROFILE) DIAG3A.113
! CLEAR-SKY DOWNWARD FLUX AT SURFACE DIAG3A.114
& , SURF_UP_CLR(NPD_PROFILE) DIAG3A.115
! CLEAR-SKY UPWARD FLUX AT SURFACE DIAG3A.116
& , FLUX_BELOW_690NM_SURF(NPD_PROFILE) DIAG3A.117
! SURFACE FLUX BELOW 690NM DIAG3A.118
! DIAG3A.119
! DIAG3A.120
! DIAG3A.121
CALL R2_ZERO_1D
(N_PROFILE, SEA_FLUX) DIAG3A.122
! DIAG3A.123
IF (L_SURFACE_DOWN_FLUX) THEN DIAG3A.124
CALL R2_ZERO_1D(N_PROFILE, SURFACE_DOWN_FLUX) DIAG3A.125
ENDIF DIAG3A.126
! DIAG3A.127
IF (L_SURF_DOWN_CLR) THEN DIAG3A.128
CALL R2_ZERO_1D(N_PROFILE, SURF_DOWN_CLR) DIAG3A.129
ENDIF DIAG3A.130
! DIAG3A.131
IF (L_SURF_UP_CLR) THEN DIAG3A.132
CALL R2_ZERO_1D(N_PROFILE, SURF_UP_CLR) DIAG3A.133
ENDIF DIAG3A.134
! DIAG3A.135
IF (L_FLUX_BELOW_690NM_SURF) THEN DIAG3A.136
CALL R2_ZERO_1D(N_PROFILE, FLUX_BELOW_690NM_SURF) DIAG3A.137
ENDIF DIAG3A.138
! DIAG3A.139
! DIAG3A.140
! DIAG3A.141
RETURN DIAG3A.142
END DIAG3A.143
!+ Subroutine to calculate spectral diagnostics and coupling arrays. DIAG3A.144
! DIAG3A.145
! Purpose: DIAG3A.146
! The coupling and diagnostic arrays are calculated. DIAG3A.147
! DIAG3A.148
! Method: DIAG3A.149
! Straightforward. DIAG3A.150
! DIAG3A.151
! Current Owner of Code: J. M. Edwards DIAG3A.152
! DIAG3A.153
! History: DIAG3A.154
! Version Date Comment DIAG3A.155
! 4.0 27-07-95 Original Code DIAG3A.156
! (J. M. Edwards) DIAG3A.157
! 4.1 10-06-96 Formulation over ADB1F401.127
! sea-ice revised. ADB1F401.128
! Corrections to ADB1F401.129
! some diagnostics. ADB1F401.130
! (J. M. Edwards) ADB1F401.131
! DIAG3A.158
! Description of Code: DIAG3A.159
! FORTRAN 77 with extensions listed in documentation. DIAG3A.160
! DIAG3A.161
!- --------------------------------------------------------------------- DIAG3A.162
SUBROUTINE R2_COUPLE_DIAG(N_PROFILE, L_NET, ISOLIR 1DIAG3A.163
& , ALBEDO_FIELD_DIFF, ALBEDO_FIELD_DIR DIAG3A.164
& , ALBEDO_SEA_DIFF, ALBEDO_SEA_DIR DIAG3A.165
& , N_FRAC_ICE_POINT, I_FRAC_ICE_POINT, ICE_FRACTION ADB1F401.132
& , PLANCK_FREEZE_SEA ADB1F401.133
& , PLANCK_AIR_SURFACE, THERMAL_SOURCE_GROUND ADB1F401.134
& , FLUX_DOWN, FLUX_UP, FLUX_DIRECT DIAG3A.167
& , FLUX_DOWN_CLEAR, FLUX_UP_CLEAR, FLUX_DIRECT_CLEAR DIAG3A.168
& , WEIGHT_690NM DIAG3A.169
& , SEA_FLUX DIAG3A.170
& , L_SURFACE_DOWN_FLUX, SURFACE_DOWN_FLUX DIAG3A.171
& , L_SURF_DOWN_CLR, SURF_DOWN_CLR DIAG3A.172
& , L_SURF_UP_CLR, SURF_UP_CLR DIAG3A.173
& , L_FLUX_BELOW_690NM_SURF, FLUX_BELOW_690NM_SURF DIAG3A.174
& , NPD_PROFILE DIAG3A.175
& ) DIAG3A.176
! DIAG3A.177
! DIAG3A.178
! DIAG3A.179
IMPLICIT NONE DIAG3A.180
! DIAG3A.181
! DIAG3A.182
! COMDECKS INCLUDED DIAG3A.183
! SPECTRAL REGIONS DIAG3A.184
*CALL SPCRG3A DIAG3A.185
! DIAG3A.186
! DUMMY ARGUMENTS DIAG3A.187
! DIAG3A.188
! DIMENSIONS OF ARRAYS DIAG3A.189
INTEGER !, INTENT(IN) DIAG3A.190
& NPD_PROFILE DIAG3A.191
! MAXIMUM NUMBER OF ATMOSPHERIC PROFILES DIAG3A.192
! DIAG3A.193
INTEGER !, INTENT(IN) DIAG3A.194
& N_PROFILE DIAG3A.195
! NUMBER OF ATMOSPHERIC PROFILES DIAG3A.196
& , ISOLIR DIAG3A.197
! SPECTRAL REGION DIAG3A.198
! DIAG3A.199
! LOGICAL SWITCHES FOR THE CODE DIAG3A.200
LOGICAL !, INTENT(IN) DIAG3A.201
& L_NET DIAG3A.202
! FLAG FOR NET FLUXES DIAG3A.203
! DIAG3A.204
! SWITCHES FOR DIAGNOSTICS: DIAG3A.205
LOGICAL !, INTENT(IN) DIAG3A.206
& L_FLUX_BELOW_690NM_SURF DIAG3A.207
! FLUX BELOW 690NM AT SURFACE TO BE CALCULATED DIAG3A.208
& , L_SURFACE_DOWN_FLUX DIAG3A.209
! DOWNWARD SURFACE FLUX REQUIRED DIAG3A.210
& , L_SURF_DOWN_CLR DIAG3A.211
! CALCULATE DOWNWARD CLEAR FLUX DIAG3A.212
& , L_SURF_UP_CLR DIAG3A.213
! CALCULATE UPWARD CLEAR FLUX DIAG3A.214
! DIAG3A.215
! ALBEDOS DIAG3A.216
REAL !, INTENT(IN) DIAG3A.217
& ALBEDO_FIELD_DIFF(NPD_PROFILE) DIAG3A.218
! DIFFUSE ALBEDO MEANED OVER GRID BOX DIAG3A.219
& , ALBEDO_FIELD_DIR(NPD_PROFILE) DIAG3A.220
! DIRECT ALBEDO MEANED OVER GRID BOX DIAG3A.221
& , ALBEDO_SEA_DIFF(NPD_PROFILE) DIAG3A.222
! DIFFUSE ALBEDO OF OPEN SEA DIAG3A.223
& , ALBEDO_SEA_DIR(NPD_PROFILE) DIAG3A.224
! DIRECT ALBEDO MEANED OF OPEN SEA DIAG3A.225
! DIAG3A.226
REAL !, INTENT(IN) DIAG3A.227
& THERMAL_SOURCE_GROUND(NPD_PROFILE) DIAG3A.228
! THERMAL SOURCE AT GROUND DIAG3A.229
& , PLANCK_AIR_SURFACE(NPD_PROFILE) ADB1F401.135
! PLANCK FUNCTION AT NEAR-SURFACE AIR TEMPERATURE IN BAND ADB1F401.136
! DIAG3A.230
! ARGUMENTS RELATING TO SEA ICE. ADB1F401.137
INTEGER !, INTENT(IN) ADB1F401.138
& N_FRAC_ICE_POINT ADB1F401.139
! NUMBER OF POINTS WITH FRACTIONAL ICE COVER ADB1F401.140
& , I_FRAC_ICE_POINT(NPD_PROFILE) ADB1F401.141
! INDICES OF POINTS WITH FRACTIONAL ICE COVER ADB1F401.142
REAL !, INTENT(IN) ADB1F401.143
& ICE_FRACTION(NPD_PROFILE) ADB1F401.144
! ICE FRACTION ADB1F401.145
REAL !, INTENT(IN) ADB1F401.146
& PLANCK_FREEZE_SEA ADB1F401.147
! PLANCK FUNCTION OVER FREEZING SEA ADB1F401.148
! ADB1F401.149
REAL !, INTENT(IN) DIAG3A.231
& WEIGHT_690NM DIAG3A.232
! WEIGHTING APPLIED TO BAND FOR REGION BELOW 690 NM DIAG3A.233
! DIAG3A.234
! CALCULATED FLUXES DIAG3A.235
REAL !, INTENT(IN) DIAG3A.236
& FLUX_DOWN(NPD_PROFILE) DIAG3A.237
! TOTAL DOWNWARD OR NET FLUX AT SURFACE DIAG3A.238
& , FLUX_DIRECT(NPD_PROFILE) DIAG3A.239
! DIRECT SOLAR FLUX AT SURFACE DIAG3A.240
& , FLUX_UP(NPD_PROFILE) DIAG3A.241
! UPWARD FLUX AT SURFACE DIAG3A.242
& , FLUX_DOWN_CLEAR(NPD_PROFILE) DIAG3A.243
! TOTAL CLEAR-SKY DOWNWARD OR NET FLUX AT SURFACE DIAG3A.244
& , FLUX_UP_CLEAR(NPD_PROFILE) DIAG3A.245
! CLEAR-SKY UPWARD FLUX AT SURFACE DIAG3A.246
& , FLUX_DIRECT_CLEAR(NPD_PROFILE) DIAG3A.247
! CLEAR-SKY DIRECT SOLAR FLUX AT SURFACE DIAG3A.248
! DIAG3A.249
! DIAG3A.250
! SURFACE FLUXES FOR COUPLING OR DIAGNOSTIC USE DIAG3A.251
REAL !, INTENT(INOUT) DIAG3A.252
& SEA_FLUX(NPD_PROFILE) DIAG3A.253
! NET DOWNWARD FLUX INTO SEA DIAG3A.254
& , SURFACE_DOWN_FLUX(NPD_PROFILE) DIAG3A.255
! DOWNWARD FLUX AT SURFACE DIAG3A.256
& , SURF_DOWN_CLR(NPD_PROFILE) DIAG3A.257
! CLEAR-SKY DOWNWARD FLUX AT SURFACE DIAG3A.258
& , SURF_UP_CLR(NPD_PROFILE) DIAG3A.259
! CLEAR-SKY UPWARD FLUX AT SURFACE DIAG3A.260
& , FLUX_BELOW_690NM_SURF(NPD_PROFILE) DIAG3A.261
! SURFACE FLUX BELOW 690NM DIAG3A.262
! DIAG3A.263
! DIAG3A.264
! LOCAL VARIABLES DIAG3A.265
INTEGER DIAG3A.266
& L DIAG3A.267
! LOOP VARIABLE DIAG3A.268
! DIAG3A.269
! DIAG3A.270
! DIAG3A.271
! DIAG3A.272
! DEPENDING ON THE SOLVER THE TOTAL FLUX AVAILABLE WILL BE EITHER ADB1F401.150
! THE NET FLUX OR THE SEPARATE UPWARD AND DOWNWARD FLUXES, HENCE DIAG3A.274
! EACH DIAGNOSTIC MUST BE ENFOLDED IN AN IF-TEST. ADB1F401.151
! DIAG3A.276
! SINCE DIFFERENTIAL FLUXES ARE USED IN THE INFRA-RED APPROPRIATE DIAG3A.277
! PLANCKIAN SOURCES MUST BE ADDED TO NON-NET FLUXES. A SLIGHTLY DIAG3A.278
! INEFFICIENT FORM HAS BEEN USED IN THE NON-NET CASE, DERIVED IN DIAG3A.279
! ANALOGY WITH THE CASE OF NET FLUXES SINCE THIS MATCHES THE USE DIAG3A.280
! OF ARRAYS IN THE MAIN CODE. DIAG3A.281
! DIAG3A.282
IF (L_NET) THEN DIAG3A.283
IF (ISOLIR.EQ.IP_SOLAR) THEN DIAG3A.284
DO L=1, N_PROFILE DIAG3A.285
SEA_FLUX(L)=SEA_FLUX(L)+FLUX_DIRECT(L) DIAG3A.286
& *(ALBEDO_SEA_DIFF(L)-ALBEDO_SEA_DIR(L)) DIAG3A.287
& +((1.0E+00-ALBEDO_SEA_DIFF(L)) DIAG3A.288
& /(1.0E+00-ALBEDO_FIELD_DIFF(L))) DIAG3A.289
& *(FLUX_DOWN(L)-FLUX_DIRECT(L) DIAG3A.290
& *(ALBEDO_FIELD_DIFF(L)-ALBEDO_FIELD_DIR(L))) DIAG3A.291
ENDDO DIAG3A.292
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN DIAG3A.293
DO L=1, N_PROFILE DIAG3A.294
SEA_FLUX(L)=SEA_FLUX(L) ADB1F401.152
& +(FLUX_DOWN(L)+THERMAL_SOURCE_GROUND(L)) ADB1F401.153
& *(1.0E+00-ALBEDO_SEA_DIFF(L)) DIAG3A.296
& /(1.0E+00-ALBEDO_FIELD_DIFF(L)) DIAG3A.297
& -(1.0E+00-ALBEDO_SEA_DIFF(L))*PLANCK_FREEZE_SEA ADB1F401.154
ENDDO DIAG3A.298
ENDIF DIAG3A.299
ELSE DIAG3A.300
IF (ISOLIR.EQ.IP_SOLAR) THEN DIAG3A.301
DO L=1, N_PROFILE DIAG3A.302
SEA_FLUX(L)=SEA_FLUX(L)+FLUX_DOWN(L)-FLUX_UP(L) ADB1F401.155
ENDDO DIAG3A.307
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN DIAG3A.308
DO L=1, N_PROFILE DIAG3A.309
SEA_FLUX(L)=SEA_FLUX(L) DIAG3A.310
& +(1.0E+00-ALBEDO_SEA_DIFF(L)) ADB1F401.156
& *(FLUX_DOWN(L)+PLANCK_AIR_SURFACE(L) ADB1F401.157
& -PLANCK_FREEZE_SEA) ADB1F401.158
ENDDO DIAG3A.312
ENDIF DIAG3A.313
ENDIF DIAG3A.314
! DIAG3A.315
IF (L_SURFACE_DOWN_FLUX) THEN DIAG3A.316
IF (L_NET) THEN DIAG3A.317
IF (ISOLIR.EQ.IP_SOLAR) THEN DIAG3A.318
DO L=1, N_PROFILE DIAG3A.319
SURFACE_DOWN_FLUX(L)=SURFACE_DOWN_FLUX(L) DIAG3A.320
& +(FLUX_DOWN(L)+FLUX_DIRECT(L) DIAG3A.321
& *(ALBEDO_FIELD_DIR(L)-ALBEDO_FIELD_DIFF(L))) DIAG3A.322
& /(1.0E+00-ALBEDO_FIELD_DIFF(L)) DIAG3A.323
ENDDO DIAG3A.324
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN DIAG3A.325
DO L=1, N_PROFILE DIAG3A.326
SURFACE_DOWN_FLUX(L)=SURFACE_DOWN_FLUX(L) DIAG3A.327
& +(FLUX_DOWN(L)+THERMAL_SOURCE_GROUND(L)) DIAG3A.328
& /(1.0E+00-ALBEDO_FIELD_DIFF(L)) DIAG3A.329
ENDDO DIAG3A.330
ENDIF DIAG3A.331
ELSE DIAG3A.332
IF (ISOLIR.EQ.IP_SOLAR) THEN ADB1F401.159
DO L=1, N_PROFILE ADB1F401.160
SURFACE_DOWN_FLUX(L)=SURFACE_DOWN_FLUX(L) ADB1F401.161
& +FLUX_DOWN(L) ADB1F401.162
ENDDO ADB1F401.163
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN ADB1F401.164
DO L=1, N_PROFILE ADB1F401.165
SURFACE_DOWN_FLUX(L)=SURFACE_DOWN_FLUX(L) ADB1F401.166
& +FLUX_DOWN(L)+PLANCK_AIR_SURFACE(L) ADB1F401.167
ENDDO ADB1F401.168
ENDIF ADB1F401.169
ENDIF DIAG3A.338
ENDIF DIAG3A.339
! DIAG3A.340
IF (L_SURF_DOWN_CLR) THEN DIAG3A.341
IF (L_NET) THEN DIAG3A.342
IF (ISOLIR.EQ.IP_SOLAR) THEN DIAG3A.343
DO L=1, N_PROFILE DIAG3A.344
SURF_DOWN_CLR(L)=SURF_DOWN_CLR(L) DIAG3A.345
& +(FLUX_DOWN_CLEAR(L)+FLUX_DIRECT_CLEAR(L) DIAG3A.346
& *(ALBEDO_FIELD_DIR(L)-ALBEDO_FIELD_DIFF(L))) DIAG3A.347
& /(1.0E+00-ALBEDO_FIELD_DIFF(L)) DIAG3A.348
ENDDO DIAG3A.349
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN DIAG3A.350
DO L=1, N_PROFILE DIAG3A.351
SURF_DOWN_CLR(L)=SURF_DOWN_CLR(L) DIAG3A.352
& +(FLUX_DOWN_CLEAR(L)+THERMAL_SOURCE_GROUND(L)) DIAG3A.353
& /(1.0E+00-ALBEDO_FIELD_DIFF(L)) DIAG3A.354
ENDDO DIAG3A.355
ENDIF DIAG3A.356
ELSE DIAG3A.357
IF (ISOLIR.EQ.IP_SOLAR) THEN ADB1F401.170
DO L=1, N_PROFILE ADB1F401.171
SURF_DOWN_CLR(L)=SURF_DOWN_CLR(L) ADB1F401.172
& +FLUX_DOWN_CLEAR(L) ADB1F401.173
ENDDO ADB1F401.174
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN ADB1F401.175
DO L=1, N_PROFILE ADB1F401.176
SURF_DOWN_CLR(L)=SURF_DOWN_CLR(L) ADB1F401.177
& +FLUX_DOWN_CLEAR(L)+PLANCK_AIR_SURFACE(L) ADB1F401.178
ENDDO ADB1F401.179
ENDIF ADB1F401.180
ENDIF DIAG3A.365
ENDIF DIAG3A.366
! DIAG3A.367
IF (L_SURF_UP_CLR) THEN DIAG3A.368
IF (L_NET) THEN DIAG3A.369
IF (ISOLIR.EQ.IP_SOLAR) THEN DIAG3A.370
DO L=1, N_PROFILE DIAG3A.371
SURF_UP_CLR(L)=SURF_UP_CLR(L) DIAG3A.372
& +((ALBEDO_FIELD_DIR(L)-ALBEDO_FIELD_DIFF(L)) DIAG3A.373
& *FLUX_DIRECT_CLEAR(L) DIAG3A.374
& +ALBEDO_FIELD_DIFF(L)*FLUX_DOWN_CLEAR(L)) DIAG3A.375
& /(1.0E+00-ALBEDO_FIELD_DIFF(L)) DIAG3A.376
ENDDO DIAG3A.377
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN DIAG3A.378
DO L=1, N_PROFILE DIAG3A.379
SURF_UP_CLR(L)=SURF_UP_CLR(L) DIAG3A.380
& +(THERMAL_SOURCE_GROUND(L)+ALBEDO_FIELD_DIFF(L) DIAG3A.381
& *FLUX_DOWN_CLEAR(L))/(1.0E+00-ALBEDO_FIELD_DIFF(L)) DIAG3A.382
ENDDO DIAG3A.383
ENDIF DIAG3A.384
ELSE DIAG3A.385
IF (ISOLIR.EQ.IP_SOLAR) THEN ADB1F401.181
DO L=1, N_PROFILE ADB1F401.182
SURF_UP_CLR(L)=SURF_UP_CLR(L) ADB1F401.183
& +FLUX_UP_CLEAR(L) ADB1F401.184
ENDDO ADB1F401.185
ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN ADB1F401.186
DO L=1, N_PROFILE ADB1F401.187
SURF_UP_CLR(L)=SURF_UP_CLR(L) ADB1F401.188
& +FLUX_UP_CLEAR(L)+PLANCK_AIR_SURFACE(L) ADB1F401.189
ENDDO ADB1F401.190
ENDIF ADB1F401.191
ENDIF DIAG3A.393
ENDIF DIAG3A.394
! DIAG3A.395
! THIS DIAGNOSTIC IS AVAILABLE ONLY IN THE SOLAR REGION. DIAG3A.396
IF (L_FLUX_BELOW_690NM_SURF) THEN DIAG3A.397
IF (ISOLIR.EQ.IP_SOLAR) THEN DIAG3A.398
IF (L_NET) THEN DIAG3A.399
DO L=1, N_PROFILE DIAG3A.400
FLUX_BELOW_690NM_SURF(L)=FLUX_BELOW_690NM_SURF(L) DIAG3A.401
& +WEIGHT_690NM*FLUX_DOWN(L) ADB1F401.192
ENDDO DIAG3A.406
ELSE DIAG3A.407
DO L=1, N_PROFILE DIAG3A.408
FLUX_BELOW_690NM_SURF(L)=FLUX_BELOW_690NM_SURF(L) DIAG3A.409
& +WEIGHT_690NM*(FLUX_DOWN(L)-FLUX_UP(L)) ADB1F401.193
ENDDO DIAG3A.411
ENDIF DIAG3A.412
ENDIF DIAG3A.413
ENDIF DIAG3A.414
! DIAG3A.415
! DIAG3A.416
! DIAG3A.417
RETURN DIAG3A.418
END DIAG3A.419
*ENDIF DEF,A01_3A,OR,DEF,A02_3A DIAG3A.420
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.20