C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.22800 
C                                                                                  RAD_ALL.22801 
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.22802 
C restrictions as set forth in the contract.                                       RAD_ALL.22803 
C                                                                                  RAD_ALL.22804 
C                Meteorological Office                                             RAD_ALL.22805 
C                London Road                                                       RAD_ALL.22806 
C                BRACKNELL                                                         RAD_ALL.22807 
C                Berkshire UK                                                      RAD_ALL.22808 
C                RG12 2SZ                                                          RAD_ALL.22809 
C                                                                                  RAD_ALL.22810 
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.22811 
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.22812 
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.22813 
C Modelling at the above address.                                                  RAD_ALL.22814 
C ******************************COPYRIGHT******************************            RAD_ALL.22815 
C                                                                                  RAD_ALL.22816 
!+ Subroutine to find the optical depth and single scattering albedo.              RAD_ALL.22817 
!                                                                                  RAD_ALL.22818 
! Method:                                                                          RAD_ALL.22819 
!       Depending on the treatment of scattering, the optical and                  RAD_ALL.22820 
!       and single scattering albedo are determined from the                       RAD_ALL.22821 
!       extinctions supplied.                                                      RAD_ALL.22822 
!                                                                                  RAD_ALL.22823 
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.22824 
!                                                                                  RAD_ALL.22825 
! History:                                                                         RAD_ALL.22826 
!       Version         Date                    Comment                            RAD_ALL.22827 
!       4.0             27-07-95                Original Code                      RAD_ALL.22828 
!                                               (J. M. Edwards)                    RAD_ALL.22829 
!                                                                                  RAD_ALL.22830 
! Description of Code:                                                             RAD_ALL.22831 
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.22832 
!                                                                                  RAD_ALL.22833 
!- ---------------------------------------------------------------------           RAD_ALL.22834 
      SUBROUTINE SINGLE_SCATTERING(I_SCATTER_METHOD_BAND                           RAD_ALL.22835 
     &   , N_PROFILE, N_LAYER, I_TOP                                               RAD_ALL.22836 
     &   , D_MASS                                                                  RAD_ALL.22837 
     &   , K_GREY_TOT, K_EXT_SCAT, K_GAS_ABS                                       RAD_ALL.22838 
     &   , TAU, OMEGA                                                              RAD_ALL.22839 
     &   , NPD_PROFILE, NPD_LAYER                                                  RAD_ALL.22840 
     &   )                                                                         RAD_ALL.22841 
!                                                                                  RAD_ALL.22842 
!                                                                                  RAD_ALL.22843 
!                                                                                  RAD_ALL.22844 
      IMPLICIT NONE                                                                RAD_ALL.22845 
!                                                                                  RAD_ALL.22846 
!                                                                                  RAD_ALL.22847 
!     SIZES OF ARRAYS.                                                             RAD_ALL.22848 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.22849 
     &     NPD_PROFILE                                                             RAD_ALL.22850 
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.22851 
     &   , NPD_LAYER                                                               RAD_ALL.22852 
!             MAXIMUM NUMBER OF LAYERS                                             RAD_ALL.22853 
!                                                                                  RAD_ALL.22854 
!     INCLUDE COMDECKS.                                                            RAD_ALL.22855 
!     ------------------------------------------------------------------           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    
!     ------------------------------------------------------------------           SCTMTH3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       SCTMTH3A.3     
!                                                                                  SCTMTH3A.4     
!     MODULE TO SET THE METHODS OF TREATING SCATTERING.                            SCTMTH3A.5     
!                                                                                  SCTMTH3A.6     
      INTEGER                                                                      SCTMTH3A.7     
     &     IP_SCATTER_FULL                                                         SCTMTH3A.8     
!             FULL TREATMENT OF SCATTERING                                         SCTMTH3A.9     
     &   , IP_NO_SCATTER_ABS                                                       SCTMTH3A.10    
!             SCATTERING IGNORED COMPLETELY.                                       SCTMTH3A.11    
     &   , IP_NO_SCATTER_EXT                                                       SCTMTH3A.12    
!             SCATTERING TREATED AS ABSORPTION                                     SCTMTH3A.13    
!                                                                                  SCTMTH3A.14    
      PARAMETER(                                                                   SCTMTH3A.15    
     &     IP_SCATTER_FULL=1                                                       SCTMTH3A.16    
     &   , IP_NO_SCATTER_ABS=2                                                     SCTMTH3A.17    
     &   , IP_NO_SCATTER_EXT=3                                                     SCTMTH3A.18    
     &   )                                                                         SCTMTH3A.19    
!                                                                                  SCTMTH3A.20    
!     ------------------------------------------------------------------           SCTMTH3A.21    
!                                                                                  RAD_ALL.22858 
!     DUMMY VARIABLES.                                                             RAD_ALL.22859 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.22860 
     &     I_SCATTER_METHOD_BAND                                                   RAD_ALL.22861 
!             TREATMENT OF SCATTERING IN THIS BAND                                 RAD_ALL.22862 
!                                                                                  RAD_ALL.22863 
!                       Atmospheric Properties                                     RAD_ALL.22864 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.22865 
     &     N_PROFILE                                                               RAD_ALL.22866 
!             NUMBER OF PROFILES                                                   RAD_ALL.22867 
     &   , N_LAYER                                                                 RAD_ALL.22868 
!             NUMBER OF LAYERS                                                     RAD_ALL.22869 
     &   , I_TOP                                                                   RAD_ALL.22870 
!             TOP LAYER TO CONSIDER                                                RAD_ALL.22871 
      REAL      !, INTENT(IN)                                                      RAD_ALL.22872 
     &     D_MASS(NPD_PROFILE, NPD_LAYER)                                          RAD_ALL.22873 
!             MASS THICKNESS OF EACH LAYER                                         RAD_ALL.22874 
!                                                                                  RAD_ALL.22875 
!                       Optical Propeties                                          RAD_ALL.22876 
      REAL      !, INTENT(IN)                                                      RAD_ALL.22877 
     &     K_GREY_TOT(NPD_PROFILE, NPD_LAYER)                                      RAD_ALL.22878 
!             ABSORPTIVE EXTINCTION                                                RAD_ALL.22879 
     &   , K_EXT_SCAT(NPD_PROFILE, NPD_LAYER)                                      RAD_ALL.22880 
!             SCATTERING EXTINCTION                                                RAD_ALL.22881 
     &   , K_GAS_ABS(NPD_PROFILE, NPD_LAYER)                                       RAD_ALL.22882 
!             GASEOUS EXTINCTION                                                   RAD_ALL.22883 
!                                                                                  RAD_ALL.22884 
!                       Single Scattering Propeties                                RAD_ALL.22885 
      REAL      !, INTENT(OUT)                                                     RAD_ALL.22886 
     &     TAU(NPD_PROFILE, NPD_LAYER)                                             RAD_ALL.22887 
!             OPTICAL DEPTH                                                        RAD_ALL.22888 
     &   , OMEGA(NPD_PROFILE, NPD_LAYER)                                           RAD_ALL.22889 
!             SINGLE SCATTERING ALBEDO                                             RAD_ALL.22890 
!                                                                                  RAD_ALL.22891 
!                                                                                  RAD_ALL.22892 
!                                                                                  RAD_ALL.22893 
!     LOCAL VARIABLES.                                                             RAD_ALL.22894 
      INTEGER                                                                      RAD_ALL.22895 
     &     L                                                                       RAD_ALL.22896 
!             LOOP VARIABLE                                                        RAD_ALL.22897 
     &   , I                                                                       RAD_ALL.22898 
!             LOOP VARIABLE                                                        RAD_ALL.22899 
!                                                                                  RAD_ALL.22900 
!                                                                                  RAD_ALL.22901 
!                                                                                  RAD_ALL.22902 
!     THE MACHINE TOLERANCE IS ADDED TO THE DENOMINATOR IN THE                     RAD_ALL.22903 
!     EXPRESSION FOR OMEGA TO PREVENT DIVISION BY ZERO: THIS IS                    RAD_ALL.22904 
!     SIGNIFICANT ONLY IF THE TOTAL EXTINCTION IS SMALL, AND THUS                  RAD_ALL.22905 
!     WILL NOT SENSIBLY AFFECT ANY PHYSICAL RESULTS.                               RAD_ALL.22906 
!                                                                                  RAD_ALL.22907 
      IF (I_SCATTER_METHOD_BAND.EQ.IP_SCATTER_FULL) THEN                           RAD_ALL.22908 
!                                                                                  RAD_ALL.22909 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.22910 
            DO L=1, N_PROFILE                                                      RAD_ALL.22911 
               TAU(L, I)=(K_GREY_TOT(L, I)+K_GAS_ABS(L, I))                        RAD_ALL.22912 
     &            *D_MASS(L, I)                                                    RAD_ALL.22913 
               OMEGA(L, I)=K_EXT_SCAT(L, I)                                        RAD_ALL.22914 
     &            /(K_GREY_TOT(L, I)+K_GAS_ABS(L, I)+TOL_MACHINE)                  RAD_ALL.22915 
            ENDDO                                                                  RAD_ALL.22916 
         ENDDO                                                                     RAD_ALL.22917 
!                                                                                  RAD_ALL.22918 
      ELSE IF (I_SCATTER_METHOD_BAND.EQ.IP_NO_SCATTER_ABS) THEN                    RAD_ALL.22919 
!                                                                                  RAD_ALL.22920 
!        THE SCATTERING EXTINCTION IS IGNORED COMPLETELY, SO                       RAD_ALL.22921 
!        ONLY THE ABSORPTIVE CONTRIBUTIONS TO THE SINGLE                           RAD_ALL.22922 
!        SCATTERING PROPETIES ARE INCLUDED.                                        RAD_ALL.22923 
!                                                                                  RAD_ALL.22924 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.22925 
            DO L=1, N_PROFILE                                                      RAD_ALL.22926 
               TAU(L, I)=(K_GREY_TOT(L, I)+K_GAS_ABS(L, I)                         RAD_ALL.22927 
     &            -K_EXT_SCAT(L, I))*D_MASS(L, I)                                  RAD_ALL.22928 
               OMEGA(L, I)=0.0                                                     RAD_ALL.22929 
            ENDDO                                                                  RAD_ALL.22930 
         ENDDO                                                                     RAD_ALL.22931 
!                                                                                  RAD_ALL.22932 
      ELSE IF (I_SCATTER_METHOD_BAND.EQ.IP_NO_SCATTER_EXT) THEN                    RAD_ALL.22933 
!                                                                                  RAD_ALL.22934 
!        THE SCATTERING EXTINCTION IS ADDED ON TO THE ABSORPTION.                  RAD_ALL.22935 
!                                                                                  RAD_ALL.22936 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.22937 
            DO L=1, N_PROFILE                                                      RAD_ALL.22938 
               TAU(L, I)=(K_GREY_TOT(L, I)+K_GAS_ABS(L, I))                        RAD_ALL.22939 
     &            *D_MASS(L, I)                                                    RAD_ALL.22940 
               OMEGA(L, I)=0.0E+00                                                 RAD_ALL.22941 
            ENDDO                                                                  RAD_ALL.22942 
         ENDDO                                                                     RAD_ALL.22943 
!                                                                                  RAD_ALL.22944 
      ENDIF                                                                        RAD_ALL.22945 
!                                                                                  RAD_ALL.22946 
!                                                                                  RAD_ALL.22947 
!                                                                                  RAD_ALL.22948 
      RETURN                                                                       RAD_ALL.22949 
      END 
