C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.318   
C                                                                                  RAD_ALL.319   
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.320   
C restrictions as set forth in the contract.                                       RAD_ALL.321   
C                                                                                  RAD_ALL.322   
C                Meteorological Office                                             RAD_ALL.323   
C                London Road                                                       RAD_ALL.324   
C                BRACKNELL                                                         RAD_ALL.325   
C                Berkshire UK                                                      RAD_ALL.326   
C                RG12 2SZ                                                          RAD_ALL.327   
C                                                                                  RAD_ALL.328   
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.329   
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.330   
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.331   
C Modelling at the above address.                                                  RAD_ALL.332   
C ******************************COPYRIGHT******************************            RAD_ALL.333   
C                                                                                  RAD_ALL.334   
!+ Subroutine to increment the total flux within a spectral band.                  RAD_ALL.335   
!                                                                                  RAD_ALL.336   
! Method:                                                                          RAD_ALL.337   
!       The total flux is incremented by a multiple of the flux                    RAD_ALL.338   
!       flux within a spectral band. This routine is similar to                    RAD_ALL.339   
!       AUGMENT_FLUX, but here the Planckian flux must be                          RAD_ALL.340   
!       incremented in the IR.                                                     RAD_ALL.341   
!                                                                                  RAD_ALL.342   
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.343   
!                                                                                  RAD_ALL.344   
! History:                                                                         RAD_ALL.345   
!       Version         Date                    Comment                            RAD_ALL.346   
!       4.0             27-07-95                Original Code                      RAD_ALL.347   
!                                               (J. M. Edwards)                    RAD_ALL.348   
!                                                                                  RAD_ALL.349   
! Description of Code:                                                             RAD_ALL.350   
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.351   
!                                                                                  RAD_ALL.352   
!- ---------------------------------------------------------------------           RAD_ALL.353   
      SUBROUTINE AUGMENT_TOTAL_FLUX(N_PROFILE, N_LAYER, N_AUGMENT                  RAD_ALL.354   
     &   , ISOLIR, L_CLEAR, L_NET                                                  RAD_ALL.355   
     &   , WEIGHT_BAND, PLANCK_SOURCE_BAND                                         RAD_ALL.356   
     &   , FLUX_DIRECT, FLUX_TOTAL                                                 RAD_ALL.357   
     &   , FLUX_DIRECT_BAND, FLUX_TOTAL_BAND                                       RAD_ALL.358   
     &   , FLUX_DIRECT_CLEAR, FLUX_TOTAL_CLEAR                                     RAD_ALL.359   
     &   , FLUX_DIRECT_CLEAR_BAND, FLUX_TOTAL_CLEAR_BAND                           RAD_ALL.360   
     &   , PLANCK_FLUX                                                             RAD_ALL.361   
     &   , NPD_PROFILE, NPD_LAYER                                                  RAD_ALL.362   
     &   , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR                                 RAD_ALL.363   
     &   )                                                                         RAD_ALL.364   
!                                                                                  RAD_ALL.365   
!                                                                                  RAD_ALL.366   
      IMPLICIT NONE                                                                RAD_ALL.367   
!                                                                                  RAD_ALL.368   
!                                                                                  RAD_ALL.369   
!     SIZES OF DUMMY ARRAYS.                                                       RAD_ALL.370   
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.371   
     &     NPD_PROFILE                                                             RAD_ALL.372   
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.373   
     &   , NPD_LAYER                                                               RAD_ALL.374   
!             MAXIMUM NUMBER OF LAYERS                                             RAD_ALL.375   
!                                                                                  RAD_ALL.376   
!     INCLUDE COMDECKS                                                             RAD_ALL.377   
!     ------------------------------------------------------------------           SPCRG3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       SPCRG3A.3     
!                                                                                  SPCRG3A.4     
!     MODULE TO SET FLAGS FOR DIFFERENT PORTIONS                                   SPCRG3A.5     
!     OF THE SPECTRUM.                                                             SPCRG3A.6     
!                                                                                  SPCRG3A.7     
      INTEGER                                                                      SPCRG3A.8     
     &     IP_SOLAR                                                                SPCRG3A.9     
!             SOLAR REGION                                                         SPCRG3A.10    
     &   , IP_INFRA_RED                                                            SPCRG3A.11    
!             INFRA-RED REGION                                                     SPCRG3A.12    
!                                                                                  SPCRG3A.13    
      PARAMETER(                                                                   SPCRG3A.14    
     &     IP_SOLAR=1                                                              SPCRG3A.15    
     &   , IP_INFRA_RED=2                                                          SPCRG3A.16    
     &   )                                                                         SPCRG3A.17    
!                                                                                  SPCRG3A.18    
!     ------------------------------------------------------------------           SPCRG3A.19    
!                                                                                  RAD_ALL.379   
!     DUMMY ARGUMENTS.                                                             RAD_ALL.380   
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.381   
     &     N_PROFILE                                                               RAD_ALL.382   
!             NUMBER OF PROFILES                                                   RAD_ALL.383   
     &   , N_LAYER                                                                 RAD_ALL.384   
!             NUMBER OF LAYERS                                                     RAD_ALL.385   
     &   , N_AUGMENT                                                               RAD_ALL.386   
!             LENGTH OF VECTOR TO AUGMENT                                          RAD_ALL.387   
     &   , ISOLIR                                                                  RAD_ALL.388   
!             SPECTRAL REGION                                                      RAD_ALL.389   
      LOGICAL   !, INTENT(IN)                                                      RAD_ALL.390   
     &     L_CLEAR                                                                 RAD_ALL.391   
!             CLEAR FLUXES CALCULATED                                              RAD_ALL.392   
     &   , L_NET                                                                   RAD_ALL.393   
!             CALCULATE NET FLUXES                                                 RAD_ALL.394   
      REAL  !, INTENT(IN)                                                          RAD_ALL.395   
     &     WEIGHT_BAND                                                             RAD_ALL.396   
!             WEIGHTING FACTOR FOR BAND                                            RAD_ALL.397   
     &   , PLANCK_SOURCE_BAND(NPD_PROFILE, 0: NPD_LAYER)                           RAD_ALL.398   
!             PLANCK FUNCTION IN BAND                                              RAD_ALL.399   
     &   , FLUX_DIRECT_BAND(NPD_PROFILE, 0: NPD_LAYER)                             RAD_ALL.400   
!             DIRECT FLUX IN BAND                                                  RAD_ALL.401   
     &   , FLUX_TOTAL_BAND(NPD_PROFILE, 2*NPD_LAYER+2)                             RAD_ALL.402   
!             TOTAL FLUX IN BAND                                                   RAD_ALL.403   
     &   , FLUX_DIRECT_CLEAR_BAND(NPD_PROFILE, 0: NPD_LAYER)                       RAD_ALL.404   
!             CLEAR DIRECT FLUX IN BAND                                            RAD_ALL.405   
     &   , FLUX_TOTAL_CLEAR_BAND(NPD_PROFILE, 2*NPD_LAYER+2)                       RAD_ALL.406   
!             CLEAR TOTAL FLUX IN BAND                                             RAD_ALL.407   
      REAL  !, INTENT(INOUT)                                                       RAD_ALL.408   
     &     FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER)                                  RAD_ALL.409   
!             DIRECT FLUX                                                          RAD_ALL.410   
     &   , FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2)                                  RAD_ALL.411   
!             TOTAL FLUX                                                           RAD_ALL.412   
     &   , FLUX_DIRECT_CLEAR(NPD_PROFILE, 0: NPD_LAYER)                            RAD_ALL.413   
!             CLEAR DIRECT FLUX                                                    RAD_ALL.414   
     &   , FLUX_TOTAL_CLEAR(NPD_PROFILE, 2*NPD_LAYER+2)                            RAD_ALL.415   
!             CLEAR TOTAL FLUX                                                     RAD_ALL.416   
     &   , PLANCK_FLUX(NPD_PROFILE, 0: NPD_LAYER)                                  RAD_ALL.417   
!             PLANCKIAN FLUX AT EACH LAYER                                         RAD_ALL.418   
!     VARIABLES SPECIFIC TO THE UM.                                                RAD_ALL.419   
      REAL      !, INTENT(IN)                                                      RAD_ALL.420   
     &     ALBEDO_SURFACE_DIFF(NPD_PROFILE)                                        RAD_ALL.421   
!             DIFFUSE ALBEDO                                                       RAD_ALL.422   
     &   , ALBEDO_SURFACE_DIR(NPD_PROFILE)                                         RAD_ALL.423   
!             DIRECT ALBEDO                                                        RAD_ALL.424   
!                                                                                  RAD_ALL.425   
!     LOCAL ARGUMENTS.                                                             RAD_ALL.426   
      INTEGER                                                                      RAD_ALL.427   
     &     I                                                                       RAD_ALL.428   
!             LOOP VARIABLE                                                        RAD_ALL.429   
     &   , L                                                                       RAD_ALL.430   
!             LOOP VARIABLE                                                        RAD_ALL.431   
!                                                                                  RAD_ALL.432   
!                                                                                  RAD_ALL.433   
!     INCREMENT THE TOTAL FLUXES.                                                  RAD_ALL.434   
      IF (ISOLIR.EQ.IP_SOLAR) THEN                                                 RAD_ALL.435   
         DO I=0, N_LAYER                                                           RAD_ALL.436   
            DO L=1, N_PROFILE                                                      RAD_ALL.437   
               FLUX_DIRECT(L, I)=FLUX_DIRECT(L, I)                                 RAD_ALL.438   
     &            +WEIGHT_BAND*FLUX_DIRECT_BAND(L, I)                              RAD_ALL.439   
            ENDDO                                                                  RAD_ALL.440   
         ENDDO                                                                     RAD_ALL.441   
      ENDIF                                                                        RAD_ALL.442   
      DO I=1, N_AUGMENT                                                            RAD_ALL.443   
         DO L=1, N_PROFILE                                                         RAD_ALL.444   
            FLUX_TOTAL(L, I)=FLUX_TOTAL(L, I)                                      RAD_ALL.445   
     &         +WEIGHT_BAND*FLUX_TOTAL_BAND(L, I)                                  RAD_ALL.446   
         ENDDO                                                                     RAD_ALL.447   
      ENDDO                                                                        RAD_ALL.448   
!                                                                                  RAD_ALL.449   
      IF (L_CLEAR) THEN                                                            RAD_ALL.450   
         IF (ISOLIR.EQ.IP_SOLAR) THEN                                              RAD_ALL.451   
            DO I=0, N_LAYER                                                        RAD_ALL.452   
               DO L=1, N_PROFILE                                                   RAD_ALL.453   
                  FLUX_DIRECT_CLEAR(L, I)=FLUX_DIRECT_CLEAR(L, I)                  RAD_ALL.454   
     &               +WEIGHT_BAND*FLUX_DIRECT_CLEAR_BAND(L, I)                     RAD_ALL.455   
               ENDDO                                                               RAD_ALL.456   
            ENDDO                                                                  RAD_ALL.457   
         ENDIF                                                                     RAD_ALL.458   
         DO I=1, N_AUGMENT                                                         RAD_ALL.459   
            DO L=1, N_PROFILE                                                      RAD_ALL.460   
               FLUX_TOTAL_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, I)                       RAD_ALL.461   
     &            +WEIGHT_BAND*FLUX_TOTAL_CLEAR_BAND(L, I)                         RAD_ALL.462   
            ENDDO                                                                  RAD_ALL.463   
         ENDDO                                                                     RAD_ALL.464   
!        BOTH UPWARD AND DOWNWARD FLUXES ARE NEEDED AT THE SURFACE                 RAD_ALL.465   
!        FOR DIAGNOSTICS. IF THE NET FLUX IS CALCULATED WE DETERMINE               RAD_ALL.466   
!        THE DIFFUSE UPWARD FLUX AND PUT IT WHERE IT BELONGS IN THE                RAD_ALL.467   
!        ARRAY. IF THE FULL FLUXES ARE CALCULATED NO ACTION IS NEEDED.             RAD_ALL.468   
         IF (L_NET) THEN                                                           RAD_ALL.469   
            DO L=1, N_PROFILE                                                      RAD_ALL.470   
               FLUX_TOTAL_CLEAR(L, 2*N_LAYER+2)                                    RAD_ALL.471   
     &            =(ALBEDO_SURFACE_DIFF(L)                                         RAD_ALL.472   
     &            *FLUX_TOTAL_CLEAR_BAND(L, N_LAYER+1)                             RAD_ALL.473   
     &            +ALBEDO_SURFACE_DIR(L)                                           RAD_ALL.474   
     &            *FLUX_DIRECT_CLEAR_BAND(L, N_LAYER))                             RAD_ALL.475   
     &            /(1.0E+00-ALBEDO_SURFACE_DIFF(L))                                RAD_ALL.476   
            ENDDO                                                                  RAD_ALL.477   
         ENDIF                                                                     RAD_ALL.478   
      ENDIF                                                                        RAD_ALL.479   
!                                                                                  RAD_ALL.480   
!     SUM THE PLANCKIAN FLUXES FOR LATER ADDITION TO THE DIFFERENTIAL              RAD_ALL.481   
!     FLUXES. THIS IS NOT NECESSARY FOR A NET-FLUX SCHEME                          RAD_ALL.482   
      IF ( (ISOLIR.EQ.IP_INFRA_RED).AND.(.NOT.L_NET) ) THEN                        RAD_ALL.483   
         DO I=0, N_LAYER                                                           RAD_ALL.484   
            DO L=1, N_PROFILE                                                      RAD_ALL.485   
               PLANCK_FLUX(L, I)=PLANCK_FLUX(L, I)                                 RAD_ALL.486   
     &            +WEIGHT_BAND*PLANCK_SOURCE_BAND(L, I)                            RAD_ALL.487   
            ENDDO                                                                  RAD_ALL.488   
         ENDDO                                                                     RAD_ALL.489   
      ENDIF                                                                        RAD_ALL.490   
!                                                                                  RAD_ALL.491   
!                                                                                  RAD_ALL.492   
      RETURN                                                                       RAD_ALL.493   
      END 
