*IF DEF,A70_1B                                                             RSCTW3B.2      
*IF DEF,A01_3A,OR,DEF,A02_3A                                               RSCTW3B.3      
C ******************************COPYRIGHT******************************    RSCTW3B.4      
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved.    RSCTW3B.5      
C                                                                          RSCTW3B.6      
C Use, duplication or disclosure of this code is subject to the            RSCTW3B.7      
C restrictions as set forth in the contract.                               RSCTW3B.8      
C                                                                          RSCTW3B.9      
C                Meteorological Office                                     RSCTW3B.10     
C                London Road                                               RSCTW3B.11     
C                BRACKNELL                                                 RSCTW3B.12     
C                Berkshire UK                                              RSCTW3B.13     
C                RG12 2SZ                                                  RSCTW3B.14     
C                                                                          RSCTW3B.15     
C If no contract has been raised with this copy of the code, the use,      RSCTW3B.16     
C duplication or disclosure of it is strictly prohibited.  Permission      RSCTW3B.17     
C to do so must first be obtained in writing from the Head of Numerical    RSCTW3B.18     
C Modelling at the above address.                                          RSCTW3B.19     
C ******************************COPYRIGHT******************************    RSCTW3B.20     
C                                                                          RSCTW3B.21     
!+ Subroutine to rescale optical depth and albedo.                         RSCTW3B.22     
!                                                                          RSCTW3B.23     
! Method:                                                                  RSCTW3B.24     
!       The standard rescaling formulae are applied.                       RSCTW3B.25     
!                                                                          RSCTW3B.26     
! Current Owner of Code: J. M. Edwards                                     RSCTW3B.27     
!                                                                          RSCTW3B.28     
! History:                                                                 RSCTW3B.29     
!       Version         Date                    Comment                    RSCTW3B.30     
!       4.5             11-06-98                Optimised version          RSCTW3B.31     
!                                               (P. Burton)                RSCTW3B.32     
!                                                                          RSCTW3B.33     
! Description of Code:                                                     RSCTW3B.34     
!   FORTRAN 77  with extensions listed in documentation.                   RSCTW3B.35     
!                                                                          RSCTW3B.36     
!- ---------------------------------------------------------------------   RSCTW3B.37     

      SUBROUTINE RESCALE_TAU_OMEGA(N_PROFILE                                2RSCTW3B.38     
     &   , I_LAYER_FIRST, I_LAYER_LAST                                     RSCTW3B.39     
     &   , TAU, OMEGA, FORWARD_SCATTER                                     RSCTW3B.40     
     &   , NPD_PROFILE, NPD_LAYER                                          RSCTW3B.41     
     &   )                                                                 RSCTW3B.42     
!                                                                          RSCTW3B.43     
!                                                                          RSCTW3B.44     
      IMPLICIT NONE                                                        RSCTW3B.45     
!                                                                          RSCTW3B.46     
!                                                                          RSCTW3B.47     
!     SIZES OF DUMMY ARRAYS.                                               RSCTW3B.48     
      INTEGER   !, INTENT(IN)                                              RSCTW3B.49     
     &     NPD_PROFILE                                                     RSCTW3B.50     
!             MAXIMUM NUMBER OF PROFILES                                   RSCTW3B.51     
     &   , NPD_LAYER                                                       RSCTW3B.52     
!             MAXIMUM NUMBER OF LAYERS                                     RSCTW3B.53     
!                                                                          RSCTW3B.54     
!     DUMMY ARGUMENTS.                                                     RSCTW3B.55     
      INTEGER   !, INTENT(IN)                                              RSCTW3B.56     
     &     N_PROFILE                                                       RSCTW3B.57     
!             NUMBER OF PROFILES                                           RSCTW3B.58     
     &   , I_LAYER_FIRST                                                   RSCTW3B.59     
!             FIRST LAYER TO RESCALE                                       RSCTW3B.60     
     &   , I_LAYER_LAST                                                    RSCTW3B.61     
!             FIRST LAYER TO RESCALE                                       RSCTW3B.62     
      REAL      !, INTENT(IN)                                              RSCTW3B.63     
     &     FORWARD_SCATTER(NPD_PROFILE, NPD_LAYER)                         RSCTW3B.64     
!             FORWARD SCATTERING                                           RSCTW3B.65     
      REAL      !, INTENT(INOUT)                                           RSCTW3B.66     
     &     TAU(NPD_PROFILE, NPD_LAYER)                                     RSCTW3B.67     
!             OPTICAL DEPTH                                                RSCTW3B.68     
     &   , OMEGA(NPD_PROFILE, NPD_LAYER)                                   RSCTW3B.69     
!             ALBEDO OF SINGLE SCATTERING                                  RSCTW3B.70     
!                                                                          RSCTW3B.71     
!     LOCAL VARIABLES.                                                     RSCTW3B.72     
      INTEGER                                                              RSCTW3B.73     
     &     I                                                               RSCTW3B.74     
!             LOOP VARIABLE                                                RSCTW3B.75     
     &   , L                                                               RSCTW3B.76     
!             LOOP VARIABLE                                                RSCTW3B.77     
                                                                           RSCTW3B.78     
!     Temporary scalars for the rescheduled divide                         RSCTW3B.79     
      REAL                                                                 RSCTW3B.80     
     &  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5                                      RSCTW3B.81     
                                                                           RSCTW3B.82     
                                                                           RSCTW3B.83     
                                                                           RSCTW3B.84     
      DO I=I_LAYER_FIRST, I_LAYER_LAST                                     RSCTW3B.85     
         IF(N_PROFILE.GT.0) THEN                                           RSCTW3B.86     
            TEMP1=1.0E+00 - OMEGA(1,I)*FORWARD_SCATTER(1,I)                RSCTW3B.87     
            TEMP2=1.0E+00 - FORWARD_SCATTER(1,I)                           RSCTW3B.88     
            DO L=1,N_PROFILE-1                                             RSCTW3B.89     
               TEMP5=TEMP2/TEMP1                                           RSCTW3B.90     
               TAU(L,I)=TAU(L,I)*TEMP1                                     RSCTW3B.91     
               TEMP3=1.0-OMEGA(L+1,I)*FORWARD_SCATTER(L+1,I)               RSCTW3B.92     
               TEMP4=1.0-FORWARD_SCATTER(L+1,I)                            RSCTW3B.93     
               TEMP2=TEMP4                                                 RSCTW3B.94     
               TEMP1=TEMP3                                                 RSCTW3B.95     
               OMEGA(L,I) = OMEGA(L,I)*TEMP5                               RSCTW3B.96     
            ENDDO                                                          RSCTW3B.97     
            TEMP5=TEMP2/TEMP1                                              RSCTW3B.98     
            TAU(N_PROFILE,I) = TAU(N_PROFILE,I)*TEMP1                      RSCTW3B.99     
            OMEGA(N_PROFILE,I)= OMEGA(N_PROFILE,I)*TEMP5                   RSCTW3B.100    
         END IF                                                            RSCTW3B.101    
      END DO                                                               RSCTW3B.102    
                                                                           RSCTW3B.103    
      RETURN                                                               RSCTW3B.104    
      END                                                                  RSCTW3B.105    
*ENDIF DEF,A01_3A,OR,DEF,A02_3A                                            RSCTW3B.106    
*ENDIF DEF,A70_1B                                                          RSCTW3B.107