C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.8871  
C                                                                                  RAD_ALL.8872  
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.8873  
C restrictions as set forth in the contract.                                       RAD_ALL.8874  
C                                                                                  RAD_ALL.8875  
C                Meteorological Office                                             RAD_ALL.8876  
C                London Road                                                       RAD_ALL.8877  
C                BRACKNELL                                                         RAD_ALL.8878  
C                Berkshire UK                                                      RAD_ALL.8879  
C                RG12 2SZ                                                          RAD_ALL.8880  
C                                                                                  RAD_ALL.8881  
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.8882  
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.8883  
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.8884  
C Modelling at the above address.                                                  RAD_ALL.8885  
C ******************************COPYRIGHT******************************            RAD_ALL.8886  
C                                                                                  RAD_ALL.8887  
!+ Subroutine to calcaulate IR source function for differential flux.              RAD_ALL.8888  
!                                                                                  RAD_ALL.8889  
! Method:                                                                          RAD_ALL.8890  
!       The linear contribution to the source function is proportional             RAD_ALL.8891  
!       to the absorption divided by the optical depth. A tolerance is             RAD_ALL.8892  
!       added to the optical depth to allow for the depth's being 0.               RAD_ALL.8893  
!       Corrections may also be made for cwa quadratic variation in the            RAD_ALL.8894  
!       temperature across the layer and for the effects of edges.                 RAD_ALL.8895  
!                                                                                  RAD_ALL.8896  
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.8897  
!                                                                                  RAD_ALL.8898  
! History:                                                                         RAD_ALL.8899  
!       Version         Date                    Comment                            RAD_ALL.8900  
!       4.0             27-07-95                Original Code                      RAD_ALL.8901  
!                                               (J. M. Edwards)                    RAD_ALL.8902  
!                                                                                  RAD_ALL.8903  
! Description of Code:                                                             RAD_ALL.8904  
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.8905  
!                                                                                  RAD_ALL.8906  
!- ---------------------------------------------------------------------           RAD_ALL.8907  
      SUBROUTINE IR_SOURCE(N_PROFILE, I_LAYER_FIRST, I_LAYER_LAST                  RAD_ALL.8908  
     &   , SOURCE_COEFF, DEL_PLANCK, L_IR_SOURCE_QUAD, DIFF_PLANCK_2               RAD_ALL.8909  
     &   , L_2_STREAM_CORRECT, PLANCK_SOURCE                                       RAD_ALL.8910  
     &   , GROUND_EMISSION, N_LAYER                                                RAD_ALL.8911  
     &   , TAU, TRANS                                                              RAD_ALL.8912  
     &   , S_DOWN, S_UP                                                            RAD_ALL.8913  
     &   , NPD_PROFILE, NPD_LAYER                                                  RAD_ALL.8914  
     &   )                                                                         RAD_ALL.8915  
!                                                                                  RAD_ALL.8916  
!                                                                                  RAD_ALL.8917  
!                                                                                  RAD_ALL.8918  
      IMPLICIT NONE                                                                RAD_ALL.8919  
!                                                                                  RAD_ALL.8920  
!                                                                                  RAD_ALL.8921  
!     SIZES OF DUMMY ARRAYS.                                                       RAD_ALL.8922  
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.8923  
     &     NPD_PROFILE                                                             RAD_ALL.8924  
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.8925  
     &   , NPD_LAYER                                                               RAD_ALL.8926  
!             MAXIMUM NUMBER OF LAYERS                                             RAD_ALL.8927  
!                                                                                  RAD_ALL.8928  
!     INCLUDE COMDECKS.                                                            RAD_ALL.8929  
!     ------------------------------------------------------------------           DIMFIX3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       DIMFIX3A.3     
!                                                                                  DIMFIX3A.4     
!     MODULE TO SET INTERNAL DIMENSIONS TIED TO ALGORITHMS,                        DIMFIX3A.5     
!     MOSTLY FOR CLOUDS.                                                           DIMFIX3A.6     
!                                                                                  DIMFIX3A.7     
      INTEGER                                                                      DIMFIX3A.8     
     &     NPD_CLOUD_COMPONENT                                                     DIMFIX3A.9     
!             NUMBER OF COMPONENTS OF CLOUDS                                       DIMFIX3A.10    
     &   , NPD_CLOUD_TYPE                                                          DIMFIX3A.11    
!             NUMBER OF PERMITTED TYPES OF CLOUDS.                                 DIMFIX3A.12    
     &   , NPD_CLOUD_REPRESENTATION                                                DIMFIX3A.13    
!             NUMBER OF PERMITTED REPRESENTATIONS OF CLOUDS.                       DIMFIX3A.14    
     &   , NPD_OVERLAP_COEFF                                                       DIMFIX3A.15    
!             NUMBER OF OVERLAP COEFFICIENTS FOR CLOUDS                            DIMFIX3A.16    
     &   , NPD_SOURCE_COEFF                                                        DIMFIX3A.17    
!             NUMBER OF COEFFICIENTS FOR TWO-STREAM SOURCES                        DIMFIX3A.18    
     &   , NPD_REGION                                                              DIMFIX3A.19    
!             NUMBER OF REGIONS IN A LAYER                                         DIMFIX3A.20    
!                                                                                  DIMFIX3A.21    
      PARAMETER(                                                                   DIMFIX3A.22    
     &     NPD_CLOUD_COMPONENT=4                                                   DIMFIX3A.23    
     &   , NPD_CLOUD_TYPE=4                                                        DIMFIX3A.24    
     &   , NPD_CLOUD_REPRESENTATION=4                                              DIMFIX3A.25    
     &   , NPD_OVERLAP_COEFF=18                                                    DIMFIX3A.26    
     &   , NPD_SOURCE_COEFF=2                                                      DIMFIX3A.27    
     &   , NPD_REGION=3                                                            DIMFIX3A.28    
     &   )                                                                         DIMFIX3A.29    
!                                                                                  DIMFIX3A.30    
!     ------------------------------------------------------------------           DIMFIX3A.31    
!     ------------------------------------------------------------------           SCFPT3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       SCFPT3A.3     
!                                                                                  SCFPT3A.4     
!     MODULE TO SET POINTERS TO SOURCE COEFFICIENTS.                               SCFPT3A.5     
!                                                                                  SCFPT3A.6     
      INTEGER                                                                      SCFPT3A.7     
     &     IP_SCF_SOLAR_UP                                                         SCFPT3A.8     
!             POINTER TO SOURCE COEFICIENT FOR UPWARD SOLAR BEAM                   SCFPT3A.9     
     &   , IP_SCF_SOLAR_DOWN                                                       SCFPT3A.10    
!             POINTER TO SOURCE COEFICIENT FOR DOWNWARD SOLAR BEAM                 SCFPT3A.11    
     &   , IP_SCF_IR_1D                                                            SCFPT3A.12    
!             POINTER TO SOURCE COEFICIENT                                         SCFPT3A.13    
!             FOR 1ST DIFFERENCE OF PLANCKIAN                                      SCFPT3A.14    
     &   , IP_SCF_IR_2D                                                            SCFPT3A.15    
!             POINTER TO SOURCE COEFICIENT                                         SCFPT3A.16    
!             FOR 2ND DIFFERENCE OF PLANCKIAN                                      SCFPT3A.17    
!                                                                                  SCFPT3A.18    
      PARAMETER(                                                                   SCFPT3A.19    
     &     IP_SCF_SOLAR_UP=1                                                       SCFPT3A.20    
     &   , IP_SCF_SOLAR_DOWN=2                                                     SCFPT3A.21    
     &   , IP_SCF_IR_1D=1                                                          SCFPT3A.22    
     &   , IP_SCF_IR_2D=2                                                          SCFPT3A.23    
     &   )                                                                         SCFPT3A.24    
!                                                                                  SCFPT3A.25    
!     ------------------------------------------------------------------           SCFPT3A.26    
!                                                                                  RAD_ALL.8932  
!     DUMMY VARIABLES.                                                             RAD_ALL.8933  
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.8934  
     &     N_PROFILE                                                               RAD_ALL.8935  
!             NUMBER OF PROFILES                                                   RAD_ALL.8936  
     &   , I_LAYER_FIRST                                                           RAD_ALL.8937  
!             FIRST LAYER TO CONSIDER                                              RAD_ALL.8938  
     &   , I_LAYER_LAST                                                            RAD_ALL.8939  
!             LAST LAYER TO CONSIDER                                               RAD_ALL.8940  
     &   , N_LAYER                                                                 RAD_ALL.8941  
!             NUMBER OF LAYERS                                                     RAD_ALL.8942  
!                                                                                  RAD_ALL.8943  
      LOGICAL   !, INTENT(IN)                                                      RAD_ALL.8944  
     &     L_IR_SOURCE_QUAD                                                        RAD_ALL.8945  
!             USE A QUADRATIC REPRESENTATION                                       RAD_ALL.8946  
     &   , L_2_STREAM_CORRECT                                                      RAD_ALL.8947  
!             EDGE CORRECTION TO 2-STREAM                                          RAD_ALL.8948  
!                                                                                  RAD_ALL.8949  
      REAL      !, INTENT(IN)                                                      RAD_ALL.8950  
     &     SOURCE_COEFF(NPD_PROFILE, NPD_LAYER, NPD_SOURCE_COEFF)                  RAD_ALL.8951  
!             COEFFICIENTS FOR SOURCE TERMS                                        RAD_ALL.8952  
     &   , DEL_PLANCK(NPD_PROFILE, NPD_LAYER)                                      RAD_ALL.8953  
!             DIFFERENCE IN PLANCK FUNCTION ACROSS THE LAYER                       RAD_ALL.8954  
     &   , DIFF_PLANCK_2(NPD_PROFILE, NPD_LAYER)                                   RAD_ALL.8955  
!             2x2ND DIFFERENCE OF PLANCKIAN                                        RAD_ALL.8956  
     &   , TAU(NPD_PROFILE, NPD_LAYER)                                             RAD_ALL.8957  
!             OPTCIAL DEPTH                                                        RAD_ALL.8958  
     &   , TRANS(NPD_PROFILE, NPD_LAYER)                                           RAD_ALL.8959  
!             TRANSMISSION COEFFICIENT                                             RAD_ALL.8960  
     &   , PLANCK_SOURCE(NPD_PROFILE, 0: NPD_LAYER)                                RAD_ALL.8961  
!             PLANCKIAN SOURCE FUNCTION                                            RAD_ALL.8962  
     &   , GROUND_EMISSION(NPD_PROFILE)                                            RAD_ALL.8963  
!             TOTAL FLUX EMITTED FROM GROUND                                       RAD_ALL.8964  
!                                                                                  RAD_ALL.8965  
      REAL      !, INTENT(OUT)                                                     RAD_ALL.8966  
     &     S_DOWN(NPD_PROFILE, NPD_LAYER)                                          RAD_ALL.8967  
!             UPWARD SOURCE FUNCTION                                               RAD_ALL.8968  
     &   , S_UP(NPD_PROFILE, NPD_LAYER)                                            RAD_ALL.8969  
!             UPWARD SOURCE FUNCTION                                               RAD_ALL.8970  
!                                                                                  RAD_ALL.8971  
!                                                                                  RAD_ALL.8972  
!     LOCAL VARIABLES.                                                             RAD_ALL.8973  
!                                                                                  RAD_ALL.8974  
      INTEGER                                                                      RAD_ALL.8975  
     &     I                                                                       RAD_ALL.8976  
!             LOOP VARIABLE                                                        RAD_ALL.8977  
     &   , L                                                                       RAD_ALL.8978  
!             LOOP VARIABLE                                                        RAD_ALL.8979  
!                                                                                  RAD_ALL.8980  
      REAL                                                                         RAD_ALL.8981  
     &     TAUC(NPD_PROFILE, 0: NPD_LAYER)                                         RAD_ALL.8982  
!             CUMULATIVE OPTICAL DEPTH                                             RAD_ALL.8983  
     &   , PLANCK_AVE(NPD_PROFILE, 0: NPD_LAYER)                                   RAD_ALL.8984  
!             AVERAGE PLANCKIAN                                                    RAD_ALL.8985  
     &   , DELTA_TAU_UP_TOP                                                        RAD_ALL.8986  
!             OPTICAL DEPTH: SURF-TOP OF LAYER                                     RAD_ALL.8987  
     &   , DELTA_TAU_UP_BASE                                                       RAD_ALL.8988  
!             OPTICAL DEPTH: SURF-BASE OF LAYER                                    RAD_ALL.8989  
!                                                                                  RAD_ALL.8990  
!     FUNCTIONS CALLED:                                                            RAD_ALL.8991  
      REAL                                                                         RAD_ALL.8992  
     &     E3_ACC01                                                                RAD_ALL.8993  
!             THIRD EXPONENTIAL INTEGRAL TO 1%                                     RAD_ALL.8994  
      EXTERNAL                                                                     RAD_ALL.8995  
     &     E3_ACC01                                                                RAD_ALL.8996  
!                                                                                  RAD_ALL.8997  
!                                                                                  RAD_ALL.8998  
!                                                                                  RAD_ALL.8999  
!     MULTIPLY THE SOURCE COEFFICIENTS BY THE PLANCKIAN DIFFERENCES                RAD_ALL.9000  
!     TO THE ORDER REQUIRED.                                                       RAD_ALL.9001  
!                                                                                  RAD_ALL.9002  
      IF (L_IR_SOURCE_QUAD) THEN                                                   RAD_ALL.9003  
!                                                                                  RAD_ALL.9004  
         DO I=I_LAYER_FIRST, I_LAYER_LAST                                          RAD_ALL.9005  
            DO L=1, N_PROFILE                                                      RAD_ALL.9006  
               S_UP(L, I)=SOURCE_COEFF(L, I, IP_SCF_IR_1D)                         RAD_ALL.9007  
     &            *DEL_PLANCK(L, I)                                                RAD_ALL.9008  
     &            +SOURCE_COEFF(L, I, IP_SCF_IR_2D)                                RAD_ALL.9009  
     &            *DIFF_PLANCK_2(L, I)                                             RAD_ALL.9010  
               S_DOWN(L, I)=-SOURCE_COEFF(L, I, IP_SCF_IR_1D)                      RAD_ALL.9011  
     &            *DEL_PLANCK(L, I)                                                RAD_ALL.9012  
     &            +SOURCE_COEFF(L, I, IP_SCF_IR_2D)                                RAD_ALL.9013  
     &            *DIFF_PLANCK_2(L, I)                                             RAD_ALL.9014  
            ENDDO                                                                  RAD_ALL.9015  
!                                                                                  RAD_ALL.9016  
         ENDDO                                                                     RAD_ALL.9017  
!                                                                                  RAD_ALL.9018  
      ELSE                                                                         RAD_ALL.9019  
!                                                                                  RAD_ALL.9020  
         DO I=I_LAYER_FIRST, I_LAYER_LAST                                          RAD_ALL.9021  
            DO L=1, N_PROFILE                                                      RAD_ALL.9022  
               S_UP(L, I)=SOURCE_COEFF(L, I, IP_SCF_IR_1D)                         RAD_ALL.9023  
     &            *DEL_PLANCK(L, I)                                                RAD_ALL.9024  
               S_DOWN(L, I)=-S_UP(L, I)                                            RAD_ALL.9025  
            ENDDO                                                                  RAD_ALL.9026  
         ENDDO                                                                     RAD_ALL.9027  
!                                                                                  RAD_ALL.9028  
      ENDIF                                                                        RAD_ALL.9029  
!                                                                                  RAD_ALL.9030  
!                                                                                  RAD_ALL.9031  
!     EDGE CORRECTIONS TO 2-STREAM EQUATIONS.                                      RAD_ALL.9032  
!                                                                                  RAD_ALL.9033  
      IF (L_2_STREAM_CORRECT) THEN                                                 RAD_ALL.9034  
!                                                                                  RAD_ALL.9035  
         DO L=1, N_PROFILE                                                         RAD_ALL.9036  
            TAUC(L, 0)=0.0E+00                                                     RAD_ALL.9037  
         ENDDO                                                                     RAD_ALL.9038  
         DO I=1, N_LAYER                                                           RAD_ALL.9039  
            DO L=1, N_PROFILE                                                      RAD_ALL.9040  
               TAUC(L, I)=TAUC(L, I-1)+TAU(L, I)                                   RAD_ALL.9041  
               PLANCK_AVE(L, I)                                                    RAD_ALL.9042  
     &            =0.5E+00*(PLANCK_SOURCE(L, I-1)+PLANCK_SOURCE(L, I))             RAD_ALL.9043  
            ENDDO                                                                  RAD_ALL.9044  
         ENDDO                                                                     RAD_ALL.9045  
!                                                                                  RAD_ALL.9046  
         DO I=1, N_LAYER                                                           RAD_ALL.9047  
            DO L=1, N_PROFILE                                                      RAD_ALL.9048  
               DELTA_TAU_UP_TOP=TAUC(L, N_LAYER)-TAUC(L, I-1)                      RAD_ALL.9049  
               DELTA_TAU_UP_BASE=TAUC(L, N_LAYER)-TAUC(L, I)                       RAD_ALL.9050  
               S_UP(L, I)=S_UP(L, I)                                               RAD_ALL.9051  
     &            +2.0E+00*(GROUND_EMISSION(L)-PLANCK_AVE(L, I))                   RAD_ALL.9052  
     &            *(E3_ACC01(DELTA_TAU_UP_TOP)                                     RAD_ALL.9053  
     &            -TRANS(L, I)*E3_ACC01(DELTA_TAU_UP_BASE))                        RAD_ALL.9054  
               S_DOWN(L, I)=S_DOWN(L, I)                                           RAD_ALL.9055  
     &            +2.0E+00*PLANCK_AVE(L, I)                                        RAD_ALL.9056  
     &            *(TRANS(L, I)*E3_ACC01(TAUC(L, I-1))                             RAD_ALL.9057  
     &            -E3_ACC01(TAUC(L, I)))                                           RAD_ALL.9058  
            ENDDO                                                                  RAD_ALL.9059  
         ENDDO                                                                     RAD_ALL.9060  
                                                                                   RAD_ALL.9061  
      ENDIF                                                                        RAD_ALL.9062  
!                                                                                  RAD_ALL.9063  
!                                                                                  RAD_ALL.9064  
!                                                                                  RAD_ALL.9065  
      RETURN                                                                       RAD_ALL.9066  
      END 
