*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