C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.            RAD_ALL.18445 
C                                                                                  RAD_ALL.18446 
C Use, duplication or disclosure of this code is subject to the                    RAD_ALL.18447 
C restrictions as set forth in the contract.                                       RAD_ALL.18448 
C                                                                                  RAD_ALL.18449 
C                Meteorological Office                                             RAD_ALL.18450 
C                London Road                                                       RAD_ALL.18451 
C                BRACKNELL                                                         RAD_ALL.18452 
C                Berkshire UK                                                      RAD_ALL.18453 
C                RG12 2SZ                                                          RAD_ALL.18454 
C                                                                                  RAD_ALL.18455 
C If no contract has been raised with this copy of the code, the use,              RAD_ALL.18456 
C duplication or disclosure of it is strictly prohibited.  Permission              RAD_ALL.18457 
C to do so must first be obtained in writing from the Head of Numerical            RAD_ALL.18458 
C Modelling at the above address.                                                  RAD_ALL.18459 
C ******************************COPYRIGHT******************************            RAD_ALL.18460 
C                                                                                  RAD_ALL.18461 
!+ Subroutine to scale amounts of absorbers.                                       RAD_ALL.18462 
!                                                                                  RAD_ALL.18463 
! Method:                                                                          RAD_ALL.18464 
!       The mixing ratio is multiplied by a factor determined                      RAD_ALL.18465 
!       by the type of scaling selected.                                           RAD_ALL.18466 
!                                                                                  RAD_ALL.18467 
!                                                                                  RAD_ALL.18468 
! Current Owner of Code: J. M. Edwards                                             RAD_ALL.18469 
!                                                                                  RAD_ALL.18470 
! History:                                                                         RAD_ALL.18471 
!       Version         Date                    Comment                            RAD_ALL.18472 
!       4.0             27-07-95                Original Code                      RAD_ALL.18473 
!                                               (J. M. Edwards)                    RAD_ALL.18474 
!       4.1             03-05-96                Range of scaling                   RAD_ALL.18475 
!                                               function with implicit             RAD_ALL.18476 
!                                               Doppler term set to                RAD_ALL.18477 
!                                               begin at I_TOP.                    RAD_ALL.18478 
!                                               (J. M. Edwards)                    RAD_ALL.18479 
!       4.2             Oct. 96     T3E migration: HF functions                    RAD_ALL.18480 
!                                   replaced by T3E vec_lib function               RAD_ALL.18481 
!                                   rtor_v      (S.J.Swarbrick)                    RAD_ALL.18482 
!                                                                                  RAD_ALL.18483 
! Description of Code:                                                             RAD_ALL.18484 
!   FORTRAN 77  with extensions listed in documentation.                           RAD_ALL.18485 
!                                                                                  RAD_ALL.18486 
!- ---------------------------------------------------------------------           RAD_ALL.18487 
      SUBROUTINE SCALE_ABSORB(IERR, N_PROFILE, N_LAYER                             RAD_ALL.18488 
     &   , GAS_MIX_RATIO, P, T, L_LAYER, I_TOP                                     RAD_ALL.18489 
     &   , GAS_FRAC_RESCALED                                                       RAD_ALL.18490 
     &   , I_FNC, P_REFERENCE, T_REFERENCE, SCALE_PARAMETER                        RAD_ALL.18491 
     &   , L_DOPPLER, DOPPLER_CORRECTION                                           RAD_ALL.18492 
     &   , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC                                   RAD_ALL.18493 
     &   , NPD_SCALE_VARIABLE                                                      RAD_ALL.18494 
     &   )                                                                         RAD_ALL.18495 
!                                                                                  RAD_ALL.18496 
!                                                                                  RAD_ALL.18497 
      IMPLICIT NONE                                                                RAD_ALL.18498 
!                                                                                  RAD_ALL.18499 
!                                                                                  RAD_ALL.18500 
!     SIZES OF DUMMY ARRAYS.                                                       RAD_ALL.18501 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.18502 
     &     NPD_PROFILE                                                             RAD_ALL.18503 
!             MAXIMUM NUMBER OF PROFILES                                           RAD_ALL.18504 
     &   , NPD_LAYER                                                               RAD_ALL.18505 
!             MAXIMUM NUMBER OF LAYERS                                             RAD_ALL.18506 
     &   , NPD_SCALE_FNC                                                           RAD_ALL.18507 
!             NUMBER OF SCALING FUNCTIONS                                          RAD_ALL.18508 
     &   , NPD_SCALE_VARIABLE                                                      RAD_ALL.18509 
!             MAX. NUMBER OF SCALING VARIABLES                                     RAD_ALL.18510 
!                                                                                  RAD_ALL.18511 
!     INCLUDE COMDECKS.                                                            RAD_ALL.18512 
!     ------------------------------------------------------------------           STDIO3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       STDIO3A.3     
!                                                                                  STDIO3A.4     
!     MODULE TO SET UNIT NUMBERS FOR STANDARD I/O.                                 STDIO3A.5     
!                                                                                  STDIO3A.6     
      INTEGER                                                                      STDIO3A.7     
     &     IU_STDIN                                                                STDIO3A.8     
!             UNIT NUMBER FOR STANDARD INPUT                                       STDIO3A.9     
     &   , IU_STDOUT                                                               STDIO3A.10    
!             UNIT NUMBER FOR STANDARD OUTPUT                                      STDIO3A.11    
     *   , IU_ERR                                                                  STDIO3A.12    
!             UNIT NUMBER FOR ERROR MESSAGES                                       STDIO3A.13    
!                                                                                  STDIO3A.14    
      PARAMETER(                                                                   STDIO3A.15    
     &     IU_STDIN=5                                                              STDIO3A.16    
     &   , IU_STDOUT=6                                                             STDIO3A.17    
     *   , IU_ERR=6                                                                STDIO3A.18    
     &   )                                                                         STDIO3A.19    
!                                                                                  STDIO3A.20    
!     ------------------------------------------------------------------           STDIO3A.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    
!     ------------------------------------------------------------------           ERROR3A.2     
!     COMDECK FOR TWO-STREAM RADIATION CODE.                                       ERROR3A.3     
!                                                                                  ERROR3A.4     
!     MODULE TO SET ERROR FLAGS IN THE RADIATION CODE.                             ERROR3A.5     
!                                                                                  ERROR3A.6     
      INTEGER                                                                      ERROR3A.7     
     &     I_NORMAL                                                                ERROR3A.8     
!             ERROR FREE CONDITION                                                 ERROR3A.9     
     &   , I_ERR_FATAL                                                             ERROR3A.10    
!             FATAL ERROR: IMMEDIATE RETURN                                        ERROR3A.11    
     &   , I_ABORT_CALCULATION                                                     ERROR3A.12    
!             CALCULATION ABORTED                                                  ERROR3A.13    
     &   , I_MISSING_DATA                                                          ERROR3A.14    
!             MISSING DATA ERROR: CONDITIONAL                                      ERROR3A.15    
     &   , I_ERR_IO                                                                ERROR3A.16    
!             I/O ERROR                                                            ERROR3A.17    
     &   , I_ERR_RANGE                                                             ERROR3A.18    
!             INTERPOLATION RANGE ERROR                                            ERROR3A.19    
     &   , I_ERR_EXIST                                                             ERROR3A.20    
!             EXISTENCE ERROR                                                      ERROR3A.21    
!                                                                                  ERROR3A.22    
      PARAMETER(                                                                   ERROR3A.23    
     &     I_NORMAL=0                                                              ERROR3A.24    
     &   , I_ERR_FATAL=1                                                           ERROR3A.25    
     &   , I_ABORT_CALCULATION=2                                                   ERROR3A.26    
     &   , I_MISSING_DATA=3                                                        ERROR3A.27    
     &   , I_ERR_IO=4                                                              ERROR3A.28    
     &   , I_ERR_RANGE=5                                                           ERROR3A.29    
     &   , I_ERR_EXIST=6                                                           ERROR3A.30    
     &   )                                                                         ERROR3A.31    
!                                                                                  ERROR3A.32    
!     ------------------------------------------------------------------           ERROR3A.33    
!                                                                                  RAD_ALL.18516 
!     DUMMY ARGUMENTS.                                                             RAD_ALL.18517 
      INTEGER   !, INTENT(OUT)                                                     RAD_ALL.18518 
     &     IERR                                                                    RAD_ALL.18519 
!             ERROR FLAG                                                           RAD_ALL.18520 
      INTEGER   !, INTENT(IN)                                                      RAD_ALL.18521 
     &     N_PROFILE                                                               RAD_ALL.18522 
!             NUMBER OF PROFILES                                                   RAD_ALL.18523 
     &   , N_LAYER                                                                 RAD_ALL.18524 
!             NUMBER OF LAYERS                                                     RAD_ALL.18525 
     &   , I_FNC                                                                   RAD_ALL.18526 
!             TYPE OF SCALING FUNCTION                                             RAD_ALL.18527 
     &   , I_TOP                                                                   RAD_ALL.18528 
!             UPPERMOST INDEX FOR SCALING (THIS WILL BE 1 FOR FIELDS               RAD_ALL.18529 
!             GIVEN IN LAYERS, AS IN THE UNIFIED MODEL, OR 0 FOR                   RAD_ALL.18530 
!             FIELDS GIVEN AT THE BOUNDARIES OF LAYERS)                            RAD_ALL.18531 
      LOGICAL   !, INTENT(IN)                                                      RAD_ALL.18532 
     &     L_LAYER                                                                 RAD_ALL.18533 
!             DATA SPECIFIED IN LAYERS                                             RAD_ALL.18534 
     &   , L_DOPPLER                                                               RAD_ALL.18535 
!             FLAG FOR DOPPLER TERM                                                RAD_ALL.18536 
      REAL      !, INTENT(IN)                                                      RAD_ALL.18537 
     &     GAS_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER)                                RAD_ALL.18538 
!             MASS MIXING RATIO OF GAS                                             RAD_ALL.18539 
     &   , P(NPD_PROFILE, 0: NPD_LAYER)                                            RAD_ALL.18540 
!             PRESSURE                                                             RAD_ALL.18541 
     &   , T(NPD_PROFILE, 0: NPD_LAYER)                                            RAD_ALL.18542 
!             TEMPERATURE                                                          RAD_ALL.18543 
     &   , P_REFERENCE                                                             RAD_ALL.18544 
!             REFERENCE PRESSURE                                                   RAD_ALL.18545 
     &   , T_REFERENCE                                                             RAD_ALL.18546 
!             REFERENCE TEMPERATURE                                                RAD_ALL.18547 
     &   , SCALE_PARAMETER(NPD_SCALE_VARIABLE)                                     RAD_ALL.18548 
!             SCALING PARAMTERS                                                    RAD_ALL.18549 
     &   , DOPPLER_CORRECTION                                                      RAD_ALL.18550 
!             DOPPLER-BROADENING CORRECTION                                        RAD_ALL.18551 
      REAL      !, INTENT(OUT)                                                     RAD_ALL.18552 
     &     GAS_FRAC_RESCALED(NPD_PROFILE, 0: NPD_LAYER)                            RAD_ALL.18553 
!             MASS FRACTION OF GAS                                                 RAD_ALL.18554 
!                                                                                  RAD_ALL.18555 
!     LOCAL VARIABLES.                                                             RAD_ALL.18556 
      INTEGER                                                                      RAD_ALL.18557 
     &     L                                                                       RAD_ALL.18558 
!             LOOP VARIABLE                                                        RAD_ALL.18559 
     &   , I                                                                       RAD_ALL.18560 
!             LOOP VARIABLE                                                        RAD_ALL.18561 
      REAL                                                                         RAD_ALL.18562 
     &     PRESSURE_OFFSET                                                         RAD_ALL.18563 
!             OFFSET TO PRESSURE                                                   RAD_ALL.18564 
      REAL    PWK(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                          RAD_ALL.18565 
      REAL    TWK(N_PROFILE,N_LAYER-I_TOP+1)  ! Workspace                          RAD_ALL.18566 
!                                                                                  RAD_ALL.18572 
!     SET THE OFFSET TO THE PRESSURE FOR THE DOPPLER CORRECTION.                   RAD_ALL.18573 
      IF (L_DOPPLER) THEN                                                          RAD_ALL.18574 
         PRESSURE_OFFSET=DOPPLER_CORRECTION                                        RAD_ALL.18575 
      ELSE                                                                         RAD_ALL.18576 
         PRESSURE_OFFSET=0.0E+00                                                   RAD_ALL.18577 
      ENDIF                                                                        RAD_ALL.18578 
!                                                                                  RAD_ALL.18579 
!     THE ARRAY GAS_FRAC_RESCALED IS USED INITIALLY TO HOLD ONLY THE               RAD_ALL.18580 
!     SCALING FUNCTIONS, AND ONLY LATER IS IT MULTIPLIED BY THE                    RAD_ALL.18581 
!     MIXING RATIOS                                                                RAD_ALL.18582 
!                                                                                  RAD_ALL.18592 
      IF (I_FNC.EQ.IP_SCALE_POWER_LAW) THEN                                        RAD_ALL.18593 
!                                                                                  RAD_ALL.18594 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.18595 
            DO L=1, N_PROFILE                                                      RAD_ALL.18596 
              PWK(L,I)=(P(L,I_TOP+I-1)+PRESSURE_OFFSET)                            RAD_ALL.18597 
     &                       /(P_REFERENCE+PRESSURE_OFFSET)                        RAD_ALL.18598 
              TWK(L,I)=T(L,I_TOP+I-1)/T_REFERENCE                                  RAD_ALL.18599 
            END DO                                                                 RAD_ALL.18600 
         END DO                                                                    RAD_ALL.18601 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.18606 
            DO L=1, N_PROFILE                                                      RAD_ALL.18607 
              PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1)                                RAD_ALL.18608 
              TWK(L,I)=TWK(L,I)**SCALE_PARAMETER(2)                                RAD_ALL.18609 
            ENDDO                                                                  RAD_ALL.18610 
         ENDDO                                                                     RAD_ALL.18611 
!                                                                                  RAD_ALL.18613 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.18614 
            DO L=1, N_PROFILE                                                      RAD_ALL.18615 
               GAS_FRAC_RESCALED(L, I)                                             RAD_ALL.18616 
     &                       =PWK(L,I-I_TOP+1)*TWK(L,I-I_TOP+1)                    RAD_ALL.18617 
            ENDDO                                                                  RAD_ALL.18618 
         ENDDO                                                                     RAD_ALL.18619 
      ELSE IF (I_FNC.EQ.IP_SCALE_FNC_NULL) THEN                                    RAD_ALL.18620 
         RETURN                                                                    RAD_ALL.18621 
      ELSE IF (I_FNC.EQ.IP_SCALE_POWER_QUAD) THEN                                  RAD_ALL.18622 
!                                                                                  RAD_ALL.18623 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.18624 
            DO L=1, N_PROFILE                                                      RAD_ALL.18625 
              PWK(L,I)=(P(L,I_TOP+I-1)+PRESSURE_OFFSET)                            RAD_ALL.18626 
     &                       /(P_REFERENCE+PRESSURE_OFFSET)                        RAD_ALL.18627 
            END DO                                                                 RAD_ALL.18628 
         END DO                                                                    RAD_ALL.18629 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.18633 
            DO L=1, N_PROFILE                                                      RAD_ALL.18634 
              PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1)                                RAD_ALL.18635 
            ENDDO                                                                  RAD_ALL.18636 
         ENDDO                                                                     RAD_ALL.18637 
!                                                                                  RAD_ALL.18639 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.18640 
            DO L=1, N_PROFILE                                                      RAD_ALL.18641 
               GAS_FRAC_RESCALED(L, I)=PWK(L,I-I_TOP+1)*                           RAD_ALL.18642 
     &    (1.0E+00+SCALE_PARAMETER(2)*(T(L, I)/T_REFERENCE-1.0E+00)                RAD_ALL.18643 
     &            +SCALE_PARAMETER(3)*(T(L, I)/T_REFERENCE-1.0E+00)**2)            RAD_ALL.18644 
            ENDDO                                                                  RAD_ALL.18645 
         ENDDO                                                                     RAD_ALL.18646 
      ELSE IF (I_FNC.EQ.IP_SCALE_DOPPLER_QUAD) THEN                                RAD_ALL.18647 
!        THERE IS NO DOPPLER TERM HERE SINCE IT IS IMPLICITLY INCLUDED             RAD_ALL.18648 
!        IN THE SCALING.                                                           RAD_ALL.18649 
!                                                                                  RAD_ALL.18650 
         DO I=   1, N_LAYER-I_TOP+1                                                RAD_ALL.18651 
            DO L=1, N_PROFILE                                                      RAD_ALL.18652 
              PWK(L,I)=(P(L,I_TOP+I-1)+SCALE_PARAMETER(2))                         RAD_ALL.18653 
     &                       /(P_REFERENCE+SCALE_PARAMETER(2))                     RAD_ALL.18654 
            END DO                                                                 RAD_ALL.18655 
         END DO                                                                    RAD_ALL.18656 
         DO I=1,N_LAYER-I_TOP+1                                                    RAD_ALL.18660 
            DO L=1, N_PROFILE                                                      RAD_ALL.18661 
              PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1)                                RAD_ALL.18662 
            ENDDO                                                                  RAD_ALL.18663 
         ENDDO                                                                     RAD_ALL.18664 
!                                                                                  RAD_ALL.18666 
         DO I=I_TOP, N_LAYER                                                       RAD_ALL.18667 
            DO L=1, N_PROFILE                                                      RAD_ALL.18668 
               GAS_FRAC_RESCALED(L, I)=PWK(L,I-I_TOP+1)                            RAD_ALL.18669 
     &            *(1.0E+00                                                        RAD_ALL.18670 
     &            +SCALE_PARAMETER(3)*(T(L, I)/T_REFERENCE-1.0E+00)                RAD_ALL.18671 
     &            +SCALE_PARAMETER(4)*(T(L, I)/T_REFERENCE-1.0E+00)**2)            RAD_ALL.18672 
            ENDDO                                                                  RAD_ALL.18673 
         ENDDO                                                                     RAD_ALL.18674 
      ELSE                                                                         RAD_ALL.18675 
         WRITE(IU_ERR, '(/A)')                                                     RAD_ALL.18676 
     &      '*** ERROR: AN ILLEGAL TYPE OF SCALING HAS BEEN GIVEN.'                RAD_ALL.18677 
         IERR=I_ERR_FATAL                                                          RAD_ALL.18678 
         RETURN                                                                    RAD_ALL.18679 
      ENDIF                                                                        RAD_ALL.18680 
!                                                                                  RAD_ALL.18681 
!     MULTIPLY BY THE MIXING RATIO AND LIMIT NEGATIVE SCALINGS.                    RAD_ALL.18682 
      IF (L_LAYER) THEN                                                            RAD_ALL.18683 
         DO I=N_LAYER, 1, -1                                                       RAD_ALL.18684 
            DO L=1, N_PROFILE                                                      RAD_ALL.18685 
               GAS_FRAC_RESCALED(L, I)=MAX(REAL(0.0E+00)                           RAD_ALL.18686 
     &            , GAS_FRAC_RESCALED(L, I)*GAS_MIX_RATIO(L, I))                   RAD_ALL.18687 
            ENDDO                                                                  RAD_ALL.18688 
         ENDDO                                                                     RAD_ALL.18689 
      ELSE                                                                         RAD_ALL.18690 
!        CONVERT TO VALUES IN LAYERS.                                              RAD_ALL.18691 
         DO I=N_LAYER, 1, -1                                                       RAD_ALL.18692 
            DO L=1, N_PROFILE                                                      RAD_ALL.18693 
               GAS_FRAC_RESCALED(L, I)                                             RAD_ALL.18694 
     &            =0.5E+00*(GAS_FRAC_RESCALED(L, I-1)                              RAD_ALL.18695 
     &            *GAS_MIX_RATIO(L, I-1)                                           RAD_ALL.18696 
     &            +GAS_FRAC_RESCALED(L, I)*GAS_MIX_RATIO(L, I))                    RAD_ALL.18697 
               GAS_FRAC_RESCALED(L, I)                                             RAD_ALL.18698 
     &            =MAX(REAL(0.0E+00), GAS_FRAC_RESCALED(L, I))                     RAD_ALL.18699 
            ENDDO                                                                  RAD_ALL.18700 
         ENDDO                                                                     RAD_ALL.18701 
      ENDIF                                                                        RAD_ALL.18702 
!                                                                                  RAD_ALL.18703 
!                                                                                  RAD_ALL.18704 
      RETURN                                                                       RAD_ALL.18705 
      END  
