SUBROUTINE SCALE_ABSORB(IERR, N_PROFILE, N_LAYER 13SCLAB3B.40
& , GAS_MIX_RATIO, P, T, L_LAYER, I_TOP SCLAB3B.41
& , GAS_FRAC_RESCALED SCLAB3B.42
& , I_FNC, P_REFERENCE, T_REFERENCE, SCALE_PARAMETER SCLAB3B.43
& , L_DOPPLER, DOPPLER_CORRECTION SCLAB3B.44
& , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC SCLAB3B.45
& , NPD_SCALE_VARIABLE SCLAB3B.46
& ) SCLAB3B.47
! SCLAB3B.48
! SCLAB3B.49
IMPLICIT NONE SCLAB3B.50
! SCLAB3B.51
! SCLAB3B.52
! SIZES OF DUMMY ARRAYS. SCLAB3B.53
INTEGER !, INTENT(IN) SCLAB3B.54
& NPD_PROFILE SCLAB3B.55
! MAXIMUM NUMBER OF PROFILES SCLAB3B.56
& , NPD_LAYER SCLAB3B.57
! MAXIMUM NUMBER OF LAYERS SCLAB3B.58
& , NPD_SCALE_FNC SCLAB3B.59
! NUMBER OF SCALING FUNCTIONS SCLAB3B.60
& , NPD_SCALE_VARIABLE SCLAB3B.61
! MAX. NUMBER OF SCALING VARIABLES SCLAB3B.62
! SCLAB3B.63
! INCLUDE COMDECKS. SCLAB3B.64
*CALL STDIO3A 
SCLAB3B.65
*CALL SCLFNC3A SCLAB3B.66
*CALL ERROR3A SCLAB3B.67
! SCLAB3B.68
! DUMMY ARGUMENTS. SCLAB3B.69
INTEGER !, INTENT(OUT) SCLAB3B.70
& IERR SCLAB3B.71
! ERROR FLAG SCLAB3B.72
INTEGER !, INTENT(IN) SCLAB3B.73
& N_PROFILE SCLAB3B.74
! NUMBER OF PROFILES SCLAB3B.75
& , N_LAYER SCLAB3B.76
! NUMBER OF LAYERS SCLAB3B.77
& , I_FNC SCLAB3B.78
! TYPE OF SCALING FUNCTION SCLAB3B.79
& , I_TOP SCLAB3B.80
! UPPERMOST INDEX FOR SCALING (THIS WILL BE 1 FOR FIELDS SCLAB3B.81
! GIVEN IN LAYERS, AS IN THE UNIFIED MODEL, OR 0 FOR SCLAB3B.82
! FIELDS GIVEN AT THE BOUNDARIES OF LAYERS) SCLAB3B.83
LOGICAL !, INTENT(IN) SCLAB3B.84
& L_LAYER SCLAB3B.85
! DATA SPECIFIED IN LAYERS SCLAB3B.86
& , L_DOPPLER SCLAB3B.87
! FLAG FOR DOPPLER TERM SCLAB3B.88
REAL !, INTENT(IN) SCLAB3B.89
& GAS_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER) SCLAB3B.90
! MASS MIXING RATIO OF GAS SCLAB3B.91
& , P(NPD_PROFILE, 0: NPD_LAYER) SCLAB3B.92
! PRESSURE SCLAB3B.93
& , T(NPD_PROFILE, 0: NPD_LAYER) SCLAB3B.94
! TEMPERATURE SCLAB3B.95
& , P_REFERENCE SCLAB3B.96
! REFERENCE PRESSURE SCLAB3B.97
& , T_REFERENCE SCLAB3B.98
! REFERENCE TEMPERATURE SCLAB3B.99
& , SCALE_PARAMETER(NPD_SCALE_VARIABLE) SCLAB3B.100
! SCALING PARAMTERS SCLAB3B.101
& , DOPPLER_CORRECTION SCLAB3B.102
! DOPPLER-BROADENING CORRECTION SCLAB3B.103
REAL !, INTENT(OUT) SCLAB3B.104
& GAS_FRAC_RESCALED(NPD_PROFILE, 0: NPD_LAYER) SCLAB3B.105
! MASS FRACTION OF GAS SCLAB3B.106
! SCLAB3B.107
! LOCAL VARIABLES. SCLAB3B.108
INTEGER SCLAB3B.109
& L SCLAB3B.110
! LOOP VARIABLE SCLAB3B.111
& , I SCLAB3B.112
! LOOP VARIABLE SCLAB3B.113
REAL SCLAB3B.114
& PRESSURE_OFFSET SCLAB3B.115
! OFFSET TO PRESSURE SCLAB3B.116
REAL PWK(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace SCLAB3B.117
REAL TWK(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace SCLAB3B.118
*IF DEF,VECTLIB PXVECTLB.138
REAL SP1(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace SCLAB3B.120
REAL SP2(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace SCLAB3B.121
INTEGER n_input ! No. of inputs for rtor_v function SCLAB3B.122
*ENDIF SCLAB3B.123
REAL TMP, T_INV,P_REF_OFF_INV SCLAB3B.124
SCLAB3B.125
! SCLAB3B.126
! SET THE OFFSET TO THE PRESSURE FOR THE DOPPLER CORRECTION. SCLAB3B.127
IF (L_DOPPLER) THEN SCLAB3B.128
PRESSURE_OFFSET=DOPPLER_CORRECTION SCLAB3B.129
ELSE SCLAB3B.130
PRESSURE_OFFSET=0.0E+00 SCLAB3B.131
ENDIF SCLAB3B.132
SCLAB3B.133
T_INV = 1.0/T_REFERENCE SCLAB3B.134
P_REF_OFF_INV = 1.0/(P_REFERENCE+PRESSURE_OFFSET) SCLAB3B.135
SCLAB3B.136
! THE ARRAY GAS_FRAC_RESCALED IS USED INITIALLY TO HOLD ONLY THE SCLAB3B.137
! SCALING FUNCTIONS, AND ONLY LATER IS IT MULTIPLIED BY THE SCLAB3B.138
! MIXING RATIOS SCLAB3B.139
*IF DEF,VECTLIB PXVECTLB.139
do I=1, N_LAYER-I_TOP+1 SCLAB3B.141
do L=1, N_PROFILE SCLAB3B.142
sp1(L,I)=SCALE_PARAMETER(1) SCLAB3B.143
sp2(L,I)=SCALE_PARAMETER(2) SCLAB3B.144
end do SCLAB3B.145
end do SCLAB3B.146
n_input=(N_LAYER-I_TOP+1)*N_PROFILE SCLAB3B.147
*ENDIF SCLAB3B.148
! SCLAB3B.149
IF (I_FNC.EQ.IP_SCALE_POWER_LAW) THEN SCLAB3B.150
! SCLAB3B.151
IF(L_DOPPLER) THEN SCLAB3B.152
DO I= 1, N_LAYER-I_TOP+1 SCLAB3B.153
DO L=1, N_PROFILE SCLAB3B.154
PWK(L,I)=(P(L,I_TOP+I-1)+PRESSURE_OFFSET) SCLAB3B.155
& *P_REF_OFF_INV SCLAB3B.156
TWK(L,I)=T(L,I_TOP+I-1)*T_INV SCLAB3B.157
END DO SCLAB3B.158
END DO SCLAB3B.159
ELSE SCLAB3B.160
DO I= 1, N_LAYER-I_TOP+1 SCLAB3B.161
DO L=1, N_PROFILE SCLAB3B.162
PWK(L,I)=P(L,I_TOP+I-1) SCLAB3B.163
& *P_REF_OFF_INV SCLAB3B.164
TWK(L,I)=T(L,I_TOP+I-1)*T_INV SCLAB3B.165
END DO SCLAB3B.166
END DO SCLAB3B.167
END IF SCLAB3B.168
*IF DEF,VECTLIB PXVECTLB.140
call rtor_v(n_input,pwk,sp1,pwk) SCLAB3B.170
call rtor_v(n_input,twk,sp2,twk) SCLAB3B.171
*ELSE SCLAB3B.172
DO I= 1, N_LAYER-I_TOP+1 SCLAB3B.173
DO L=1, N_PROFILE SCLAB3B.174
PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1) SCLAB3B.175
TWK(L,I)=TWK(L,I)**SCALE_PARAMETER(2) SCLAB3B.176
ENDDO SCLAB3B.177
ENDDO SCLAB3B.178
*ENDIF SCLAB3B.179
! SCLAB3B.180
DO I=I_TOP, N_LAYER SCLAB3B.181
DO L=1, N_PROFILE SCLAB3B.182
GAS_FRAC_RESCALED(L, I) SCLAB3B.183
& =PWK(L,I-I_TOP+1)*TWK(L,I-I_TOP+1) SCLAB3B.184
ENDDO SCLAB3B.185
ENDDO SCLAB3B.186
ELSE IF (I_FNC.EQ.IP_SCALE_FNC_NULL) THEN SCLAB3B.187
RETURN SCLAB3B.188
ELSE IF (I_FNC.EQ.IP_SCALE_POWER_QUAD) THEN SCLAB3B.189
! SCLAB3B.190
IF(L_DOPPLER) THEN SCLAB3B.191
DO I= 1, N_LAYER-I_TOP+1 SCLAB3B.192
DO L=1, N_PROFILE SCLAB3B.193
PWK(L,I)=(P(L,I_TOP+I-1)+PRESSURE_OFFSET) SCLAB3B.194
& *P_REF_OFF_INV SCLAB3B.195
END DO SCLAB3B.196
END DO SCLAB3B.197
ELSE SCLAB3B.198
DO I= 1, N_LAYER-I_TOP+1 SCLAB3B.199
DO L=1, N_PROFILE SCLAB3B.200
PWK(L,I)=P(L,I_TOP+I-1) SCLAB3B.201
& *P_REF_OFF_INV SCLAB3B.202
END DO SCLAB3B.203
END DO SCLAB3B.204
END IF SCLAB3B.205
*IF DEF,VECTLIB PXVECTLB.141
call rtor_v(n_input,pwk,sp1,pwk) SCLAB3B.207
*ELSE SCLAB3B.208
DO I= 1, N_LAYER-I_TOP+1 SCLAB3B.209
DO L=1, N_PROFILE SCLAB3B.210
PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1) SCLAB3B.211
ENDDO SCLAB3B.212
ENDDO SCLAB3B.213
*ENDIF SCLAB3B.214
! SCLAB3B.215
DO I=I_TOP, N_LAYER SCLAB3B.216
DO L=1, N_PROFILE SCLAB3B.217
TMP = T(L,I)*T_INV - 1.0 SCLAB3B.218
GAS_FRAC_RESCALED(L, I)=PWK(L,I-I_TOP+1)* SCLAB3B.219
& (1.0E+00+TMP*SCALE_PARAMETER(2) SCLAB3B.220
& +SCALE_PARAMETER(3)*TMP*TMP) SCLAB3B.221
ENDDO SCLAB3B.222
ENDDO SCLAB3B.223
ELSE IF (I_FNC.EQ.IP_SCALE_DOPPLER_QUAD) THEN SCLAB3B.224
! THERE IS NO DOPPLER TERM HERE SINCE IT IS IMPLICITLY INCLUDED SCLAB3B.225
! IN THE SCALING. SCLAB3B.226
! SCLAB3B.227
DO I= 1, N_LAYER-I_TOP+1 SCLAB3B.228
DO L=1, N_PROFILE SCLAB3B.229
PWK(L,I)=(P(L,I_TOP+I-1)+SCALE_PARAMETER(2)) SCLAB3B.230
& /(P_REFERENCE+SCALE_PARAMETER(2)) SCLAB3B.231
END DO SCLAB3B.232
END DO SCLAB3B.233
*IF DEF,VECTLIB PXVECTLB.142
call rtor_v(n_input,pwk,sp1,pwk) SCLAB3B.235
*ELSE SCLAB3B.236
DO I=1,N_LAYER-I_TOP+1 SCLAB3B.237
DO L=1, N_PROFILE SCLAB3B.238
PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1) SCLAB3B.239
ENDDO SCLAB3B.240
ENDDO SCLAB3B.241
*ENDIF SCLAB3B.242
! SCLAB3B.243
DO I=I_TOP, N_LAYER SCLAB3B.244
DO L=1, N_PROFILE SCLAB3B.245
TMP = T(L,I)*T_INV - 1.0 SCLAB3B.246
GAS_FRAC_RESCALED(L, I)=PWK(L,I-I_TOP+1) SCLAB3B.247
& *(1.0E+00 SCLAB3B.248
& +TMP*SCALE_PARAMETER(3) SCLAB3B.249
& +SCALE_PARAMETER(4)*TMP*TMP) SCLAB3B.250
ENDDO SCLAB3B.251
ENDDO SCLAB3B.252
ELSE SCLAB3B.253
WRITE(IU_ERR, '(/A)') SCLAB3B.254
& '*** ERROR: AN ILLEGAL TYPE OF SCALING HAS BEEN GIVEN.' SCLAB3B.255
IERR=I_ERR_FATAL SCLAB3B.256
RETURN SCLAB3B.257
ENDIF SCLAB3B.258
! SCLAB3B.259
! MULTIPLY BY THE MIXING RATIO AND LIMIT NEGATIVE SCALINGS. SCLAB3B.260
IF (L_LAYER) THEN SCLAB3B.261
DO I=N_LAYER, 1, -1 SCLAB3B.262
DO L=1, N_PROFILE SCLAB3B.263
GAS_FRAC_RESCALED(L, I)=MAX(REAL(0.0E+00) SCLAB3B.264
& , GAS_FRAC_RESCALED(L, I)*GAS_MIX_RATIO(L, I)) SCLAB3B.265
ENDDO SCLAB3B.266
ENDDO SCLAB3B.267
ELSE SCLAB3B.268
! CONVERT TO VALUES IN LAYERS. SCLAB3B.269
DO I=N_LAYER, 1, -1 SCLAB3B.270
DO L=1, N_PROFILE SCLAB3B.271
GAS_FRAC_RESCALED(L, I) SCLAB3B.272
& =0.5E+00*(GAS_FRAC_RESCALED(L, I-1) SCLAB3B.273
& *GAS_MIX_RATIO(L, I-1) SCLAB3B.274
& +GAS_FRAC_RESCALED(L, I)*GAS_MIX_RATIO(L, I)) SCLAB3B.275
GAS_FRAC_RESCALED(L, I) SCLAB3B.276
& =MAX(REAL(0.0E+00), GAS_FRAC_RESCALED(L, I)) SCLAB3B.277
ENDDO SCLAB3B.278
ENDDO SCLAB3B.279
ENDIF SCLAB3B.280
! SCLAB3B.281
! SCLAB3B.282
RETURN SCLAB3B.283
END SCLAB3B.284
*ENDIF DEF,A01_3A,OR,DEF,A02_3A SCLAB3B.285
*ENDIF DEF,A70_1B SCLAB3B.286