*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.47 *IF DEF,A01_3A,OR,DEF,A02_3A MXAPS3A.2 C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13484 C GTS2F400.13485 C Use, duplication or disclosure of this code is subject to the GTS2F400.13486 C restrictions as set forth in the contract. GTS2F400.13487 C GTS2F400.13488 C Meteorological Office GTS2F400.13489 C London Road GTS2F400.13490 C BRACKNELL GTS2F400.13491 C Berkshire UK GTS2F400.13492 C RG12 2SZ GTS2F400.13493 C GTS2F400.13494 C If no contract has been raised with this copy of the code, the use, GTS2F400.13495 C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13496 C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13497 C Modelling at the above address. GTS2F400.13498 C ******************************COPYRIGHT****************************** GTS2F400.13499 C GTS2F400.13500 !+ Subroutine to solve for fluxes treating scattering approximately. MXAPS3A.3 ! MXAPS3A.4 ! Method: MXAPS3A.5 ! The routine is applicable in the infra-red. Downward MXAPS3A.6 ! differential fluxes are calculated first assuming that the MXAPS3A.7 ! upward differential fluxes are 0. Upward fluxes are then MXAPS3A.8 ! calculated using the previously calculated downward fluxes MXAPS3A.9 ! in the reflected terms. MXAPS3A.10 ! MXAPS3A.11 ! Current Owner of Code: J. M. Edwards MXAPS3A.12 ! MXAPS3A.13 ! History: MXAPS3A.14 ! Version Date Comment MXAPS3A.15 ! 4.0 27-07-95 Original Code MXAPS3A.16 ! (J. M. Edwards) MXAPS3A.17 ! MXAPS3A.18 ! Description of Code: MXAPS3A.19 ! FORTRAN 77 with extensions listed in documentation. MXAPS3A.20 ! MXAPS3A.21 !- --------------------------------------------------------------------- MXAPS3A.22SUBROUTINE MIX_APP_SCAT(N_PROFILE, N_LAYER, N_CLOUD_TOP 1MXAPS3A.23 & , T_FREE, R_FREE, S_DOWN_FREE, S_UP_FREE MXAPS3A.24 & , T_CLOUD, R_CLOUD, S_DOWN_CLOUD, S_UP_CLOUD MXAPS3A.25 & , G_FF, G_FC, G_CF, G_CC MXAPS3A.26 & , B_FF, B_FC, B_CF, B_CC MXAPS3A.27 & , L_NET MXAPS3A.28 & , FLUX_INC_DOWN MXAPS3A.29 & , SOURCE_GROUND, ALBEDO_SURFACE_DIFF MXAPS3A.30 & , FLUX_DIFFUSE MXAPS3A.31 & , NPD_PROFILE, NPD_LAYER MXAPS3A.32 & ) MXAPS3A.33 ! MXAPS3A.34 ! MXAPS3A.35 IMPLICIT NONE MXAPS3A.36 ! MXAPS3A.37 ! MXAPS3A.38 ! SIZES OF DUMMY ARRAYS. MXAPS3A.39 INTEGER !, INTENT(IN) MXAPS3A.40 & NPD_PROFILE MXAPS3A.41 ! MAXIMUM NUMBER OF PROFILES MXAPS3A.42 & , NPD_LAYER MXAPS3A.43 ! MAXIMUM NUMBER OF LAYERS MXAPS3A.44 ! MXAPS3A.45 ! MXAPS3A.46 ! DUMMY ARGUMENTS. MXAPS3A.47 INTEGER !, INTENT(IN) MXAPS3A.48 & N_PROFILE MXAPS3A.49 ! NUMBER OF PROFILES MXAPS3A.50 & , N_LAYER MXAPS3A.51 ! NUMBER OF LAYERS MXAPS3A.52 & , N_CLOUD_TOP MXAPS3A.53 ! TOPMOST CLOUDY LAYER MXAPS3A.54 LOGICAL !, INTENT(IN) MXAPS3A.55 & L_NET MXAPS3A.56 ! FLAG FOR CALCULATION OF NET FLUXES MXAPS3A.57 REAL !, INTENT(IN) MXAPS3A.58 & T_FREE(NPD_PROFILE, NPD_LAYER) MXAPS3A.59 ! FREE TRANSMISSION MXAPS3A.60 & , R_FREE(NPD_PROFILE, NPD_LAYER) MXAPS3A.61 ! FREE REFLECTION MXAPS3A.62 & , S_DOWN_FREE(NPD_PROFILE, NPD_LAYER) MXAPS3A.63 ! FREE DOWNWARD SOURCE FUNCTION MXAPS3A.64 & , S_UP_FREE(NPD_PROFILE, NPD_LAYER) MXAPS3A.65 ! FREE UPWARD SOURCE FUNCTION MXAPS3A.66 & , T_CLOUD(NPD_PROFILE, NPD_LAYER) MXAPS3A.67 ! CLOUDY TRANSMISSION MXAPS3A.68 & , R_CLOUD(NPD_PROFILE, NPD_LAYER) MXAPS3A.69 ! CLOUDY REFLECTION MXAPS3A.70 & , S_DOWN_CLOUD(NPD_PROFILE, NPD_LAYER) MXAPS3A.71 ! DOWNWARD CLOUDY SOURCE FUNCTION MXAPS3A.72 & , S_UP_CLOUD(NPD_PROFILE, NPD_LAYER) MXAPS3A.73 ! UPWARD CLOUDY SOURCE FUNCTION MXAPS3A.74 REAL !, INTENT(IN) MXAPS3A.75 & G_FF(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.76 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.77 & , G_FC(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.78 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.79 & , G_CF(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.80 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.81 & , G_CC(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.82 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.83 & , B_FF(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.84 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.85 & , B_FC(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.86 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.87 & , B_CF(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.88 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.89 & , B_CC(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.90 ! ENERGY TRANSFER COEFFICIENT MXAPS3A.91 REAL !, INTENT(IN) MXAPS3A.92 & FLUX_INC_DOWN(NPD_PROFILE) MXAPS3A.93 ! INCIDENT DIFFUSE FLUX MXAPS3A.94 & , SOURCE_GROUND(NPD_PROFILE) MXAPS3A.95 ! SOURCE FROM GROUND MXAPS3A.96 & , ALBEDO_SURFACE_DIFF(NPD_PROFILE) MXAPS3A.97 ! DIFFUSE ALBEDO MXAPS3A.98 REAL !, INTENT(OUT) MXAPS3A.99 & FLUX_DIFFUSE(NPD_PROFILE, 2*NPD_LAYER+2) MXAPS3A.100 ! DIFFUSE FLUX MXAPS3A.101 ! MXAPS3A.102 ! LOCAL VARIABLES. MXAPS3A.103 INTEGER MXAPS3A.104 & I MXAPS3A.105 ! LOOP VARIABLE MXAPS3A.106 & , L MXAPS3A.107 ! LOOP VARIABLE MXAPS3A.108 ! MXAPS3A.109 REAL MXAPS3A.110 & FLUX_DOWN(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.111 ! DOWNWARD FLUXES OUTSIDE CLOUDS JUST BELOW I'TH LEVEL MXAPS3A.112 & , FLUX_DOWN_CLOUD(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.113 ! DOWNWARD FLUXES INSIDE CLOUDS JUST BELOW I'TH LEVEL MXAPS3A.114 & , FLUX_UP(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.115 ! UPWARD FLUXES OUTSIDE CLOUDS JUST ABOVE I'TH LEVEL MXAPS3A.116 & , FLUX_UP_CLOUD(NPD_PROFILE, 0: NPD_LAYER) MXAPS3A.117 ! UPWARD FLUXES INSIDE CLOUDS JUST ABOVE I'TH LEVEL MXAPS3A.118 & , FLUX_PROPAGATED MXAPS3A.119 ! TEMPORARY PROPAGATED FLUX OUTSIDE CLOUD MXAPS3A.120 & , FLUX_PROPAGATED_CLOUD MXAPS3A.121 ! TEMPORARY PROPAGATED FLUX INSIDE CLOUD MXAPS3A.122 & , FLUX_CLOUD_TOP(NPD_PROFILE) MXAPS3A.123 ! TOTAL DOWNWARD FLUX AT TOP OF CLOUD MXAPS3A.124 ! MXAPS3A.125 ! MXAPS3A.126 ! MXAPS3A.127 ! THE ARRAYS FLUX_DOWN AND FLUX_UP WILL EVENTUALLY CONTAIN THE TOTAL MXAPS3A.128 ! FLUXES, BUT INITIALLY THEY ARE USED FOR THE CLEAR FLUXES. MXAPS3A.129 ! NOTE THAT DOWNWARD FLUXES REFER TO VALUES JUST BELOW THE INTERFACE MXAPS3A.130 ! AND UPWARD FLUXES TO VALUES JUST ABOVE IT. MXAPS3A.131 ! MXAPS3A.132 ! MXAPS3A.133 ! DOWNWARD FLUX: MXAPS3A.134 ! MXAPS3A.135 ! REGION ABOVE CLOUDS: MXAPS3A.136 DO L=1, N_PROFILE MXAPS3A.137 FLUX_DOWN(L, 0)=FLUX_INC_DOWN(L) MXAPS3A.138 ENDDO MXAPS3A.139 DO I=1, N_CLOUD_TOP-1 MXAPS3A.140 DO L=1, N_PROFILE MXAPS3A.141 FLUX_DOWN(L, I)=T_FREE(L, I)*FLUX_DOWN(L, I-1) MXAPS3A.142 & +S_DOWN_FREE(L, I) MXAPS3A.143 ENDDO MXAPS3A.144 ENDDO MXAPS3A.145 DO L=1, N_PROFILE MXAPS3A.146 FLUX_CLOUD_TOP(L)=FLUX_DOWN(L, N_CLOUD_TOP-1) MXAPS3A.147 ENDDO MXAPS3A.148 ! MXAPS3A.149 ! REGION OF CLOUDS: MXAPS3A.150 DO L=1, N_PROFILE MXAPS3A.151 FLUX_DOWN(L, N_CLOUD_TOP-1) MXAPS3A.152 & =G_FF(L, N_CLOUD_TOP-1)*FLUX_CLOUD_TOP(L) MXAPS3A.153 FLUX_DOWN_CLOUD(L, N_CLOUD_TOP-1) MXAPS3A.154 & =G_FC(L, N_CLOUD_TOP-1)*FLUX_CLOUD_TOP(L) MXAPS3A.155 ENDDO MXAPS3A.156 ! MXAPS3A.157 DO I=N_CLOUD_TOP, N_LAYER-1 MXAPS3A.158 DO L=1, N_PROFILE MXAPS3A.159 ! MXAPS3A.160 ! PROPAGATE DOWNWARD FLUXES THROUGH THE LAYER. MXAPS3A.161 FLUX_PROPAGATED=T_FREE(L, I)*FLUX_DOWN(L, I-1) MXAPS3A.162 & +S_DOWN_FREE(L, I) MXAPS3A.163 FLUX_PROPAGATED_CLOUD=T_CLOUD(L, I)*FLUX_DOWN_CLOUD(L, I-1) MXAPS3A.164 & +S_DOWN_CLOUD(L, I) MXAPS3A.165 ! TRANSFER DOWNWARD FLUXES ACROSS THE INTERFACE. MXAPS3A.166 FLUX_DOWN(L, I) MXAPS3A.167 & =G_FF(L, I)*FLUX_PROPAGATED MXAPS3A.168 & +G_CF(L, I)*FLUX_PROPAGATED_CLOUD MXAPS3A.169 FLUX_DOWN_CLOUD(L, I) MXAPS3A.170 & =G_CC(L, I)*FLUX_PROPAGATED_CLOUD MXAPS3A.171 & +G_FC(L, I)*FLUX_PROPAGATED MXAPS3A.172 ! MXAPS3A.173 ENDDO MXAPS3A.174 ENDDO MXAPS3A.175 ! MXAPS3A.176 ! PROPAGATE ACROSS THE BOTTOM LAYER, BUT WITHOUT TRANSFERRING MXAPS3A.177 ! ACROSS THE SURFACE AND FORM THE REFLECTED BEAMS. MXAPS3A.178 DO L=1, N_PROFILE MXAPS3A.179 ! PROPAGATE DOWNWARD FLUXES THROUGH THE LAYER. MXAPS3A.180 FLUX_DOWN(L, N_LAYER) MXAPS3A.181 & =T_FREE(L, N_LAYER)*FLUX_DOWN(L, N_LAYER-1) MXAPS3A.182 & +S_DOWN_FREE(L, N_LAYER) MXAPS3A.183 FLUX_DOWN_CLOUD(L, N_LAYER) MXAPS3A.184 & =T_CLOUD(L, N_LAYER)*FLUX_DOWN_CLOUD(L, N_LAYER-1) MXAPS3A.185 & +S_DOWN_CLOUD(L, N_LAYER) MXAPS3A.186 FLUX_UP(L, N_LAYER) MXAPS3A.187 & =ALBEDO_SURFACE_DIFF(L)*FLUX_DOWN(L, N_LAYER) MXAPS3A.188 & +B_FF(L, N_LAYER)*SOURCE_GROUND(L) MXAPS3A.189 FLUX_UP_CLOUD(L, N_LAYER) MXAPS3A.190 & =ALBEDO_SURFACE_DIFF(L)*FLUX_DOWN_CLOUD(L, N_LAYER) MXAPS3A.191 & +B_CF(L, N_LAYER)*SOURCE_GROUND(L) MXAPS3A.192 ENDDO MXAPS3A.193 ! MXAPS3A.194 ! MXAPS3A.195 ! CALCULATE THE UPWARD FLUXES USING THE PREVIOUS DOWNWARD FLUXES MXAPS3A.196 ! TO APPROXIMATE THE SCATTERING TERM. MXAPS3A.197 DO I=N_LAYER, N_CLOUD_TOP, -1 MXAPS3A.198 DO L=1, N_PROFILE MXAPS3A.199 ! MXAPS3A.200 ! PROPAGATE UPWARD FLUXES THROUGH THE LAYER. MXAPS3A.201 FLUX_PROPAGATED=T_FREE(L, I)*FLUX_UP(L, I)+S_UP_FREE(L, I) MXAPS3A.202 & +R_FREE(L, I)*FLUX_DOWN(L, I-1) MXAPS3A.203 FLUX_PROPAGATED_CLOUD=T_CLOUD(L, I)*FLUX_UP_CLOUD(L, I) MXAPS3A.204 & +S_UP_CLOUD(L, I)+R_CLOUD(L, I)*FLUX_DOWN_CLOUD(L, I-1) MXAPS3A.205 ! TRANSFER UPWARD FLUXES ACROSS THE INTERFACE. MXAPS3A.206 FLUX_UP(L, I-1)=B_FF(L, I-1)*FLUX_PROPAGATED MXAPS3A.207 & +B_FC(L, I-1)*FLUX_PROPAGATED_CLOUD MXAPS3A.208 FLUX_UP_CLOUD(L, I-1)=B_CC(L, I-1)*FLUX_PROPAGATED_CLOUD MXAPS3A.209 & +B_CF(L, I-1)*FLUX_PROPAGATED MXAPS3A.210 ! MXAPS3A.211 ENDDO MXAPS3A.212 ENDDO MXAPS3A.213 ! MXAPS3A.214 ! CONTINUE THROUGH THE REGION ABOVE CLOUDS. MXAPS3A.215 DO I=N_CLOUD_TOP-1, 1, -1 MXAPS3A.216 DO L=1, N_PROFILE MXAPS3A.217 FLUX_UP(L, I-1)=T_FREE(L, I)*FLUX_UP(L,I)+S_UP_FREE(L, I) MXAPS3A.218 & +R_FREE(L, I)*FLUX_DOWN(L, I-1) MXAPS3A.219 ENDDO MXAPS3A.220 ENDDO MXAPS3A.221 ! MXAPS3A.222 ! MXAPS3A.223 ! MXAPS3A.224 ! CALCULATE THE OVERALL FLUX. MXAPS3A.225 IF (L_NET) THEN MXAPS3A.226 DO I=0, N_CLOUD_TOP-2 MXAPS3A.227 DO L=1, N_PROFILE MXAPS3A.228 FLUX_DIFFUSE(L, I+1)=FLUX_DOWN(L, I)-FLUX_UP(L, I) MXAPS3A.229 ENDDO MXAPS3A.230 ENDDO MXAPS3A.231 DO I=N_CLOUD_TOP-1, N_LAYER MXAPS3A.232 DO L=1, N_PROFILE MXAPS3A.233 FLUX_DIFFUSE(L, I+1) MXAPS3A.234 & =FLUX_DOWN(L, I)+FLUX_DOWN_CLOUD(L, I) MXAPS3A.235 & -FLUX_UP(L, I)-FLUX_UP_CLOUD(L, I) MXAPS3A.236 ENDDO MXAPS3A.237 ENDDO MXAPS3A.238 ELSE MXAPS3A.239 DO I=0, N_CLOUD_TOP-2 MXAPS3A.240 DO L=1, N_PROFILE MXAPS3A.241 FLUX_DIFFUSE(L, 2*I+1)=FLUX_UP(L, I) MXAPS3A.242 FLUX_DIFFUSE(L, 2*I+2)=FLUX_DOWN(L, I) MXAPS3A.243 ENDDO MXAPS3A.244 ENDDO MXAPS3A.245 DO I=N_CLOUD_TOP-1, N_LAYER MXAPS3A.246 DO L=1, N_PROFILE MXAPS3A.247 FLUX_DIFFUSE(L, 2*I+1)=FLUX_UP(L, I)+FLUX_UP_CLOUD(L, I) MXAPS3A.248 FLUX_DIFFUSE(L, 2*I+2)=FLUX_DOWN(L, I) MXAPS3A.249 & +FLUX_DOWN_CLOUD(L, I) MXAPS3A.250 ENDDO MXAPS3A.251 ENDDO MXAPS3A.252 ENDIF MXAPS3A.253 ! MXAPS3A.254 ! MXAPS3A.255 RETURN MXAPS3A.256 END MXAPS3A.257 *ENDIF DEF,A01_3A,OR,DEF,A02_3A MXAPS3A.258 *ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.48