C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.14194 
C                                                                                  RAD_ALL.14195 
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.14196 
C restrictions as set forth in the contract.                                       RAD_ALL.14197 
C                                                                                  RAD_ALL.14198 
C                Meteorological Office                                             RAD_ALL.14199 
C                London Road                                                       RAD_ALL.14200 
C                BRACKNELL                                                         RAD_ALL.14201 
C                Berkshire UK                                                      RAD_ALL.14202 
C                RG12 2SZ                                                          RAD_ALL.14203 
C                                                                                  RAD_ALL.14204 
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.14205 
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.14206 
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.14207 
C Modelling at the above address.                                                  RAD_ALL.14208 
C ******************************COPYRIGHT******************************            RAD_ALL.14209 
C                                                                                  RAD_ALL.14210 
!+ Subroutine to apply a path-length scaling to the continuum.                     RAD_ALL.14211 
!                                                                                  RAD_ALL.14212 
! Method:                                                                          RAD_ALL.14213 
!       The scaling function is calculated. This is multpiled by a                 RAD_ALL.14214 
!       suitable "amount" of continuum incorporating a broadening                  RAD_ALL.14215 
!       density.                                                                   RAD_ALL.14216 
!                                                                                  RAD_ALL.14217 
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.14218 
!                                                                                  RAD_ALL.14219 
! History:                                                                         RAD_ALL.14220 
!       Version         Date                    Comment                            RAD_ALL.14221 
!       4.0             27-07-95                Original Code                      RAD_ALL.14222 
!                                               (J. M. Edwards)                    RAD_ALL.14223 
!       4.2             Oct. 96     T3E migration: HF functions                    RAD_ALL.14224 
!                                   replaced by T3E vec_lib function               RAD_ALL.14225 
!                                   rtor_v      (S.J.Swarbrick)                    RAD_ALL.14226 
!                                                                                  RAD_ALL.14227 
! Description of Code:                                                             RAD_ALL.14228 
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.14229 
!                                                                                  RAD_ALL.14230 
!- ---------------------------------------------------------------------           RAD_ALL.14231 
      SUBROUTINE RESCALE_CONTINUUM(N_PROFILE, N_LAYER, I_CONTINUUM                 RAD_ALL.14232 
     &   , P, T, L_LAYER, I_TOP                                                    RAD_ALL.14233 
     &   , DENSITY, MOLAR_DENSITY_WATER, MOLAR_DENSITY_FRN                         RAD_ALL.14234 
     &   , WATER_FRAC                                                              RAD_ALL.14235 
     &   , AMOUNT_CONTINUUM                                                        RAD_ALL.14236 
     &   , I_FNC                                                                   RAD_ALL.14237 
     &   , P_REFERENCE, T_REFERENCE, SCALE_PARAMETER                               RAD_ALL.14238 
     &   , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC                                   RAD_ALL.14239 
     &   , NPD_SCALE_VARIABLE                                                      RAD_ALL.14240 
     &   )                                                                         RAD_ALL.14241 
!                                                                                  RAD_ALL.14242 
!                                                                                  RAD_ALL.14243 
      IMPLICIT NONE                                                                RAD_ALL.14244 
!                                                                                  RAD_ALL.14245 
!                                                                                  RAD_ALL.14246 
!     SIZES OF DUMMY ARRAYS.                                                       RAD_ALL.14247 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.14248 
     &     NPD_PROFILE                                                             RAD_ALL.14249 
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.14250 
     &   , NPD_LAYER                                                               RAD_ALL.14251 
!             MAXIMUM NUMBER OF LAYERS                                             RAD_ALL.14252 
     &   , NPD_SCALE_FNC                                                           RAD_ALL.14253 
!             NUMBER OF SCALING FUNCTIONS                                          RAD_ALL.14254 
     &   , NPD_SCALE_VARIABLE                                                      RAD_ALL.14255 
!             MAX. NUMBER OF SCALING VARIABLES                                     RAD_ALL.14256 
!                                                                                  RAD_ALL.14257 
!     INCLUDE COMDECKS                                                             RAD_ALL.14258 
!     ------------------------------------------------------------------           PHYCN03A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       PHYCN03A.3     
!                                                                                  PHYCN03A.4     
!     MODULE SETTING PHYSICAL CONSTANTS.                                           PHYCN03A.5     
!                                                                                  PHYCN03A.6     
      REAL                                                                         PHYCN03A.7     
     &     MOL_WEIGHT_AIR                                                          PHYCN03A.8     
!             MOLAR WEIGHT OF DRY AIR                                              PHYCN03A.9     
     &   , N2_MASS_FRAC                                                            PHYCN03A.10    
!             MASS FRACTION OF NITROGEN                                            PHYCN03A.11    
!                                                                                  PHYCN03A.12    
      PARAMETER(                                                                   PHYCN03A.13    
     &     MOL_WEIGHT_AIR=28.966E-3                                                PHYCN03A.14    
     &   , N2_MASS_FRAC=0.781E+00                                                  PHYCN03A.15    
     &   )                                                                         PHYCN03A.16    
!                                                                                  PHYCN03A.17    
!     ------------------------------------------------------------------           PHYCN03A.18    
!     ------------------------------------------------------------------           CNTUUM3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       CNTUUM3A.3     
!                                                                                  CNTUUM3A.4     
!     MODULE SETTING PARAMETERS FOR CONTINUUM DATA.                                CNTUUM3A.5     
!                                                                                  CNTUUM3A.6     
      INTEGER                                                                      CNTUUM3A.7     
     &     IP_SELF_CONTINUUM                                                       CNTUUM3A.8     
!             SELF-BROADENED CONTINUUM                                             CNTUUM3A.9     
     &   , IP_FRN_CONTINUUM                                                        CNTUUM3A.10    
!             FOREIGN-BROADENED CONTINUUM                                          CNTUUM3A.11    
     &   , IP_N2_CONTINUUM                                                         CNTUUM3A.12    
!             NITROGEN CONTINUUM                                                   CNTUUM3A.13    
!                                                                                  CNTUUM3A.14    
      PARAMETER(                                                                   CNTUUM3A.15    
     &     IP_SELF_CONTINUUM=1                                                     CNTUUM3A.16    
     &   , IP_FRN_CONTINUUM=2                                                      CNTUUM3A.17    
     &   , IP_N2_CONTINUUM=3                                                       CNTUUM3A.18    
     &   )                                                                         CNTUUM3A.19    
!                                                                                  CNTUUM3A.20    
!     ------------------------------------------------------------------           CNTUUM3A.21    
!     ------------------------------------------------------------------           SCLFNC3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       SCLFNC3A.3     
!                                                                                  SCLFNC3A.4     
!     MODULE TO SET TYPES OF SCALING FOR ABSORBER AMOUNTS                          SCLFNC3A.5     
!                                                                                  SCLFNC3A.6     
      INTEGER                                                                      SCLFNC3A.7     
     &     IP_SCALE_FNC_NULL                                                       SCLFNC3A.8     
!             NULL SCALING FUNCTION                                                SCLFNC3A.9     
     &   , IP_SCALE_POWER_LAW                                                      SCLFNC3A.10    
!             POWER LAW SCALING FUNCTION                                           SCLFNC3A.11    
     &   , IP_SCALE_POWER_QUAD                                                     SCLFNC3A.12    
!             POWER LAW FOR P; QUADRATIC FOR T                                     SCLFNC3A.13    
     &   , IP_SCALE_DOPPLER_QUAD                                                   SCLFNC3A.14    
!             POWER LAW FOR P; QUADRATIC FOR T                                     SCLFNC3A.15    
!              WITH IMPLICIT DOPPLER CORRECTION                                    SCLFNC3A.16    
     &   , N_SCALE_VARIABLE(0: NPD_SCALE_FNC)                                      SCLFNC3A.17    
!             NUMBER OF SCALING VARIABLES                                          SCLFNC3A.18    
!                                                                                  SCLFNC3A.19    
      PARAMETER(                                                                   SCLFNC3A.20    
     &     IP_SCALE_FNC_NULL=0                                                     SCLFNC3A.21    
     &   , IP_SCALE_POWER_LAW=1                                                    SCLFNC3A.22    
     &   , IP_SCALE_POWER_QUAD=2                                                   SCLFNC3A.23    
     &   , IP_SCALE_DOPPLER_QUAD=3                                                 SCLFNC3A.24    
     &   )                                                                         SCLFNC3A.25    
!                                                                                  SCLFNC3A.26    
!     -----------------------------------------------------------------            SCLFNC3A.27    
!                                                                                  RAD_ALL.14262 
!     DUMMY ARGUMENTS.                                                             RAD_ALL.14263 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.14264 
     &     N_PROFILE                                                               RAD_ALL.14265 
!             NUMBER OF PROFILES                                                   RAD_ALL.14266 
     &   , N_LAYER                                                                 RAD_ALL.14267 
!             NUMBER OF LAYERS                                                     RAD_ALL.14268 
     &   , I_CONTINUUM                                                             RAD_ALL.14269 
!             CONTINUUM TYPE                                                       RAD_ALL.14270 
     &   , I_FNC                                                                   RAD_ALL.14271 
!             SCALING FUNCTION                                                     RAD_ALL.14272 
     &   , I_TOP                                                                   RAD_ALL.14273 
!             TOP INDEX OF ARRAYS                                                  RAD_ALL.14274 
      LOGICAL   !, INTENT(IN)                                                      RAD_ALL.14275 
     &     L_LAYER                                                                 RAD_ALL.14276 
!             DATA ARE SUPPLIED IN LAYERS                                          RAD_ALL.14277 
      REAL      !, INTENT(IN)                                                      RAD_ALL.14278 
     &     WATER_FRAC(NPD_PROFILE, 0: NPD_LAYER)                                   RAD_ALL.14279 
!             MASS FRACTION OF WATER                                               RAD_ALL.14280 
     &   , P(NPD_PROFILE, 0: NPD_LAYER)                                            RAD_ALL.14281 
!             PRESSURE                                                             RAD_ALL.14282 
     &   , T(NPD_PROFILE, 0: NPD_LAYER)                                            RAD_ALL.14283 
!             TEMPERATURE                                                          RAD_ALL.14284 
     &   , DENSITY(NPD_PROFILE, 0: NPD_LAYER)                                      RAD_ALL.14285 
!             OVERALL DENSITY                                                      RAD_ALL.14286 
     &   , MOLAR_DENSITY_WATER(NPD_PROFILE, 0: NPD_LAYER)                          RAD_ALL.14287 
!             MOLAR DENSITY OF WATER VAPOUR                                        RAD_ALL.14288 
     &   , MOLAR_DENSITY_FRN(NPD_PROFILE, 0: NPD_LAYER)                            RAD_ALL.14289 
!             MOLAR DENSITY OF FOREIGN SPECIES                                     RAD_ALL.14290 
     &   , P_REFERENCE                                                             RAD_ALL.14291 
!             REFERENCE PRESSURE                                                   RAD_ALL.14292 
     &   , T_REFERENCE                                                             RAD_ALL.14293 
!             REFERENCE PRESSURE                                                   RAD_ALL.14294 
     &   , SCALE_PARAMETER(NPD_SCALE_VARIABLE)                                     RAD_ALL.14295 
!             SCALING PARAMTERS                                                    RAD_ALL.14296 
      REAL      !, INTENT(OUT)                                                     RAD_ALL.14297 
     &     AMOUNT_CONTINUUM(NPD_PROFILE, 0: NPD_LAYER)                             RAD_ALL.14298 
!             AMOUNT OF CONTINUUM                                                  RAD_ALL.14299 
!                                                                                  RAD_ALL.14300 
!     LOCAL VARIABLES.                                                             RAD_ALL.14301 
      INTEGER                                                                      RAD_ALL.14302 
     &     L                                                                       RAD_ALL.14303 
!             LOOP VARIABLE                                                        RAD_ALL.14304 
     &   , I                                                                       RAD_ALL.14305 
!             LOOP VARIABLE                                                        RAD_ALL.14306 
      REAL    PWK(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                          RAD_ALL.14307 
      REAL    TWK(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                          RAD_ALL.14308 
!                                                                                  RAD_ALL.14314 
!                                                                                  RAD_ALL.14315 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.14325 
            DO L=1, N_PROFILE                                                      RAD_ALL.14326 
              PWK(L,I)=P(L, I_TOP+I-1)/P_REFERENCE                                 RAD_ALL.14327 
            END DO                                                                 RAD_ALL.14328 
         END DO                                                                    RAD_ALL.14329 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.14333 
            DO L=1, N_PROFILE                                                      RAD_ALL.14334 
              PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1)                                RAD_ALL.14335 
            ENDDO                                                                  RAD_ALL.14336 
         ENDDO                                                                     RAD_ALL.14337 
!                                                                                  RAD_ALL.14339 
      IF (I_FNC.EQ.IP_SCALE_POWER_LAW) THEN                                        RAD_ALL.14340 
!                                                                                  RAD_ALL.14341 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.14342 
            DO L=1, N_PROFILE                                                      RAD_ALL.14343 
              TWK(L,I)=T(L, I_TOP+I-1)/T_REFERENCE                                 RAD_ALL.14344 
            END DO                                                                 RAD_ALL.14345 
         END DO                                                                    RAD_ALL.14346 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.14350 
            DO L=1, N_PROFILE                                                      RAD_ALL.14351 
              TWK(L,I)=TWK(L,I)**SCALE_PARAMETER(2)                                RAD_ALL.14352 
            ENDDO                                                                  RAD_ALL.14353 
         ENDDO                                                                     RAD_ALL.14354 
!                                                                                  RAD_ALL.14356 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.14357 
            DO L=1, N_PROFILE                                                      RAD_ALL.14358 
               AMOUNT_CONTINUUM(L, I)                                              RAD_ALL.14359 
     &                       =PWK(L,I-I_TOP+1)*TWK(L,I-I_TOP+1)                    RAD_ALL.14360 
            ENDDO                                                                  RAD_ALL.14361 
         ENDDO                                                                     RAD_ALL.14362 
      ELSE IF(I_FNC.EQ.IP_SCALE_POWER_QUAD) THEN                                   RAD_ALL.14363 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.14364 
            DO L=1, N_PROFILE                                                      RAD_ALL.14365 
               AMOUNT_CONTINUUM(L, I)                                              RAD_ALL.14366 
     &            =PWK(L,I-I_TOP+1)                                                RAD_ALL.14367 
     &            *(1.0E+00+SCALE_PARAMETER(2)*(T(L, I)                            RAD_ALL.14368 
     &            /T_REFERENCE-1.0E+00)                                            RAD_ALL.14369 
     &            +SCALE_PARAMETER(3)*(T(L, I)                                     RAD_ALL.14370 
     &            /T_REFERENCE-1.0E+00)**2)                                        RAD_ALL.14371 
            ENDDO                                                                  RAD_ALL.14372 
         ENDDO                                                                     RAD_ALL.14373 
      ENDIF                                                                        RAD_ALL.14374 
!                                                                                  RAD_ALL.14375 
      IF (L_LAYER) THEN                                                            RAD_ALL.14376 
         IF (I_CONTINUUM.EQ.IP_SELF_CONTINUUM) THEN                                RAD_ALL.14377 
            DO I=1, N_LAYER                                                        RAD_ALL.14378 
               DO L=1, N_PROFILE                                                   RAD_ALL.14379 
                  AMOUNT_CONTINUUM(L, I)=AMOUNT_CONTINUUM(L, I)                    RAD_ALL.14380 
     &               *MOLAR_DENSITY_WATER(L, I)*WATER_FRAC(L, I)                   RAD_ALL.14381 
               ENDDO                                                               RAD_ALL.14382 
            ENDDO                                                                  RAD_ALL.14383 
         ELSE IF (I_CONTINUUM.EQ.IP_FRN_CONTINUUM) THEN                            RAD_ALL.14384 
            DO I=1, N_LAYER                                                        RAD_ALL.14385 
               DO L=1, N_PROFILE                                                   RAD_ALL.14386 
                  AMOUNT_CONTINUUM(L, I)=AMOUNT_CONTINUUM(L, I)                    RAD_ALL.14387 
     &               *MOLAR_DENSITY_FRN(L, I)*WATER_FRAC(L, I)                     RAD_ALL.14388 
               ENDDO                                                               RAD_ALL.14389 
            ENDDO                                                                  RAD_ALL.14390 
         ELSE IF (I_CONTINUUM.EQ.IP_N2_CONTINUUM) THEN                             RAD_ALL.14391 
            DO I=1, N_LAYER                                                        RAD_ALL.14392 
               DO L=1, N_PROFILE                                                   RAD_ALL.14393 
                  AMOUNT_CONTINUUM(L, I)=AMOUNT_CONTINUUM(L, I)                    RAD_ALL.14394 
     &               *N2_MASS_FRAC*DENSITY(L, I)                                   RAD_ALL.14395 
               ENDDO                                                               RAD_ALL.14396 
            ENDDO                                                                  RAD_ALL.14397 
         ENDIF                                                                     RAD_ALL.14398 
      ELSE                                                                         RAD_ALL.14399 
!        IF VALUES ARE GIVEN ON LEVELS WE NOW INTERPOLATE TO AVERAGES              RAD_ALL.14400 
!        ACROSS THE LAYER.                                                         RAD_ALL.14401 
         IF (I_CONTINUUM.EQ.IP_SELF_CONTINUUM) THEN                                RAD_ALL.14402 
            DO I=N_LAYER, 1, -1                                                    RAD_ALL.14403 
               DO L=1, N_PROFILE                                                   RAD_ALL.14404 
                  AMOUNT_CONTINUUM(L, I)=0.5E+00                                   RAD_ALL.14405 
     &               *(AMOUNT_CONTINUUM(L, I)                                      RAD_ALL.14406 
     &               *MOLAR_DENSITY_WATER(L, I)*WATER_FRAC(L, I)                   RAD_ALL.14407 
     &               +AMOUNT_CONTINUUM(L, I-1)                                     RAD_ALL.14408 
     &               *MOLAR_DENSITY_WATER(L, I-1)*WATER_FRAC(L, I-1))              RAD_ALL.14409 
               ENDDO                                                               RAD_ALL.14410 
            ENDDO                                                                  RAD_ALL.14411 
         ELSE IF (I_CONTINUUM.EQ.IP_FRN_CONTINUUM) THEN                            RAD_ALL.14412 
            DO I=N_LAYER, 1, -1                                                    RAD_ALL.14413 
               DO L=1, N_PROFILE                                                   RAD_ALL.14414 
                  AMOUNT_CONTINUUM(L, I)=0.5E+00                                   RAD_ALL.14415 
     &               *(AMOUNT_CONTINUUM(L, I)                                      RAD_ALL.14416 
     &               *MOLAR_DENSITY_FRN(L, I)*WATER_FRAC(L, I)                     RAD_ALL.14417 
     &               +AMOUNT_CONTINUUM(L, I-1)                                     RAD_ALL.14418 
     &               *MOLAR_DENSITY_FRN(L, I-1)*WATER_FRAC(L, I-1))                RAD_ALL.14419 
               ENDDO                                                               RAD_ALL.14420 
            ENDDO                                                                  RAD_ALL.14421 
         ELSE IF (I_CONTINUUM.EQ.IP_N2_CONTINUUM) THEN                             RAD_ALL.14422 
            DO I=N_LAYER, 1, -1                                                    RAD_ALL.14423 
               DO L=1, N_PROFILE                                                   RAD_ALL.14424 
                  AMOUNT_CONTINUUM(L, I)=0.5E+00                                   RAD_ALL.14425 
     &               *(AMOUNT_CONTINUUM(L, I)                                      RAD_ALL.14426 
     &               *N2_MASS_FRAC*DENSITY(L, I)                                   RAD_ALL.14427 
     &               +AMOUNT_CONTINUUM(L, I-1)                                     RAD_ALL.14428 
     &               *N2_MASS_FRAC*DENSITY(L, I-1))                                RAD_ALL.14429 
               ENDDO                                                               RAD_ALL.14430 
            ENDDO                                                                  RAD_ALL.14431 
         ENDIF                                                                     RAD_ALL.14432 
      ENDIF                                                                        RAD_ALL.14433 
!                                                                                  RAD_ALL.14434 
!                                                                                  RAD_ALL.14435 
      RETURN                                                                       RAD_ALL.14436 
      END 
