SUBROUTINE SCALE_ABSORB(IERR, N_PROFILE, N_LAYER 13SCLAB3A.21
& , GAS_MIX_RATIO, P, T, L_LAYER, I_TOP SCLAB3A.22
& , GAS_FRAC_RESCALED SCLAB3A.23
& , I_FNC, P_REFERENCE, T_REFERENCE, SCALE_PARAMETER SCLAB3A.24
& , L_DOPPLER, DOPPLER_CORRECTION SCLAB3A.25
& , NPD_PROFILE, NPD_LAYER, NPD_SCALE_FNC SCLAB3A.26
& , NPD_SCALE_VARIABLE SCLAB3A.27
& ) SCLAB3A.28
! SCLAB3A.29
! SCLAB3A.30
IMPLICIT NONE SCLAB3A.31
! SCLAB3A.32
! SCLAB3A.33
! SIZES OF DUMMY ARRAYS. SCLAB3A.34
INTEGER !, INTENT(IN) SCLAB3A.35
& NPD_PROFILE SCLAB3A.36
! MAXIMUM NUMBER OF PROFILES SCLAB3A.37
& , NPD_LAYER SCLAB3A.38
! MAXIMUM NUMBER OF LAYERS SCLAB3A.39
& , NPD_SCALE_FNC SCLAB3A.40
! NUMBER OF SCALING FUNCTIONS SCLAB3A.41
& , NPD_SCALE_VARIABLE SCLAB3A.42
! MAX. NUMBER OF SCALING VARIABLES SCLAB3A.43
! SCLAB3A.44
! INCLUDE COMDECKS. SCLAB3A.45
*CALL STDIO3A 
SCLAB3A.46
*CALL SCLFNC3A SCLAB3A.47
*CALL ERROR3A SCLAB3A.48
! SCLAB3A.49
! DUMMY ARGUMENTS. SCLAB3A.50
INTEGER !, INTENT(OUT) SCLAB3A.51
& IERR SCLAB3A.52
! ERROR FLAG SCLAB3A.53
INTEGER !, INTENT(IN) SCLAB3A.54
& N_PROFILE SCLAB3A.55
! NUMBER OF PROFILES SCLAB3A.56
& , N_LAYER SCLAB3A.57
! NUMBER OF LAYERS SCLAB3A.58
& , I_FNC SCLAB3A.59
! TYPE OF SCALING FUNCTION SCLAB3A.60
& , I_TOP SCLAB3A.61
! UPPERMOST INDEX FOR SCALING (THIS WILL BE 1 FOR FIELDS ADB1F401.931
! GIVEN IN LAYERS, AS IN THE UNIFIED MODEL, OR 0 FOR ADB1F401.932
! FIELDS GIVEN AT THE BOUNDARIES OF LAYERS) ADB1F401.933
LOGICAL !, INTENT(IN) SCLAB3A.63
& L_LAYER SCLAB3A.64
! DATA SPECIFIED IN LAYERS SCLAB3A.65
& , L_DOPPLER SCLAB3A.66
! FLAG FOR DOPPLER TERM SCLAB3A.67
REAL !, INTENT(IN) SCLAB3A.68
& GAS_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER) SCLAB3A.69
! MASS MIXING RATIO OF GAS SCLAB3A.70
& , P(NPD_PROFILE, 0: NPD_LAYER) SCLAB3A.71
! PRESSURE SCLAB3A.72
& , T(NPD_PROFILE, 0: NPD_LAYER) SCLAB3A.73
! TEMPERATURE SCLAB3A.74
& , P_REFERENCE SCLAB3A.75
! REFERENCE PRESSURE SCLAB3A.76
& , T_REFERENCE SCLAB3A.77
! REFERENCE TEMPERATURE ADB1F401.934
& , SCALE_PARAMETER(NPD_SCALE_VARIABLE) SCLAB3A.79
! SCALING PARAMTERS SCLAB3A.80
& , DOPPLER_CORRECTION SCLAB3A.81
! DOPPLER-BROADENING CORRECTION SCLAB3A.82
REAL !, INTENT(OUT) SCLAB3A.83
& GAS_FRAC_RESCALED(NPD_PROFILE, 0: NPD_LAYER) SCLAB3A.84
! MASS FRACTION OF GAS SCLAB3A.85
! SCLAB3A.86
! LOCAL VARIABLES. SCLAB3A.87
INTEGER SCLAB3A.88
& L SCLAB3A.89
! LOOP VARIABLE SCLAB3A.90
& , I SCLAB3A.91
! LOOP VARIABLE SCLAB3A.92
REAL SCLAB3A.93
& PRESSURE_OFFSET SCLAB3A.94
! OFFSET TO PRESSURE SCLAB3A.95
REAL PWK(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace GSS3F402.333
REAL TWK(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace GSS3F402.334
*IF DEF,VECTLIB PXVECTLB.133
REAL SP1(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace GSS3F402.336
REAL SP2(N_PROFILE,N_LAYER-I_TOP+1) ! Workspace GSS3F402.337
INTEGER n_input ! No. of inputs for rtor_v function GSS3F402.338
*ENDIF GSS3F402.339
! SCLAB3A.108
! SET THE OFFSET TO THE PRESSURE FOR THE DOPPLER CORRECTION. SCLAB3A.109
IF (L_DOPPLER) THEN SCLAB3A.110
PRESSURE_OFFSET=DOPPLER_CORRECTION SCLAB3A.111
ELSE SCLAB3A.112
PRESSURE_OFFSET=0.0E+00 SCLAB3A.113
ENDIF SCLAB3A.114
! SCLAB3A.115
! THE ARRAY GAS_FRAC_RESCALED IS USED INITIALLY TO HOLD ONLY THE SCLAB3A.116
! SCALING FUNCTIONS, AND ONLY LATER IS IT MULTIPLIED BY THE SCLAB3A.117
! MIXING RATIOS SCLAB3A.118
*IF DEF,VECTLIB PXVECTLB.134
do I=1, N_LAYER-I_TOP+1 GSS3F402.341
do L=1, N_PROFILE GSS3F402.342
sp1(L,I)=SCALE_PARAMETER(1) GSS3F402.343
sp2(L,I)=SCALE_PARAMETER(2) GSS3F402.344
end do GSS3F402.345
end do GSS3F402.346
n_input=(N_LAYER-I_TOP+1)*N_PROFILE GSS3F402.347
*ENDIF GSS3F402.348
! SCLAB3A.119
IF (I_FNC.EQ.IP_SCALE_POWER_LAW) THEN SCLAB3A.120
! GSS3F402.349
DO I= 1, N_LAYER-I_TOP+1 GSS3F402.350
DO L=1, N_PROFILE GSS3F402.351
PWK(L,I)=(P(L,I_TOP+I-1)+PRESSURE_OFFSET) GSS3F402.352
& /(P_REFERENCE+PRESSURE_OFFSET) GSS3F402.353
TWK(L,I)=T(L,I_TOP+I-1)/T_REFERENCE GSS3F402.354
END DO GSS3F402.355
END DO GSS3F402.356
*IF DEF,VECTLIB PXVECTLB.135
call rtor_v(n_input,pwk,sp1,pwk) GSS3F402.358
call rtor_v(n_input,twk,sp2,twk) GSS3F402.359
*ELSE GSS3F402.360
DO I= 1, N_LAYER-I_TOP+1 GSS3F402.361
DO L=1, N_PROFILE GSS3F402.362
*IF -DEF,FUJITSU GRB1F405.42
PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1) GSS3F402.363
TWK(L,I)=TWK(L,I)**SCALE_PARAMETER(2) GSS3F402.364
*ELSE GRB1F405.43
PWK(L,I)=exp(SCALE_PARAMETER(1)*log(PWK(L,I))) GRB1F405.44
TWK(L,I)=exp(SCALE_PARAMETER(2)*log(TWK(L,I))) GRB1F405.45
*ENDIF GRB1F405.46
ENDDO GSS3F402.365
ENDDO GSS3F402.366
*ENDIF GSS3F402.367
! GSS3F402.368
DO I=I_TOP, N_LAYER SCLAB3A.121
DO L=1, N_PROFILE SCLAB3A.122
GAS_FRAC_RESCALED(L, I) GSS3F402.369
& =PWK(L,I-I_TOP+1)*TWK(L,I-I_TOP+1) GSS3F402.370
ENDDO SCLAB3A.128
ENDDO SCLAB3A.129
ELSE IF (I_FNC.EQ.IP_SCALE_FNC_NULL) THEN SCLAB3A.130
RETURN SCLAB3A.131
ELSE IF (I_FNC.EQ.IP_SCALE_POWER_QUAD) THEN SCLAB3A.132
! GSS3F402.371
DO I= 1, N_LAYER-I_TOP+1 GSS3F402.372
DO L=1, N_PROFILE GSS3F402.373
PWK(L,I)=(P(L,I_TOP+I-1)+PRESSURE_OFFSET) GSS3F402.374
& /(P_REFERENCE+PRESSURE_OFFSET) GSS3F402.375
END DO GSS3F402.376
END DO GSS3F402.377
*IF DEF,VECTLIB PXVECTLB.136
call rtor_v(n_input,pwk,sp1,pwk) GSS3F402.379
*ELSE GSS3F402.380
DO I= 1, N_LAYER-I_TOP+1 GSS3F402.381
DO L=1, N_PROFILE GSS3F402.382
*IF -DEF,FUJITSU GRB1F405.47
PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1) GSS3F402.383
*ELSE GRB1F405.48
PWK(L,I)=exp(SCALE_PARAMETER(1)*log(PWK(L,I))) GRB1F405.49
*ENDIF GRB1F405.50
ENDDO GSS3F402.384
ENDDO GSS3F402.385
*ENDIF GSS3F402.386
! GSS3F402.387
DO I=I_TOP, N_LAYER SCLAB3A.133
DO L=1, N_PROFILE SCLAB3A.134
GAS_FRAC_RESCALED(L, I)=PWK(L,I-I_TOP+1)* GSS3F402.388
& (1.0E+00+SCALE_PARAMETER(2)*(T(L, I)/T_REFERENCE-1.0E+00) GSS3F402.389
& +SCALE_PARAMETER(3)*(T(L, I)/T_REFERENCE-1.0E+00)**2) GSS3F402.390
ENDDO SCLAB3A.143
ENDDO SCLAB3A.144
ELSE IF (I_FNC.EQ.IP_SCALE_DOPPLER_QUAD) THEN SCLAB3A.145
! THERE IS NO DOPPLER TERM HERE SINCE IT IS IMPLICITLY INCLUDED SCLAB3A.146
! IN THE SCALING. SCLAB3A.147
! GSS3F402.391
DO I= 1, N_LAYER-I_TOP+1 GSS3F402.392
DO L=1, N_PROFILE GSS3F402.393
PWK(L,I)=(P(L,I_TOP+I-1)+SCALE_PARAMETER(2)) GSS3F402.394
& /(P_REFERENCE+SCALE_PARAMETER(2)) GSS3F402.395
END DO GSS3F402.396
END DO GSS3F402.397
*IF DEF,VECTLIB PXVECTLB.137
call rtor_v(n_input,pwk,sp1,pwk) GSS3F402.399
*ELSE GSS3F402.400
DO I=1,N_LAYER-I_TOP+1 GSS3F402.401
DO L=1, N_PROFILE GSS3F402.402
*IF -DEF,FUJITSU GRB1F405.51
PWK(L,I)=PWK(L,I)**SCALE_PARAMETER(1) GSS3F402.403
*ELSE GRB1F405.52
PWK(L,I)=exp(SCALE_PARAMETER(1)*log(PWK(L,I))) GRB1F405.53
*ENDIF GRB1F405.54
ENDDO GSS3F402.404
ENDDO GSS3F402.405
*ENDIF GSS3F402.406
! GSS3F402.407
DO I=I_TOP, N_LAYER ADB1F401.935
DO L=1, N_PROFILE SCLAB3A.149
GAS_FRAC_RESCALED(L, I)=PWK(L,I-I_TOP+1) GSS3F402.408
& *(1.0E+00 SCLAB3A.154
& +SCALE_PARAMETER(3)*(T(L, I)/T_REFERENCE-1.0E+00) SCLAB3A.155
& +SCALE_PARAMETER(4)*(T(L, I)/T_REFERENCE-1.0E+00)**2) SCLAB3A.156
ENDDO SCLAB3A.157
ENDDO SCLAB3A.158
ELSE SCLAB3A.159
WRITE(IU_ERR, '(/A)') SCLAB3A.160
& '*** ERROR: AN ILLEGAL TYPE OF SCALING HAS BEEN GIVEN.' SCLAB3A.161
IERR=I_ERR_FATAL SCLAB3A.162
RETURN SCLAB3A.163
ENDIF SCLAB3A.164
! SCLAB3A.165
! MULTIPLY BY THE MIXING RATIO AND LIMIT NEGATIVE SCALINGS. SCLAB3A.166
IF (L_LAYER) THEN SCLAB3A.167
DO I=N_LAYER, 1, -1 SCLAB3A.168
DO L=1, N_PROFILE SCLAB3A.169
GAS_FRAC_RESCALED(L, I)=MAX(REAL(0.0E+00) SCLAB3A.170
& , GAS_FRAC_RESCALED(L, I)*GAS_MIX_RATIO(L, I)) SCLAB3A.171
ENDDO SCLAB3A.172
ENDDO SCLAB3A.173
ELSE SCLAB3A.174
! CONVERT TO VALUES IN LAYERS. SCLAB3A.175
DO I=N_LAYER, 1, -1 SCLAB3A.176
DO L=1, N_PROFILE SCLAB3A.177
GAS_FRAC_RESCALED(L, I) SCLAB3A.178
& =0.5E+00*(GAS_FRAC_RESCALED(L, I-1) SCLAB3A.179
& *GAS_MIX_RATIO(L, I-1) SCLAB3A.180
& +GAS_FRAC_RESCALED(L, I)*GAS_MIX_RATIO(L, I)) SCLAB3A.181
GAS_FRAC_RESCALED(L, I) SCLAB3A.182
& =MAX(REAL(0.0E+00), GAS_FRAC_RESCALED(L, I)) SCLAB3A.183
ENDDO SCLAB3A.184
ENDDO SCLAB3A.185
ENDIF SCLAB3A.186
! SCLAB3A.187
! SCLAB3A.188
RETURN SCLAB3A.189
END SCLAB3A.190
*ENDIF DEF,A01_3A,OR,DEF,A02_3A SCLAB3A.191
*ENDIF DEF,A70_1A ADB1F402.92