*IF DEF,A70_1B RSCTW3B.2 *IF DEF,A01_3A,OR,DEF,A02_3A RSCTW3B.3 C ******************************COPYRIGHT****************************** RSCTW3B.4 C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. RSCTW3B.5 C RSCTW3B.6 C Use, duplication or disclosure of this code is subject to the RSCTW3B.7 C restrictions as set forth in the contract. RSCTW3B.8 C RSCTW3B.9 C Meteorological Office RSCTW3B.10 C London Road RSCTW3B.11 C BRACKNELL RSCTW3B.12 C Berkshire UK RSCTW3B.13 C RG12 2SZ RSCTW3B.14 C RSCTW3B.15 C If no contract has been raised with this copy of the code, the use, RSCTW3B.16 C duplication or disclosure of it is strictly prohibited. Permission RSCTW3B.17 C to do so must first be obtained in writing from the Head of Numerical RSCTW3B.18 C Modelling at the above address. RSCTW3B.19 C ******************************COPYRIGHT****************************** RSCTW3B.20 C RSCTW3B.21 !+ Subroutine to rescale optical depth and albedo. RSCTW3B.22 ! RSCTW3B.23 ! Method: RSCTW3B.24 ! The standard rescaling formulae are applied. RSCTW3B.25 ! RSCTW3B.26 ! Current Owner of Code: J. M. Edwards RSCTW3B.27 ! RSCTW3B.28 ! History: RSCTW3B.29 ! Version Date Comment RSCTW3B.30 ! 4.5 11-06-98 Optimised version RSCTW3B.31 ! (P. Burton) RSCTW3B.32 ! RSCTW3B.33 ! Description of Code: RSCTW3B.34 ! FORTRAN 77 with extensions listed in documentation. RSCTW3B.35 ! RSCTW3B.36 !- --------------------------------------------------------------------- RSCTW3B.37SUBROUTINE RESCALE_TAU_OMEGA(N_PROFILE 2RSCTW3B.38 & , I_LAYER_FIRST, I_LAYER_LAST RSCTW3B.39 & , TAU, OMEGA, FORWARD_SCATTER RSCTW3B.40 & , NPD_PROFILE, NPD_LAYER RSCTW3B.41 & ) RSCTW3B.42 ! RSCTW3B.43 ! RSCTW3B.44 IMPLICIT NONE RSCTW3B.45 ! RSCTW3B.46 ! RSCTW3B.47 ! SIZES OF DUMMY ARRAYS. RSCTW3B.48 INTEGER !, INTENT(IN) RSCTW3B.49 & NPD_PROFILE RSCTW3B.50 ! MAXIMUM NUMBER OF PROFILES RSCTW3B.51 & , NPD_LAYER RSCTW3B.52 ! MAXIMUM NUMBER OF LAYERS RSCTW3B.53 ! RSCTW3B.54 ! DUMMY ARGUMENTS. RSCTW3B.55 INTEGER !, INTENT(IN) RSCTW3B.56 & N_PROFILE RSCTW3B.57 ! NUMBER OF PROFILES RSCTW3B.58 & , I_LAYER_FIRST RSCTW3B.59 ! FIRST LAYER TO RESCALE RSCTW3B.60 & , I_LAYER_LAST RSCTW3B.61 ! FIRST LAYER TO RESCALE RSCTW3B.62 REAL !, INTENT(IN) RSCTW3B.63 & FORWARD_SCATTER(NPD_PROFILE, NPD_LAYER) RSCTW3B.64 ! FORWARD SCATTERING RSCTW3B.65 REAL !, INTENT(INOUT) RSCTW3B.66 & TAU(NPD_PROFILE, NPD_LAYER) RSCTW3B.67 ! OPTICAL DEPTH RSCTW3B.68 & , OMEGA(NPD_PROFILE, NPD_LAYER) RSCTW3B.69 ! ALBEDO OF SINGLE SCATTERING RSCTW3B.70 ! RSCTW3B.71 ! LOCAL VARIABLES. RSCTW3B.72 INTEGER RSCTW3B.73 & I RSCTW3B.74 ! LOOP VARIABLE RSCTW3B.75 & , L RSCTW3B.76 ! LOOP VARIABLE RSCTW3B.77 RSCTW3B.78 ! Temporary scalars for the rescheduled divide RSCTW3B.79 REAL RSCTW3B.80 & TEMP1,TEMP2,TEMP3,TEMP4,TEMP5 RSCTW3B.81 RSCTW3B.82 RSCTW3B.83 RSCTW3B.84 DO I=I_LAYER_FIRST, I_LAYER_LAST RSCTW3B.85 IF(N_PROFILE.GT.0) THEN RSCTW3B.86 TEMP1=1.0E+00 - OMEGA(1,I)*FORWARD_SCATTER(1,I) RSCTW3B.87 TEMP2=1.0E+00 - FORWARD_SCATTER(1,I) RSCTW3B.88 DO L=1,N_PROFILE-1 RSCTW3B.89 TEMP5=TEMP2/TEMP1 RSCTW3B.90 TAU(L,I)=TAU(L,I)*TEMP1 RSCTW3B.91 TEMP3=1.0-OMEGA(L+1,I)*FORWARD_SCATTER(L+1,I) RSCTW3B.92 TEMP4=1.0-FORWARD_SCATTER(L+1,I) RSCTW3B.93 TEMP2=TEMP4 RSCTW3B.94 TEMP1=TEMP3 RSCTW3B.95 OMEGA(L,I) = OMEGA(L,I)*TEMP5 RSCTW3B.96 ENDDO RSCTW3B.97 TEMP5=TEMP2/TEMP1 RSCTW3B.98 TAU(N_PROFILE,I) = TAU(N_PROFILE,I)*TEMP1 RSCTW3B.99 OMEGA(N_PROFILE,I)= OMEGA(N_PROFILE,I)*TEMP5 RSCTW3B.100 END IF RSCTW3B.101 END DO RSCTW3B.102 RSCTW3B.103 RETURN RSCTW3B.104 END RSCTW3B.105 *ENDIF DEF,A01_3A,OR,DEF,A02_3A RSCTW3B.106 *ENDIF DEF,A70_1B RSCTW3B.107