C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.9232  
C                                                                                  RAD_ALL.9233  
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.9234  
C restrictions as set forth in the contract.                                       RAD_ALL.9235  
C                                                                                  RAD_ALL.9236  
C                Meteorological Office                                             RAD_ALL.9237  
C                London Road                                                       RAD_ALL.9238  
C                BRACKNELL                                                         RAD_ALL.9239  
C                Berkshire UK                                                      RAD_ALL.9240  
C                RG12 2SZ                                                          RAD_ALL.9241  
C                                                                                  RAD_ALL.9242  
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.9243  
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.9244  
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.9245  
C Modelling at the above address.                                                  RAD_ALL.9246  
C ******************************COPYRIGHT******************************            RAD_ALL.9247  
C                                                                                  RAD_ALL.9248  
!+ Subroutine to calculate fluxes including only gaseous absorption.               RAD_ALL.9249  
!                                                                                  RAD_ALL.9250  
! Method:                                                                          RAD_ALL.9251  
!       Transmission coefficients for each layer are calculated                    RAD_ALL.9252  
!       from the gaseous absorption alone. Fluxes are propagated                   RAD_ALL.9253  
!       upward or downward through the column using these                          RAD_ALL.9254  
!       coefficients and source terms.                                             RAD_ALL.9255  
!                                                                                  RAD_ALL.9256  
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.9257  
!                                                                                  RAD_ALL.9258  
! History:                                                                         RAD_ALL.9259  
!       Version         Date                    Comment                            RAD_ALL.9260  
!       4.0             27-07-95                Original Code                      RAD_ALL.9261  
!                                               (J. M. Edwards)                    RAD_ALL.9262  
!       4.1             29-03-96                Half-precision                     RAD_ALL.9263  
!                                               exponentials introduced.           RAD_ALL.9264  
!                                               (J. M. Edwards)                    RAD_ALL.9265  
!       4.2             Oct. 96     T3E migration: HF functions                    RAD_ALL.9266  
!                                   replaced by T3E vec_lib function               RAD_ALL.9267  
!                                               (S.J.Swarbrick)                    RAD_ALL.9268  
!                                                                                  RAD_ALL.9269  
! Description of Code:                                                             RAD_ALL.9270  
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.9271  
!                                                                                  RAD_ALL.9272  
!- ---------------------------------------------------------------------           RAD_ALL.9273  
      SUBROUTINE MONOCHROMATIC_GAS_FLUX(N_PROFILE, N_LAYER                         RAD_ALL.9274  
     &   , L_NET                                                                   RAD_ALL.9275  
     &   , TAU_GAS                                                                 RAD_ALL.9276  
     &   , ISOLIR, SEC_0, FLUX_INC_DIRECT, FLUX_INC_DOWN                           RAD_ALL.9277  
     &   , DIFF_PLANCK, SOURCE_GROUND                                              RAD_ALL.9278  
     &   , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR                                 RAD_ALL.9279  
     &   , DIFFUSIVITY_FACTOR                                                      RAD_ALL.9280  
     &   , FLUX_DIRECT, FLUX_DIFFUSE                                               RAD_ALL.9281  
     &   , NPD_PROFILE, NPD_LAYER                                                  RAD_ALL.9282  
     &         )                                                                   RAD_ALL.9283  
!                                                                                  RAD_ALL.9284  
!                                                                                  RAD_ALL.9285  
      IMPLICIT NONE                                                                RAD_ALL.9286  
!                                                                                  RAD_ALL.9287  
!                                                                                  RAD_ALL.9288  
!     SIZES OF DUMMY ARRAYS.                                                       RAD_ALL.9289  
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.9290  
     &     NPD_PROFILE                                                             RAD_ALL.9291  
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.9292  
     &   , NPD_LAYER                                                               RAD_ALL.9293  
!             MAXIMUM NUMBER OF LAYERS                                             RAD_ALL.9294  
!                                                                                  RAD_ALL.9295  
!     INCLUDE COMDECKS                                                             RAD_ALL.9296  
!     ------------------------------------------------------------------           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    
!     ------------------------------------------------------------------           PRMCH3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       PRMCH3A.3     
!                                                                                  PRMCH3A.4     
!     MODULE FOR SETTING MACHINE PRECISION.                                        PRMCH3A.5     
!                                                                                  PRMCH3A.6     
      REAL                                                                         PRMCH3A.7     
     &     TOL_MACHINE                                                             PRMCH3A.8     
!             MACHINE TOLERANCE                                                    PRMCH3A.9     
     &   , SQRT_TOL_MACHINE                                                        PRMCH3A.10    
!             SQRT OF MACHINE TOLERANCE                                            PRMCH3A.11    
!                                                                                  PRMCH3A.12    
!                                                                                  PRMCH3A.13    
!     THE PRECISION SHOULD BE ABOUT 2/2^(SIZE OF SIGNIFICAND)                      PRMCH3A.14    
!                                                                                  PRMCH3A.15    
!     THE IEEE-FORMAT USES 53 BITS FOR THE SIGNIFICAND                             PRMCH3A.16    
!     IN DOUBLE PRECISION                                                          PRMCH3A.17    
!                                                                                  PRMCH3A.18    
!     THE CRAY FORMAT USES 47 BITS IN SINGLE PRECISION.                            PRMCH3A.19    
!                                                                                  PRMCH3A.20    
      PARAMETER(                                                                   PRMCH3A.21    
     &     TOL_MACHINE=1.42E-14                                                    PRMCH3A.22    
     &   , SQRT_TOL_MACHINE=1.19E-7                                                PRMCH3A.23    
     &   )                                                                         PRMCH3A.24    
!                                                                                  PRMCH3A.25    
!     ------------------------------------------------------------------           PRMCH3A.26    
!                                                                                  RAD_ALL.9299  
!     DUMMY ARGUMENTS.                                                             RAD_ALL.9300  
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.9301  
     &     N_PROFILE                                                               RAD_ALL.9302  
!             NUMBER OF PROFILES                                                   RAD_ALL.9303  
     &   , N_LAYER                                                                 RAD_ALL.9304  
!             NUMBER OF LAYERS                                                     RAD_ALL.9305  
     &   , ISOLIR                                                                  RAD_ALL.9306  
!             SPECTRAL REGION                                                      RAD_ALL.9307  
      LOGICAL   !, INTENT(IN)                                                      RAD_ALL.9308  
     &     L_NET                                                                   RAD_ALL.9309  
!             CALCULATE NET FLUXES.                                                RAD_ALL.9310  
      REAL      !, INTENT(IN)                                                      RAD_ALL.9311  
     &     TAU_GAS(NPD_PROFILE, NPD_LAYER)                                         RAD_ALL.9312  
!             GASEOUS OPTICAL DEPTHS                                               RAD_ALL.9313  
     &   , SEC_0(NPD_PROFILE)                                                      RAD_ALL.9314  
!             SECANT OF ZENITH ANGLE                                               RAD_ALL.9315  
     &   , FLUX_INC_DIRECT(NPD_PROFILE)                                            RAD_ALL.9316  
!             INCIDENT DIRECT FLUX                                                 RAD_ALL.9317  
     &   , FLUX_INC_DOWN(NPD_PROFILE)                                              RAD_ALL.9318  
!             INCIDENT DIFFUSE FLUX                                                RAD_ALL.9319  
     &   , SOURCE_GROUND(NPD_PROFILE)                                              RAD_ALL.9320  
!             SOURCE FUNCTION OF GROUND                                            RAD_ALL.9321  
     &   , DIFF_PLANCK(NPD_PROFILE, NPD_LAYER)                                     RAD_ALL.9322  
!             DIFFERENCE IN PLANCK FUNCTION                                        RAD_ALL.9323  
     &   , ALBEDO_SURFACE_DIFF(NPD_PROFILE)                                        RAD_ALL.9324  
!             DIFFUSE SURFACE ALBEDO                                               RAD_ALL.9325  
     &   , ALBEDO_SURFACE_DIR(NPD_PROFILE)                                         RAD_ALL.9326  
!             DIRECT SURFACE ALBEDO                                                RAD_ALL.9327  
     &   , DIFFUSIVITY_FACTOR                                                      RAD_ALL.9328  
!             DIFFUSIVITY FACTOR                                                   RAD_ALL.9329  
      REAL      !, INTENT(OUT)                                                     RAD_ALL.9330  
     &     FLUX_DIRECT(NPD_PROFILE, 0: NPD_LAYER)                                  RAD_ALL.9331  
!             DIRECT FLUX                                                          RAD_ALL.9332  
     &   , FLUX_DIFFUSE(NPD_PROFILE, 2*NPD_LAYER+2)                                RAD_ALL.9333  
!             DIFFUSE FLUX                                                         RAD_ALL.9334  
!                                                                                  RAD_ALL.9335  
!     LOCAL VARIABLES.                                                             RAD_ALL.9336  
      INTEGER                                                                      RAD_ALL.9337  
     &     I                                                                       RAD_ALL.9338  
!             LOOP VARIABLE                                                        RAD_ALL.9339  
     &   , L                                                                       RAD_ALL.9340  
!             LOOP VARIABLE                                                        RAD_ALL.9341  
      REAL                                                                         RAD_ALL.9342  
     &     TRANS(N_PROFILE, N_LAYER)                                               RAD_ALL.9343  
!             TRANSMISSIVITIES                                                     RAD_ALL.9344  
      REAL                                                                         RAD_ALL.9345  
     &     SOURCE_UP(NPD_PROFILE, NPD_LAYER)                                       RAD_ALL.9346  
!             UPWARD SOURCE FUNCTION                                               RAD_ALL.9347  
     &   , SOURCE_DOWN(NPD_PROFILE, NPD_LAYER)                                     RAD_ALL.9348  
!             DOWNWARD SOURCE FUNCTION                                             RAD_ALL.9349  
!                                                                                  RAD_ALL.9350  
!                                                                                  RAD_ALL.9351  
!                                                                                  RAD_ALL.9352  
!                                                                                  RAD_ALL.9353  
      DO I=1, N_LAYER                                                              RAD_ALL.9362  
         DO L=1, N_PROFILE                                                         RAD_ALL.9363  
            TRANS(L, I)=EXP(-DIFFUSIVITY_FACTOR*TAU_GAS(L, I))                     RAD_ALL.9364  
         ENDDO                                                                     RAD_ALL.9365  
      ENDDO                                                                        RAD_ALL.9366  
!                                                                                  RAD_ALL.9368  
      IF (ISOLIR.EQ.IP_SOLAR) THEN                                                 RAD_ALL.9369  
         DO I=1, N_LAYER                                                           RAD_ALL.9370  
            DO L=1, N_PROFILE                                                      RAD_ALL.9371  
               SOURCE_UP(L, I)=0.0E+00                                             RAD_ALL.9372  
               SOURCE_DOWN(L, I)=0.0E+00                                           RAD_ALL.9373  
            ENDDO                                                                  RAD_ALL.9374  
         ENDDO                                                                     RAD_ALL.9375  
      ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN                                        RAD_ALL.9376  
         DO I=1, N_LAYER                                                           RAD_ALL.9377  
            DO L=1, N_PROFILE                                                      RAD_ALL.9378  
               SOURCE_UP(L, I)=(1.0E+00-TRANS(L, I)+SQRT_TOL_MACHINE)              RAD_ALL.9379  
     &            *DIFF_PLANCK(L, I)                                               RAD_ALL.9380  
     &            /(DIFFUSIVITY_FACTOR*TAU_GAS(L, I)+SQRT_TOL_MACHINE)             RAD_ALL.9381  
               SOURCE_DOWN(L, I)=-SOURCE_UP(L, I)                                  RAD_ALL.9382  
            ENDDO                                                                  RAD_ALL.9383  
         ENDDO                                                                     RAD_ALL.9384  
      ENDIF                                                                        RAD_ALL.9385  
!                                                                                  RAD_ALL.9386  
!     THE DIRECT FLUX.                                                             RAD_ALL.9387  
      IF (ISOLIR.EQ.IP_SOLAR) THEN                                                 RAD_ALL.9388  
         DO L=1, N_PROFILE                                                         RAD_ALL.9389  
            FLUX_DIRECT(L, 0)=FLUX_INC_DIRECT(L)                                   RAD_ALL.9390  
         ENDDO                                                                     RAD_ALL.9391  
         DO I=1, N_LAYER                                                           RAD_ALL.9392  
            DO L=1, N_PROFILE                                                      RAD_ALL.9393  
               FLUX_DIRECT(L, I)                                                   RAD_ALL.9394  
     &            =FLUX_DIRECT(L, I-1)*EXP(-TAU_GAS(L, I)*SEC_0(L))                RAD_ALL.9395  
            ENDDO                                                                  RAD_ALL.9396  
         ENDDO                                                                     RAD_ALL.9397  
      ENDIF                                                                        RAD_ALL.9398  
!                                                                                  RAD_ALL.9399  
!     DOWNWARD FLUXES.                                                             RAD_ALL.9400  
      DO L=1, N_PROFILE                                                            RAD_ALL.9401  
         FLUX_DIFFUSE(L, 2)=FLUX_INC_DOWN(L)                                       RAD_ALL.9402  
      ENDDO                                                                        RAD_ALL.9403  
      DO I=1, N_LAYER                                                              RAD_ALL.9404  
         DO L=1, N_PROFILE                                                         RAD_ALL.9405  
            FLUX_DIFFUSE(L, 2*I+2)=TRANS(L, I)*FLUX_DIFFUSE(L, 2*I)                RAD_ALL.9406  
     &         +SOURCE_DOWN(L, I)                                                  RAD_ALL.9407  
         ENDDO                                                                     RAD_ALL.9408  
      ENDDO                                                                        RAD_ALL.9409  
!                                                                                  RAD_ALL.9410  
!     UPWARD FLUXES.                                                               RAD_ALL.9411  
      IF (ISOLIR.EQ.IP_SOLAR) THEN                                                 RAD_ALL.9412  
         DO L=1, N_PROFILE                                                         RAD_ALL.9413  
            FLUX_DIFFUSE(L, 2*N_LAYER+1)=SOURCE_GROUND(L)                          RAD_ALL.9414  
     &         +ALBEDO_SURFACE_DIFF(L)*FLUX_DIFFUSE(L, 2*N_LAYER+2)                RAD_ALL.9415  
     &         +ALBEDO_SURFACE_DIR(L)*FLUX_DIRECT(L, N_LAYER)                      RAD_ALL.9416  
         ENDDO                                                                     RAD_ALL.9417  
      ELSE                                                                         RAD_ALL.9418  
         DO L=1, N_PROFILE                                                         RAD_ALL.9419  
            FLUX_DIFFUSE(L, 2*N_LAYER+1)=SOURCE_GROUND(L)                          RAD_ALL.9420  
     &         +ALBEDO_SURFACE_DIFF(L)*FLUX_DIFFUSE(L, 2*N_LAYER+2)                RAD_ALL.9421  
         ENDDO                                                                     RAD_ALL.9422  
      ENDIF                                                                        RAD_ALL.9423  
      DO I=N_LAYER, 1, -1                                                          RAD_ALL.9424  
         DO L=1, N_PROFILE                                                         RAD_ALL.9425  
            FLUX_DIFFUSE(L, 2*I-1)=TRANS(L, I)*FLUX_DIFFUSE(L, 2*I+1)              RAD_ALL.9426  
     &         +SOURCE_UP(L, I)                                                    RAD_ALL.9427  
         ENDDO                                                                     RAD_ALL.9428  
      ENDDO                                                                        RAD_ALL.9429  
!                                                                                  RAD_ALL.9430  
!     REDUCE TO THE NET FLUX IF THIS IS REQUIRED.                                  RAD_ALL.9431  
      IF (L_NET) THEN                                                              RAD_ALL.9432  
         DO I=0, N_LAYER                                                           RAD_ALL.9433  
            DO L=1, N_PROFILE                                                      RAD_ALL.9434  
               FLUX_DIFFUSE(L, I+1)=FLUX_DIFFUSE(L, 2*I+2)                         RAD_ALL.9435  
     &            -FLUX_DIFFUSE(L, 2*I+1)                                          RAD_ALL.9436  
            ENDDO                                                                  RAD_ALL.9437  
         ENDDO                                                                     RAD_ALL.9438  
      ENDIF                                                                        RAD_ALL.9439  
!                                                                                  RAD_ALL.9440  
!                                                                                  RAD_ALL.9441  
      RETURN                                                                       RAD_ALL.9442  
      END    
