*IF DEF,A70_1A,OR,DEF,A70_1B                                               APB4F405.47     
*IF DEF,A01_3A,OR,DEF,A02_3A                                               MXAPS3A.2      
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.    GTS2F400.13484  
C                                                                          GTS2F400.13485  
C Use, duplication or disclosure of this code is subject to the            GTS2F400.13486  
C restrictions as set forth in the contract.                               GTS2F400.13487  
C                                                                          GTS2F400.13488  
C                Meteorological Office                                     GTS2F400.13489  
C                London Road                                               GTS2F400.13490  
C                BRACKNELL                                                 GTS2F400.13491  
C                Berkshire UK                                              GTS2F400.13492  
C                RG12 2SZ                                                  GTS2F400.13493  
C                                                                          GTS2F400.13494  
C If no contract has been raised with this copy of the code, the use,      GTS2F400.13495  
C duplication or disclosure of it is strictly prohibited.  Permission      GTS2F400.13496  
C to do so must first be obtained in writing from the Head of Numerical    GTS2F400.13497  
C Modelling at the above address.                                          GTS2F400.13498  
C ******************************COPYRIGHT******************************    GTS2F400.13499  
C                                                                          GTS2F400.13500  
!+ Subroutine to solve for fluxes treating scattering approximately.       MXAPS3A.3      
!                                                                          MXAPS3A.4      
! Method:                                                                  MXAPS3A.5      
!       The routine is applicable in the infra-red. Downward               MXAPS3A.6      
!       differential fluxes are calculated first assuming that the         MXAPS3A.7      
!       upward differential fluxes are 0. Upward fluxes are then           MXAPS3A.8      
!       calculated using the previously calculated downward fluxes         MXAPS3A.9      
!       in the reflected terms.                                            MXAPS3A.10     
!                                                                          MXAPS3A.11     
! Current Owner of Code: J. M. Edwards                                     MXAPS3A.12     
!                                                                          MXAPS3A.13     
! History:                                                                 MXAPS3A.14     
!       Version         Date                    Comment                    MXAPS3A.15     
!       4.0             27-07-95                Original Code              MXAPS3A.16     
!                                               (J. M. Edwards)            MXAPS3A.17     
!                                                                          MXAPS3A.18     
! Description of Code:                                                     MXAPS3A.19     
!   FORTRAN 77  with extensions listed in documentation.                   MXAPS3A.20     
!                                                                          MXAPS3A.21     
!- ---------------------------------------------------------------------   MXAPS3A.22     

      SUBROUTINE MIX_APP_SCAT(N_PROFILE, N_LAYER, N_CLOUD_TOP               1MXAPS3A.23     
     &   , T_FREE, R_FREE, S_DOWN_FREE, S_UP_FREE                          MXAPS3A.24     
     &   , T_CLOUD, R_CLOUD, S_DOWN_CLOUD, S_UP_CLOUD                      MXAPS3A.25     
     &   , G_FF, G_FC, G_CF, G_CC                                          MXAPS3A.26     
     &   , B_FF, B_FC, B_CF, B_CC                                          MXAPS3A.27     
     &   , L_NET                                                           MXAPS3A.28     
     &   , FLUX_INC_DOWN                                                   MXAPS3A.29     
     &   , SOURCE_GROUND, ALBEDO_SURFACE_DIFF                              MXAPS3A.30     
     &   , FLUX_DIFFUSE                                                    MXAPS3A.31     
     &   , NPD_PROFILE, NPD_LAYER                                          MXAPS3A.32     
     &   )                                                                 MXAPS3A.33     
!                                                                          MXAPS3A.34     
!                                                                          MXAPS3A.35     
      IMPLICIT NONE                                                        MXAPS3A.36     
!                                                                          MXAPS3A.37     
!                                                                          MXAPS3A.38     
!     SIZES OF DUMMY ARRAYS.                                               MXAPS3A.39     
      INTEGER   !, INTENT(IN)                                              MXAPS3A.40     
     &     NPD_PROFILE                                                     MXAPS3A.41     
!             MAXIMUM NUMBER OF PROFILES                                   MXAPS3A.42     
     &   , NPD_LAYER                                                       MXAPS3A.43     
!             MAXIMUM NUMBER OF LAYERS                                     MXAPS3A.44     
!                                                                          MXAPS3A.45     
!                                                                          MXAPS3A.46     
!     DUMMY ARGUMENTS.                                                     MXAPS3A.47     
      INTEGER   !, INTENT(IN)                                              MXAPS3A.48     
     &     N_PROFILE                                                       MXAPS3A.49     
!             NUMBER OF PROFILES                                           MXAPS3A.50     
     &   , N_LAYER                                                         MXAPS3A.51     
!             NUMBER OF LAYERS                                             MXAPS3A.52     
     &   , N_CLOUD_TOP                                                     MXAPS3A.53     
!             TOPMOST CLOUDY LAYER                                         MXAPS3A.54     
      LOGICAL   !, INTENT(IN)                                              MXAPS3A.55     
     &     L_NET                                                           MXAPS3A.56     
!             FLAG FOR CALCULATION OF NET FLUXES                           MXAPS3A.57     
      REAL      !, INTENT(IN)                                              MXAPS3A.58     
     &     T_FREE(NPD_PROFILE, NPD_LAYER)                                  MXAPS3A.59     
!             FREE TRANSMISSION                                            MXAPS3A.60     
     &   , R_FREE(NPD_PROFILE, NPD_LAYER)                                  MXAPS3A.61     
!             FREE REFLECTION                                              MXAPS3A.62     
     &   , S_DOWN_FREE(NPD_PROFILE, NPD_LAYER)                             MXAPS3A.63     
!             FREE DOWNWARD SOURCE FUNCTION                                MXAPS3A.64     
     &   , S_UP_FREE(NPD_PROFILE, NPD_LAYER)                               MXAPS3A.65     
!             FREE UPWARD SOURCE FUNCTION                                  MXAPS3A.66     
     &   , T_CLOUD(NPD_PROFILE, NPD_LAYER)                                 MXAPS3A.67     
!             CLOUDY TRANSMISSION                                          MXAPS3A.68     
     &   , R_CLOUD(NPD_PROFILE, NPD_LAYER)                                 MXAPS3A.69     
!             CLOUDY REFLECTION                                            MXAPS3A.70     
     &   , S_DOWN_CLOUD(NPD_PROFILE, NPD_LAYER)                            MXAPS3A.71     
!             DOWNWARD CLOUDY SOURCE FUNCTION                              MXAPS3A.72     
     &   , S_UP_CLOUD(NPD_PROFILE, NPD_LAYER)                              MXAPS3A.73     
!             UPWARD CLOUDY SOURCE FUNCTION                                MXAPS3A.74     
      REAL      !, INTENT(IN)                                              MXAPS3A.75     
     &     G_FF(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.76     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.77     
     &   , G_FC(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.78     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.79     
     &   , G_CF(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.80     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.81     
     &   , G_CC(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.82     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.83     
     &   , B_FF(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.84     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.85     
     &   , B_FC(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.86     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.87     
     &   , B_CF(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.88     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.89     
     &   , B_CC(NPD_PROFILE, 0: NPD_LAYER)                                 MXAPS3A.90     
!             ENERGY TRANSFER COEFFICIENT                                  MXAPS3A.91     
      REAL      !, INTENT(IN)                                              MXAPS3A.92     
     &     FLUX_INC_DOWN(NPD_PROFILE)                                      MXAPS3A.93     
!             INCIDENT DIFFUSE FLUX                                        MXAPS3A.94     
     &   , SOURCE_GROUND(NPD_PROFILE)                                      MXAPS3A.95     
!             SOURCE FROM GROUND                                           MXAPS3A.96     
     &   , ALBEDO_SURFACE_DIFF(NPD_PROFILE)                                MXAPS3A.97     
!             DIFFUSE ALBEDO                                               MXAPS3A.98     
      REAL      !, INTENT(OUT)                                             MXAPS3A.99     
     &     FLUX_DIFFUSE(NPD_PROFILE, 2*NPD_LAYER+2)                        MXAPS3A.100    
!             DIFFUSE FLUX                                                 MXAPS3A.101    
!                                                                          MXAPS3A.102    
!     LOCAL VARIABLES.                                                     MXAPS3A.103    
      INTEGER                                                              MXAPS3A.104    
     &     I                                                               MXAPS3A.105    
!             LOOP VARIABLE                                                MXAPS3A.106    
     &   , L                                                               MXAPS3A.107    
!             LOOP VARIABLE                                                MXAPS3A.108    
!                                                                          MXAPS3A.109    
      REAL                                                                 MXAPS3A.110    
     &     FLUX_DOWN(NPD_PROFILE, 0: NPD_LAYER)                            MXAPS3A.111    
!             DOWNWARD FLUXES OUTSIDE CLOUDS JUST BELOW I'TH LEVEL         MXAPS3A.112    
     &   , FLUX_DOWN_CLOUD(NPD_PROFILE, 0: NPD_LAYER)                      MXAPS3A.113    
!             DOWNWARD FLUXES INSIDE CLOUDS JUST BELOW I'TH LEVEL          MXAPS3A.114    
     &   , FLUX_UP(NPD_PROFILE, 0: NPD_LAYER)                              MXAPS3A.115    
!             UPWARD FLUXES OUTSIDE CLOUDS JUST ABOVE I'TH LEVEL           MXAPS3A.116    
     &   , FLUX_UP_CLOUD(NPD_PROFILE, 0: NPD_LAYER)                        MXAPS3A.117    
!             UPWARD FLUXES INSIDE CLOUDS JUST ABOVE I'TH LEVEL            MXAPS3A.118    
     &   , FLUX_PROPAGATED                                                 MXAPS3A.119    
!             TEMPORARY PROPAGATED FLUX OUTSIDE CLOUD                      MXAPS3A.120    
     &   , FLUX_PROPAGATED_CLOUD                                           MXAPS3A.121    
!             TEMPORARY PROPAGATED FLUX INSIDE CLOUD                       MXAPS3A.122    
     &   , FLUX_CLOUD_TOP(NPD_PROFILE)                                     MXAPS3A.123    
!             TOTAL DOWNWARD FLUX AT TOP OF CLOUD                          MXAPS3A.124    
!                                                                          MXAPS3A.125    
!                                                                          MXAPS3A.126    
!                                                                          MXAPS3A.127    
!     THE ARRAYS FLUX_DOWN AND FLUX_UP WILL EVENTUALLY CONTAIN THE TOTAL   MXAPS3A.128    
!     FLUXES, BUT INITIALLY THEY ARE USED FOR THE CLEAR FLUXES.            MXAPS3A.129    
!     NOTE THAT DOWNWARD FLUXES REFER TO VALUES JUST BELOW THE INTERFACE   MXAPS3A.130    
!     AND UPWARD FLUXES TO VALUES JUST ABOVE IT.                           MXAPS3A.131    
!                                                                          MXAPS3A.132    
!                                                                          MXAPS3A.133    
!     DOWNWARD FLUX:                                                       MXAPS3A.134    
!                                                                          MXAPS3A.135    
!     REGION ABOVE CLOUDS:                                                 MXAPS3A.136    
      DO L=1, N_PROFILE                                                    MXAPS3A.137    
         FLUX_DOWN(L, 0)=FLUX_INC_DOWN(L)                                  MXAPS3A.138    
      ENDDO                                                                MXAPS3A.139    
      DO I=1, N_CLOUD_TOP-1                                                MXAPS3A.140    
         DO L=1, N_PROFILE                                                 MXAPS3A.141    
            FLUX_DOWN(L, I)=T_FREE(L, I)*FLUX_DOWN(L, I-1)                 MXAPS3A.142    
     &         +S_DOWN_FREE(L, I)                                          MXAPS3A.143    
         ENDDO                                                             MXAPS3A.144    
      ENDDO                                                                MXAPS3A.145    
      DO L=1, N_PROFILE                                                    MXAPS3A.146    
         FLUX_CLOUD_TOP(L)=FLUX_DOWN(L, N_CLOUD_TOP-1)                     MXAPS3A.147    
      ENDDO                                                                MXAPS3A.148    
!                                                                          MXAPS3A.149    
!     REGION OF CLOUDS:                                                    MXAPS3A.150    
      DO L=1, N_PROFILE                                                    MXAPS3A.151    
         FLUX_DOWN(L, N_CLOUD_TOP-1)                                       MXAPS3A.152    
     &      =G_FF(L, N_CLOUD_TOP-1)*FLUX_CLOUD_TOP(L)                      MXAPS3A.153    
         FLUX_DOWN_CLOUD(L, N_CLOUD_TOP-1)                                 MXAPS3A.154    
     &      =G_FC(L, N_CLOUD_TOP-1)*FLUX_CLOUD_TOP(L)                      MXAPS3A.155    
      ENDDO                                                                MXAPS3A.156    
!                                                                          MXAPS3A.157    
      DO I=N_CLOUD_TOP, N_LAYER-1                                          MXAPS3A.158    
         DO L=1, N_PROFILE                                                 MXAPS3A.159    
!                                                                          MXAPS3A.160    
!           PROPAGATE DOWNWARD FLUXES THROUGH THE LAYER.                   MXAPS3A.161    
            FLUX_PROPAGATED=T_FREE(L, I)*FLUX_DOWN(L, I-1)                 MXAPS3A.162    
     &         +S_DOWN_FREE(L, I)                                          MXAPS3A.163    
            FLUX_PROPAGATED_CLOUD=T_CLOUD(L, I)*FLUX_DOWN_CLOUD(L, I-1)    MXAPS3A.164    
     &         +S_DOWN_CLOUD(L, I)                                         MXAPS3A.165    
!           TRANSFER DOWNWARD FLUXES ACROSS THE INTERFACE.                 MXAPS3A.166    
            FLUX_DOWN(L, I)                                                MXAPS3A.167    
     &         =G_FF(L, I)*FLUX_PROPAGATED                                 MXAPS3A.168    
     &         +G_CF(L, I)*FLUX_PROPAGATED_CLOUD                           MXAPS3A.169    
            FLUX_DOWN_CLOUD(L, I)                                          MXAPS3A.170    
     &         =G_CC(L, I)*FLUX_PROPAGATED_CLOUD                           MXAPS3A.171    
     &         +G_FC(L, I)*FLUX_PROPAGATED                                 MXAPS3A.172    
!                                                                          MXAPS3A.173    
         ENDDO                                                             MXAPS3A.174    
      ENDDO                                                                MXAPS3A.175    
!                                                                          MXAPS3A.176    
!     PROPAGATE ACROSS THE BOTTOM LAYER, BUT WITHOUT TRANSFERRING          MXAPS3A.177    
!     ACROSS THE SURFACE AND FORM THE REFLECTED BEAMS.                     MXAPS3A.178    
      DO L=1, N_PROFILE                                                    MXAPS3A.179    
!        PROPAGATE DOWNWARD FLUXES THROUGH THE LAYER.                      MXAPS3A.180    
         FLUX_DOWN(L, N_LAYER)                                             MXAPS3A.181    
     &      =T_FREE(L, N_LAYER)*FLUX_DOWN(L, N_LAYER-1)                    MXAPS3A.182    
     &      +S_DOWN_FREE(L, N_LAYER)                                       MXAPS3A.183    
         FLUX_DOWN_CLOUD(L, N_LAYER)                                       MXAPS3A.184    
     &      =T_CLOUD(L, N_LAYER)*FLUX_DOWN_CLOUD(L, N_LAYER-1)             MXAPS3A.185    
     &      +S_DOWN_CLOUD(L, N_LAYER)                                      MXAPS3A.186    
         FLUX_UP(L, N_LAYER)                                               MXAPS3A.187    
     &      =ALBEDO_SURFACE_DIFF(L)*FLUX_DOWN(L, N_LAYER)                  MXAPS3A.188    
     &      +B_FF(L, N_LAYER)*SOURCE_GROUND(L)                             MXAPS3A.189    
         FLUX_UP_CLOUD(L, N_LAYER)                                         MXAPS3A.190    
     &      =ALBEDO_SURFACE_DIFF(L)*FLUX_DOWN_CLOUD(L, N_LAYER)            MXAPS3A.191    
     &      +B_CF(L, N_LAYER)*SOURCE_GROUND(L)                             MXAPS3A.192    
      ENDDO                                                                MXAPS3A.193    
!                                                                          MXAPS3A.194    
!                                                                          MXAPS3A.195    
!     CALCULATE THE UPWARD FLUXES USING THE PREVIOUS DOWNWARD FLUXES       MXAPS3A.196    
!     TO APPROXIMATE THE SCATTERING TERM.                                  MXAPS3A.197    
      DO I=N_LAYER, N_CLOUD_TOP, -1                                        MXAPS3A.198    
         DO L=1, N_PROFILE                                                 MXAPS3A.199    
!                                                                          MXAPS3A.200    
!           PROPAGATE UPWARD FLUXES THROUGH THE LAYER.                     MXAPS3A.201    
            FLUX_PROPAGATED=T_FREE(L, I)*FLUX_UP(L, I)+S_UP_FREE(L, I)     MXAPS3A.202    
     &         +R_FREE(L, I)*FLUX_DOWN(L, I-1)                             MXAPS3A.203    
            FLUX_PROPAGATED_CLOUD=T_CLOUD(L, I)*FLUX_UP_CLOUD(L, I)        MXAPS3A.204    
     &         +S_UP_CLOUD(L, I)+R_CLOUD(L, I)*FLUX_DOWN_CLOUD(L, I-1)     MXAPS3A.205    
!           TRANSFER UPWARD FLUXES ACROSS THE INTERFACE.                   MXAPS3A.206    
            FLUX_UP(L, I-1)=B_FF(L, I-1)*FLUX_PROPAGATED                   MXAPS3A.207    
     &         +B_FC(L, I-1)*FLUX_PROPAGATED_CLOUD                         MXAPS3A.208    
            FLUX_UP_CLOUD(L, I-1)=B_CC(L, I-1)*FLUX_PROPAGATED_CLOUD       MXAPS3A.209    
     &         +B_CF(L, I-1)*FLUX_PROPAGATED                               MXAPS3A.210    
!                                                                          MXAPS3A.211    
         ENDDO                                                             MXAPS3A.212    
      ENDDO                                                                MXAPS3A.213    
!                                                                          MXAPS3A.214    
!     CONTINUE THROUGH THE REGION ABOVE CLOUDS.                            MXAPS3A.215    
      DO I=N_CLOUD_TOP-1, 1, -1                                            MXAPS3A.216    
         DO L=1, N_PROFILE                                                 MXAPS3A.217    
            FLUX_UP(L, I-1)=T_FREE(L, I)*FLUX_UP(L,I)+S_UP_FREE(L, I)      MXAPS3A.218    
     &         +R_FREE(L, I)*FLUX_DOWN(L, I-1)                             MXAPS3A.219    
         ENDDO                                                             MXAPS3A.220    
      ENDDO                                                                MXAPS3A.221    
!                                                                          MXAPS3A.222    
!                                                                          MXAPS3A.223    
!                                                                          MXAPS3A.224    
!     CALCULATE THE OVERALL FLUX.                                          MXAPS3A.225    
      IF (L_NET) THEN                                                      MXAPS3A.226    
         DO I=0, N_CLOUD_TOP-2                                             MXAPS3A.227    
            DO L=1, N_PROFILE                                              MXAPS3A.228    
               FLUX_DIFFUSE(L, I+1)=FLUX_DOWN(L, I)-FLUX_UP(L, I)          MXAPS3A.229    
            ENDDO                                                          MXAPS3A.230    
         ENDDO                                                             MXAPS3A.231    
         DO I=N_CLOUD_TOP-1, N_LAYER                                       MXAPS3A.232    
            DO L=1, N_PROFILE                                              MXAPS3A.233    
               FLUX_DIFFUSE(L, I+1)                                        MXAPS3A.234    
     &            =FLUX_DOWN(L, I)+FLUX_DOWN_CLOUD(L, I)                   MXAPS3A.235    
     &            -FLUX_UP(L, I)-FLUX_UP_CLOUD(L, I)                       MXAPS3A.236    
            ENDDO                                                          MXAPS3A.237    
         ENDDO                                                             MXAPS3A.238    
      ELSE                                                                 MXAPS3A.239    
         DO I=0, N_CLOUD_TOP-2                                             MXAPS3A.240    
            DO L=1, N_PROFILE                                              MXAPS3A.241    
               FLUX_DIFFUSE(L, 2*I+1)=FLUX_UP(L, I)                        MXAPS3A.242    
               FLUX_DIFFUSE(L, 2*I+2)=FLUX_DOWN(L, I)                      MXAPS3A.243    
            ENDDO                                                          MXAPS3A.244    
         ENDDO                                                             MXAPS3A.245    
         DO I=N_CLOUD_TOP-1, N_LAYER                                       MXAPS3A.246    
            DO L=1, N_PROFILE                                              MXAPS3A.247    
               FLUX_DIFFUSE(L, 2*I+1)=FLUX_UP(L, I)+FLUX_UP_CLOUD(L, I)    MXAPS3A.248    
               FLUX_DIFFUSE(L, 2*I+2)=FLUX_DOWN(L, I)                      MXAPS3A.249    
     &            +FLUX_DOWN_CLOUD(L, I)                                   MXAPS3A.250    
            ENDDO                                                          MXAPS3A.251    
         ENDDO                                                             MXAPS3A.252    
      ENDIF                                                                MXAPS3A.253    
!                                                                          MXAPS3A.254    
!                                                                          MXAPS3A.255    
      RETURN                                                               MXAPS3A.256    
      END                                                                  MXAPS3A.257    
*ENDIF DEF,A01_3A,OR,DEF,A02_3A                                            MXAPS3A.258    
*ENDIF DEF,A70_1A,OR,DEF,A70_1B                                            APB4F405.48