*IF DEF,A70_1A,OR,DEF,A70_1B                                               APB4F405.71     
*IF DEF,A01_3A,OR,DEF,A02_3A                                               RSCNT3A.2      
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.    GTS2F400.13705  
C                                                                          GTS2F400.13706  
C Use, duplication or disclosure of this code is subject to the            GTS2F400.13707  
C restrictions as set forth in the contract.                               GTS2F400.13708  
C                                                                          GTS2F400.13709  
C                Meteorological Office                                     GTS2F400.13710  
C                London Road                                               GTS2F400.13711  
C                BRACKNELL                                                 GTS2F400.13712  
C                Berkshire UK                                              GTS2F400.13713  
C                RG12 2SZ                                                  GTS2F400.13714  
C                                                                          GTS2F400.13715  
C If no contract has been raised with this copy of the code, the use,      GTS2F400.13716  
C duplication or disclosure of it is strictly prohibited.  Permission      GTS2F400.13717  
C to do so must first be obtained in writing from the Head of Numerical    GTS2F400.13718  
C Modelling at the above address.                                          GTS2F400.13719  
C ******************************COPYRIGHT******************************    GTS2F400.13720  
C                                                                          GTS2F400.13721  
!+ Subroutine to apply a path-length scaling to the continuum.             RSCNT3A.3      
!                                                                          RSCNT3A.4      
! Method:                                                                  RSCNT3A.5      
!       The scaling function is calculated. This is multpiled by a         RSCNT3A.6      
!       suitable "amount" of continuum incorporating a broadening          RSCNT3A.7      
!       density.                                                           RSCNT3A.8      
!                                                                          RSCNT3A.9      
! Current Owner of Code: J. M. Edwards                                     RSCNT3A.10     
!                                                                          RSCNT3A.11     
! History:                                                                 RSCNT3A.12     
!       Version         Date                    Comment                    RSCNT3A.13     
!       4.0             27-07-95                Original Code              RSCNT3A.14     
!                                               (J. M. Edwards)            RSCNT3A.15     
!       4.2             Oct. 96     T3E migration: HF functions            GSS3F402.274    
!                                   replaced by T3E vec_lib function       GSS3F402.275    
!                                   rtor_v      (S.J.Swarbrick)            GSS3F402.276    
!                                                                          RSCNT3A.16     
! Description of Code:                                                     RSCNT3A.17     
!   FORTRAN 77  with extensions listed in documentation.                   RSCNT3A.18     
!                                                                          RSCNT3A.19     
!- ---------------------------------------------------------------------   RSCNT3A.20     

      SUBROUTINE RESCALE_CONTINUUM(N_PROFILE, N_LAYER, I_CONTINUUM          1RSCNT3A.21     
     &   , P, T, L_LAYER, I_TOP                                            RSCNT3A.22     
     &   , DENSITY, MOLAR_DENSITY_WATER, MOLAR_DENSITY_FRN                 RSCNT3A.23     
     &   , WATER_FRAC                                                      RSCNT3A.24     
     &   , AMOUNT_CONTINUUM                                                RSCNT3A.25     
     &   , I_FNC                                                           RSCNT3A.26     
     &   , P_REFERENCE, T_REFERENCE, SCALE_PARAMETER                       RSCNT3A.27     
     &   , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC                           RSCNT3A.28     
     &   , NPD_SCALE_VARIABLE                                              RSCNT3A.29     
     &   )                                                                 RSCNT3A.30     
!                                                                          RSCNT3A.31     
!                                                                          RSCNT3A.32     
      IMPLICIT NONE                                                        RSCNT3A.33     
!                                                                          RSCNT3A.34     
!                                                                          RSCNT3A.35     
!     SIZES OF DUMMY ARRAYS.                                               RSCNT3A.36     
      INTEGER   !, INTENT(IN)                                              RSCNT3A.37     
     &     NPD_PROFILE                                                     RSCNT3A.38     
!             MAXIMUM NUMBER OF PROFILES                                   RSCNT3A.39     
     &   , NPD_LAYER                                                       RSCNT3A.40     
!             MAXIMUM NUMBER OF LAYERS                                     RSCNT3A.41     
     &   , NPD_SCALE_FNC                                                   RSCNT3A.42     
!             NUMBER OF SCALING FUNCTIONS                                  RSCNT3A.43     
     &   , NPD_SCALE_VARIABLE                                              RSCNT3A.44     
!             MAX. NUMBER OF SCALING VARIABLES                             RSCNT3A.45     
!                                                                          RSCNT3A.46     
!     INCLUDE COMDECKS                                                     RSCNT3A.47     
*CALL PHYCN03A                                                             RSCNT3A.48     
*CALL CNTUUM3A                                                             RSCNT3A.49     
*CALL SCLFNC3A                                                             RSCNT3A.50     
!                                                                          RSCNT3A.51     
!     DUMMY ARGUMENTS.                                                     RSCNT3A.52     
      INTEGER   !, INTENT(IN)                                              RSCNT3A.53     
     &     N_PROFILE                                                       RSCNT3A.54     
!             NUMBER OF PROFILES                                           RSCNT3A.55     
     &   , N_LAYER                                                         RSCNT3A.56     
!             NUMBER OF LAYERS                                             RSCNT3A.57     
     &   , I_CONTINUUM                                                     RSCNT3A.58     
!             CONTINUUM TYPE                                               RSCNT3A.59     
     &   , I_FNC                                                           RSCNT3A.60     
!             SCALING FUNCTION                                             RSCNT3A.61     
     &   , I_TOP                                                           RSCNT3A.62     
!             TOP INDEX OF ARRAYS                                          RSCNT3A.63     
      LOGICAL   !, INTENT(IN)                                              RSCNT3A.64     
     &     L_LAYER                                                         RSCNT3A.65     
!             DATA ARE SUPPLIED IN LAYERS                                  RSCNT3A.66     
      REAL      !, INTENT(IN)                                              RSCNT3A.67     
     &     WATER_FRAC(NPD_PROFILE, 0: NPD_LAYER)                           RSCNT3A.68     
!             MASS FRACTION OF WATER                                       RSCNT3A.69     
     &   , P(NPD_PROFILE, 0: NPD_LAYER)                                    RSCNT3A.70     
!             PRESSURE                                                     RSCNT3A.71     
     &   , T(NPD_PROFILE, 0: NPD_LAYER)                                    RSCNT3A.72     
!             TEMPERATURE                                                  RSCNT3A.73     
     &   , DENSITY(NPD_PROFILE, 0: NPD_LAYER)                              RSCNT3A.74     
!             OVERALL DENSITY                                              RSCNT3A.75     
     &   , MOLAR_DENSITY_WATER(NPD_PROFILE, 0: NPD_LAYER)                  RSCNT3A.76     
!             MOLAR DENSITY OF WATER VAPOUR                                RSCNT3A.77     
     &   , MOLAR_DENSITY_FRN(NPD_PROFILE, 0: NPD_LAYER)                    RSCNT3A.78     
!             MOLAR DENSITY OF FOREIGN SPECIES                             RSCNT3A.79     
     &   , P_REFERENCE                                                     RSCNT3A.80     
!             REFERENCE PRESSURE                                           RSCNT3A.81     
     &   , T_REFERENCE                                                     RSCNT3A.82     
!             REFERENCE PRESSURE                                           RSCNT3A.83     
     &   , SCALE_PARAMETER(NPD_SCALE_VARIABLE)                             RSCNT3A.84     
!             SCALING PARAMTERS                                            RSCNT3A.85     
      REAL      !, INTENT(OUT)                                             RSCNT3A.86     
     &     AMOUNT_CONTINUUM(NPD_PROFILE, 0: NPD_LAYER)                     RSCNT3A.87     
!             AMOUNT OF CONTINUUM                                          RSCNT3A.88     
!                                                                          RSCNT3A.89     
!     LOCAL VARIABLES.                                                     RSCNT3A.90     
      INTEGER                                                              RSCNT3A.91     
     &     L                                                               RSCNT3A.92     
!             LOOP VARIABLE                                                RSCNT3A.93     
     &   , I                                                               RSCNT3A.94     
!             LOOP VARIABLE                                                RSCNT3A.95     
      REAL    PWK(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                  GSS3F402.277    
      REAL    TWK(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                  GSS3F402.278    
*IF DEF,VECTLIB                                                            PXVECTLB.128    
      REAL    SP1(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                  GSS3F402.280    
      REAL    SP2(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                  GSS3F402.281    
      INTEGER n_input             ! No. of inputs for rtor_v function      GSS3F402.282    
*ENDIF                                                                     GSS3F402.283    
!                                                                          RSCNT3A.106    
!                                                                          RSCNT3A.107    
*IF DEF,VECTLIB                                                            PXVECTLB.129    
         do I=1, N_LAYER-I_TOP+1                                           GSS3F402.285    
            do L=1, N_PROFILE                                              GSS3F402.286    
              sp1(L,I)=SCALE_PARAMETER(1)                                  GSS3F402.287    
              sp2(L,I)=SCALE_PARAMETER(2)                                  GSS3F402.288    
            end do                                                         GSS3F402.289    
         end do                                                            GSS3F402.290    
         n_input=(N_LAYER-I_TOP+1)*N_PROFILE                               GSS3F402.291    
*ENDIF                                                                     GSS3F402.292    
         DO I=   1, N_LAYER-I_TOP+1                                        GSS3F402.293    
            DO L=1, N_PROFILE                                              GSS3F402.294    
              PWK(L,I)=P(L, I_TOP+I-1)/P_REFERENCE                         GSS3F402.295    
            END DO                                                         GSS3F402.296    
         END DO                                                            GSS3F402.297    
*IF DEF,VECTLIB                                                            PXVECTLB.130    
         call rtor_v(n_input,pwk,sp1,pwk)                                  GSS3F402.299    
*ELSE                                                                      GSS3F402.300    
         DO I=   1, N_LAYER-I_TOP+1                                        GSS3F402.301    
            DO L=1, N_PROFILE                                              GSS3F402.302    
              PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1)                        GSS3F402.303    
            ENDDO                                                          GSS3F402.304    
         ENDDO                                                             GSS3F402.305    
*ENDIF                                                                     GSS3F402.306    
!                                                                          GSS3F402.307    
      IF (I_FNC.EQ.IP_SCALE_POWER_LAW) THEN                                RSCNT3A.108    
!                                                                          GSS3F402.308    
         DO I=   1, N_LAYER-I_TOP+1                                        GSS3F402.309    
            DO L=1, N_PROFILE                                              GSS3F402.310    
              TWK(L,I)=T(L, I_TOP+I-1)/T_REFERENCE                         GSS3F402.311    
            END DO                                                         GSS3F402.312    
         END DO                                                            GSS3F402.313    
*IF DEF,VECTLIB                                                            PXVECTLB.131    
         call rtor_v(n_input,twk,sp2,twk)                                  GSS3F402.315    
*ELSE                                                                      GSS3F402.316    
         DO I=   1, N_LAYER-I_TOP+1                                        GSS3F402.317    
            DO L=1, N_PROFILE                                              GSS3F402.318    
              TWK(L,I)=TWK(L,I)**SCALE_PARAMETER(2)                        GSS3F402.319    
            ENDDO                                                          GSS3F402.320    
         ENDDO                                                             GSS3F402.321    
*ENDIF                                                                     GSS3F402.322    
!                                                                          GSS3F402.323    
         DO I=I_TOP, N_LAYER                                               RSCNT3A.109    
            DO L=1, N_PROFILE                                              RSCNT3A.110    
               AMOUNT_CONTINUUM(L, I)                                      RSCNT3A.111    
     &                       =PWK(L,I-I_TOP+1)*TWK(L,I-I_TOP+1)            GSS3F402.324    
            ENDDO                                                          RSCNT3A.114    
         ENDDO                                                             RSCNT3A.115    
      ELSE IF(I_FNC.EQ.IP_SCALE_POWER_QUAD) THEN                           RSCNT3A.116    
         DO I=I_TOP, N_LAYER                                               RSCNT3A.117    
            DO L=1, N_PROFILE                                              RSCNT3A.118    
               AMOUNT_CONTINUUM(L, I)                                      RSCNT3A.119    
     &            =PWK(L,I-I_TOP+1)                                        GSS3F402.325    
     &            *(1.0E+00+SCALE_PARAMETER(2)*(T(L, I)                    RSCNT3A.121    
     &            /T_REFERENCE-1.0E+00)                                    RSCNT3A.122    
     &            +SCALE_PARAMETER(3)*(T(L, I)                             RSCNT3A.123    
     &            /T_REFERENCE-1.0E+00)**2)                                RSCNT3A.124    
            ENDDO                                                          RSCNT3A.125    
         ENDDO                                                             RSCNT3A.126    
      ENDIF                                                                RSCNT3A.127    
!                                                                          RSCNT3A.128    
      IF (L_LAYER) THEN                                                    RSCNT3A.129    
         IF (I_CONTINUUM.EQ.IP_SELF_CONTINUUM) THEN                        RSCNT3A.130    
            DO I=1, N_LAYER                                                RSCNT3A.131    
               DO L=1, N_PROFILE                                           RSCNT3A.132    
                  AMOUNT_CONTINUUM(L, I)=AMOUNT_CONTINUUM(L, I)            RSCNT3A.133    
     &               *MOLAR_DENSITY_WATER(L, I)*WATER_FRAC(L, I)           RSCNT3A.134    
               ENDDO                                                       RSCNT3A.135    
            ENDDO                                                          RSCNT3A.136    
         ELSE IF (I_CONTINUUM.EQ.IP_FRN_CONTINUUM) THEN                    RSCNT3A.137    
            DO I=1, N_LAYER                                                RSCNT3A.138    
               DO L=1, N_PROFILE                                           RSCNT3A.139    
                  AMOUNT_CONTINUUM(L, I)=AMOUNT_CONTINUUM(L, I)            RSCNT3A.140    
     &               *MOLAR_DENSITY_FRN(L, I)*WATER_FRAC(L, I)             RSCNT3A.141    
               ENDDO                                                       RSCNT3A.142    
            ENDDO                                                          RSCNT3A.143    
         ELSE IF (I_CONTINUUM.EQ.IP_N2_CONTINUUM) THEN                     RSCNT3A.144    
            DO I=1, N_LAYER                                                RSCNT3A.145    
               DO L=1, N_PROFILE                                           RSCNT3A.146    
                  AMOUNT_CONTINUUM(L, I)=AMOUNT_CONTINUUM(L, I)            RSCNT3A.147    
     &               *N2_MASS_FRAC*DENSITY(L, I)                           RSCNT3A.148    
               ENDDO                                                       RSCNT3A.149    
            ENDDO                                                          RSCNT3A.150    
         ENDIF                                                             RSCNT3A.151    
      ELSE                                                                 RSCNT3A.152    
!        IF VALUES ARE GIVEN ON LEVELS WE NOW INTERPOLATE TO AVERAGES      RSCNT3A.153    
!        ACROSS THE LAYER.                                                 RSCNT3A.154    
         IF (I_CONTINUUM.EQ.IP_SELF_CONTINUUM) THEN                        RSCNT3A.155    
            DO I=N_LAYER, 1, -1                                            RSCNT3A.156    
               DO L=1, N_PROFILE                                           RSCNT3A.157    
                  AMOUNT_CONTINUUM(L, I)=0.5E+00                           RSCNT3A.158    
     &               *(AMOUNT_CONTINUUM(L, I)                              RSCNT3A.159    
     &               *MOLAR_DENSITY_WATER(L, I)*WATER_FRAC(L, I)           RSCNT3A.160    
     &               +AMOUNT_CONTINUUM(L, I-1)                             RSCNT3A.161    
     &               *MOLAR_DENSITY_WATER(L, I-1)*WATER_FRAC(L, I-1))      RSCNT3A.162    
               ENDDO                                                       RSCNT3A.163    
            ENDDO                                                          RSCNT3A.164    
         ELSE IF (I_CONTINUUM.EQ.IP_FRN_CONTINUUM) THEN                    RSCNT3A.165    
            DO I=N_LAYER, 1, -1                                            RSCNT3A.166    
               DO L=1, N_PROFILE                                           RSCNT3A.167    
                  AMOUNT_CONTINUUM(L, I)=0.5E+00                           RSCNT3A.168    
     &               *(AMOUNT_CONTINUUM(L, I)                              RSCNT3A.169    
     &               *MOLAR_DENSITY_FRN(L, I)*WATER_FRAC(L, I)             RSCNT3A.170    
     &               +AMOUNT_CONTINUUM(L, I-1)                             RSCNT3A.171    
     &               *MOLAR_DENSITY_FRN(L, I-1)*WATER_FRAC(L, I-1))        RSCNT3A.172    
               ENDDO                                                       RSCNT3A.173    
            ENDDO                                                          RSCNT3A.174    
         ELSE IF (I_CONTINUUM.EQ.IP_N2_CONTINUUM) THEN                     RSCNT3A.175    
            DO I=N_LAYER, 1, -1                                            RSCNT3A.176    
               DO L=1, N_PROFILE                                           RSCNT3A.177    
                  AMOUNT_CONTINUUM(L, I)=0.5E+00                           RSCNT3A.178    
     &               *(AMOUNT_CONTINUUM(L, I)                              RSCNT3A.179    
     &               *N2_MASS_FRAC*DENSITY(L, I)                           RSCNT3A.180    
     &               +AMOUNT_CONTINUUM(L, I-1)                             RSCNT3A.181    
     &               *N2_MASS_FRAC*DENSITY(L, I-1))                        RSCNT3A.182    
               ENDDO                                                       RSCNT3A.183    
            ENDDO                                                          RSCNT3A.184    
         ENDIF                                                             RSCNT3A.185    
      ENDIF                                                                RSCNT3A.186    
!                                                                          RSCNT3A.187    
!                                                                          RSCNT3A.188    
      RETURN                                                               RSCNT3A.189    
      END                                                                  RSCNT3A.190    
*ENDIF DEF,A01_3A,OR,DEF,A02_3A                                            RSCNT3A.191    
*ENDIF DEF,A70_1A,OR,DEF,A70_1B                                            APB4F405.72