*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.3
*IF DEF,A01_3A,OR,DEF,A02_3A AGTFX3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13076
C GTS2F400.13077
C Use, duplication or disclosure of this code is subject to the GTS2F400.13078
C restrictions as set forth in the contract. GTS2F400.13079
C GTS2F400.13080
C Meteorological Office GTS2F400.13081
C London Road GTS2F400.13082
C BRACKNELL GTS2F400.13083
C Berkshire UK GTS2F400.13084
C RG12 2SZ GTS2F400.13085
C GTS2F400.13086
C If no contract has been raised with this copy of the code, the use, GTS2F400.13087
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13088
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13089
C Modelling at the above address. GTS2F400.13090
C ******************************COPYRIGHT****************************** GTS2F400.13091
C GTS2F400.13092
!+ Subroutine to increment the total flux within a spectral band. AGTFX3A.3
! AGTFX3A.4
! Method: AGTFX3A.5
! The total flux is incremented by a multiple of the flux AGTFX3A.6
! flux within a spectral band. This routine is similar to AGTFX3A.7
! AUGMENT_FLUX, but here the Planckian flux must be AGTFX3A.8
! incremented in the IR. AGTFX3A.9
! AGTFX3A.10
! Current Owner of Code: J. M. Edwards AGTFX3A.11
! AGTFX3A.12
! History: AGTFX3A.13
! Version Date Comment AGTFX3A.14
! 4.0 27-07-95 Original Code AGTFX3A.15
! (J. M. Edwards) AGTFX3A.16
! AGTFX3A.17
! Description of Code: AGTFX3A.18
! FORTRAN 77 with extensions listed in documentation. AGTFX3A.19
! AGTFX3A.20
!- --------------------------------------------------------------------- AGTFX3A.21
SUBROUTINE AUGMENT_TOTAL_FLUX(N_PROFILE, N_LAYER, N_AUGMENT 1AGTFX3A.22
& , ISOLIR, L_CLEAR, L_NET AGTFX3A.23
& , WEIGHT_BAND, PLANCK_SOURCE_BAND AGTFX3A.24
& , FLUX_DIRECT, FLUX_TOTAL AGTFX3A.25
& , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND AGTFX3A.26
& , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR AGTFX3A.27
& , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND AGTFX3A.28
& , PLANCK_FLUX AGTFX3A.29
& , NPD_PROFILE, NPD_LAYER AGTFX3A.30
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR AGTFX3A.31
& ) AGTFX3A.32
! AGTFX3A.33
! AGTFX3A.34
IMPLICIT NONE AGTFX3A.35
! AGTFX3A.36
! AGTFX3A.37
! SIZES OF DUMMY ARRAYS. AGTFX3A.38
INTEGER !, INTENT(IN) AGTFX3A.39
& NPD_PROFILE AGTFX3A.40
! MAXIMUM NUMBER OF PROFILES AGTFX3A.41
& , NPD_LAYER AGTFX3A.42
! MAXIMUM NUMBER OF LAYERS AGTFX3A.43
! AGTFX3A.44
! INCLUDE COMDECKS AGTFX3A.45
*CALL SPCRG3A 
AGTFX3A.46
! AGTFX3A.47
! DUMMY ARGUMENTS. AGTFX3A.48
INTEGER !, INTENT(IN) AGTFX3A.49
& N_PROFILE AGTFX3A.50
! NUMBER OF PROFILES AGTFX3A.51
& , N_LAYER AGTFX3A.52
! NUMBER OF LAYERS AGTFX3A.53
& , N_AUGMENT AGTFX3A.54
! LENGTH OF VECTOR TO AUGMENT AGTFX3A.55
& , ISOLIR AGTFX3A.56
! SPECTRAL REGION AGTFX3A.57
LOGICAL !, INTENT(IN) AGTFX3A.58
& L_CLEAR AGTFX3A.59
! CLEAR FLUXES CALCULATED AGTFX3A.60
& , L_NET AGTFX3A.61
! CALCULATE NET FLUXES AGTFX3A.62
REAL !, INTENT(IN) AGTFX3A.63
& WEIGHT_BAND AGTFX3A.64
! WEIGHTING FACTOR FOR BAND AGTFX3A.65
& , PLANCK_SOURCE_BAND(NPD_PROFILE, 0: NPD_LAYER) AGTFX3A.66
! PLANCK FUNCTION IN BAND AGTFX3A.67
& , FLUX_DIRECT_BAND(NPD_PROFILE, 0: NPD_LAYER) AGTFX3A.68
! DIRECT FLUX IN BAND AGTFX3A.69
& , FLUX_TOTAL_BAND(NPD_PROFILE, 2*NPD_LAYER+2) AGTFX3A.70
! TOTAL FLUX IN BAND AGTFX3A.71
& , FLUX_DIRECT_CLEAR_BAND(NPD_PROFILE, 0: NPD_LAYER) AGTFX3A.72
! CLEAR DIRECT FLUX IN BAND AGTFX3A.73
& , FLUX_TOTAL_CLEAR_BAND(NPD_PROFILE, 2*NPD_LAYER+2) AGTFX3A.74
! CLEAR TOTAL FLUX IN BAND AGTFX3A.75
REAL !, INTENT(INOUT) AGTFX3A.76
& FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER) AGTFX3A.77
! DIRECT FLUX AGTFX3A.78
& , FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2) AGTFX3A.79
! TOTAL FLUX AGTFX3A.80
& , FLUX_DIRECT_CLEAR(NPD_PROFILE, 0: NPD_LAYER) AGTFX3A.81
! CLEAR DIRECT FLUX AGTFX3A.82
& , FLUX_TOTAL_CLEAR(NPD_PROFILE, 2*NPD_LAYER+2) AGTFX3A.83
! CLEAR TOTAL FLUX AGTFX3A.84
& , PLANCK_FLUX(NPD_PROFILE, 0: NPD_LAYER) AGTFX3A.85
! PLANCKIAN FLUX AT EACH LAYER AGTFX3A.86
! VARIABLES SPECIFIC TO THE UM. AGTFX3A.87
REAL !, INTENT(IN) AGTFX3A.88
& ALBEDO_SURFACE_DIFF(NPD_PROFILE) AGTFX3A.89
! DIFFUSE ALBEDO AGTFX3A.90
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) AGTFX3A.91
! DIRECT ALBEDO AGTFX3A.92
! AGTFX3A.93
! LOCAL ARGUMENTS. AGTFX3A.94
INTEGER AGTFX3A.95
& I AGTFX3A.96
! LOOP VARIABLE AGTFX3A.97
& , L AGTFX3A.98
! LOOP VARIABLE AGTFX3A.99
! AGTFX3A.100
! AGTFX3A.101
! INCREMENT THE TOTAL FLUXES. AGTFX3A.102
IF (ISOLIR.EQ.IP_SOLAR) THEN AGTFX3A.103
DO I=0, N_LAYER AGTFX3A.104
DO L=1, N_PROFILE AGTFX3A.105
FLUX_DIRECT(L, I)=FLUX_DIRECT(L, I) AGTFX3A.106
& +WEIGHT_BAND*FLUX_DIRECT_BAND(L, I) AGTFX3A.107
ENDDO AGTFX3A.108
ENDDO AGTFX3A.109
ENDIF AGTFX3A.110
DO I=1, N_AUGMENT AGTFX3A.111
DO L=1, N_PROFILE AGTFX3A.112
FLUX_TOTAL(L, I)=FLUX_TOTAL(L, I) AGTFX3A.113
& +WEIGHT_BAND*FLUX_TOTAL_BAND(L, I) AGTFX3A.114
ENDDO AGTFX3A.115
ENDDO AGTFX3A.116
! AGTFX3A.117
IF (L_CLEAR) THEN AGTFX3A.118
IF (ISOLIR.EQ.IP_SOLAR) THEN AGTFX3A.119
DO I=0, N_LAYER AGTFX3A.120
DO L=1, N_PROFILE AGTFX3A.121
FLUX_DIRECT_CLEAR(L, I)=FLUX_DIRECT_CLEAR(L, I) AGTFX3A.122
& +WEIGHT_BAND*FLUX_DIRECT_CLEAR_BAND(L, I) AGTFX3A.123
ENDDO AGTFX3A.124
ENDDO AGTFX3A.125
ENDIF AGTFX3A.126
DO I=1, N_AUGMENT AGTFX3A.127
DO L=1, N_PROFILE AGTFX3A.128
FLUX_TOTAL_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, I) AGTFX3A.129
& +WEIGHT_BAND*FLUX_TOTAL_CLEAR_BAND(L, I) AGTFX3A.130
ENDDO AGTFX3A.131
ENDDO AGTFX3A.132
! BOTH UPWARD AND DOWNWARD FLUXES ARE NEEDED AT THE SURFACE AGTFX3A.133
! FOR DIAGNOSTICS. IF THE NET FLUX IS CALCULATED WE DETERMINE AGTFX3A.134
! THE DIFFUSE UPWARD FLUX AND PUT IT WHERE IT BELONGS IN THE AGTFX3A.135
! ARRAY. IF THE FULL FLUXES ARE CALCULATED NO ACTION IS NEEDED. AGTFX3A.136
IF (L_NET) THEN AGTFX3A.137
DO L=1, N_PROFILE AGTFX3A.138
FLUX_TOTAL_CLEAR(L, 2*N_LAYER+2) AGTFX3A.139
& =(ALBEDO_SURFACE_DIFF(L) AGTFX3A.140
& *FLUX_TOTAL_CLEAR_BAND(L, N_LAYER+1) AGTFX3A.141
& +ALBEDO_SURFACE_DIR(L) AGTFX3A.142
& *FLUX_DIRECT_CLEAR_BAND(L, N_LAYER)) AGTFX3A.143
& /(1.0E+00-ALBEDO_SURFACE_DIFF(L)) AGTFX3A.144
ENDDO AGTFX3A.145
ENDIF AGTFX3A.146
ENDIF AGTFX3A.147
! AGTFX3A.148
! SUM THE PLANCKIAN FLUXES FOR LATER ADDITION TO THE DIFFERENTIAL AGTFX3A.149
! FLUXES. THIS IS NOT NECESSARY FOR A NET-FLUX SCHEME AGTFX3A.150
IF ( (ISOLIR.EQ.IP_INFRA_RED).AND.(.NOT.L_NET) ) THEN AGTFX3A.151
DO I=0, N_LAYER AGTFX3A.152
DO L=1, N_PROFILE AGTFX3A.153
PLANCK_FLUX(L, I)=PLANCK_FLUX(L, I) AGTFX3A.154
& +WEIGHT_BAND*PLANCK_SOURCE_BAND(L, I) AGTFX3A.155
ENDDO AGTFX3A.156
ENDDO AGTFX3A.157
ENDIF AGTFX3A.158
! AGTFX3A.159
! AGTFX3A.160
RETURN AGTFX3A.161
END AGTFX3A.162
*ENDIF DEF,A01_3A,OR,DEF,A02_3A AGTFX3A.163
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.4