Changeset 1320 for palm/trunk/SOURCE/calc_radiation.f90
- Timestamp:
- Mar 20, 2014 8:40:49 AM (10 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/calc_radiation.f90 (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/calc_radiation.f90
r1310 r1320 20 20 ! Current revisions: 21 21 ! ----------------- 22 ! 22 ! ONLY-attribute added to USE-statements, 23 ! kind-parameters added to all INTEGER and REAL declaration statements, 24 ! kinds are defined in new module kinds, 25 ! revision history before 2012 removed, 26 ! comment fields (!:) to be used for variable explanations added to 27 ! all variable declaration statements 23 28 ! 24 29 ! Former revisions: … … 28 33 ! 1036 2012-10-22 13:43:42Z raasch 29 34 ! code put under GPL (PALM 3.9) 30 !31 ! RCS Log replace by Id keyword, revision history cleaned up32 !33 ! Revision 1.6 2004/01/30 10:17:03 raasch34 ! Scalar lower k index nzb replaced by 2d-array nzb_2d35 35 ! 36 36 ! Revision 1.1 2000/04/13 14:42:45 schroeter … … 43 43 ! based on the parameterization of the cloud effective emissivity 44 44 !------------------------------------------------------------------------------! 45 45 USE kinds 46 46 47 PRIVATE 47 48 PUBLIC calc_radiation 48 49 49 LOGICAL, SAVE :: first_call = .TRUE. 50 REAL, SAVE :: sigma = 5.67E-08 51 52 REAL, DIMENSION(:), ALLOCATABLE, SAVE :: lwp_ground, lwp_top, & 53 blackbody_emission 50 LOGICAL, SAVE :: first_call = .TRUE. !: 51 REAL(wp), SAVE :: sigma = 5.67E-08 !: 52 53 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: lwp_ground !: 54 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: lwp_top !: 55 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: blackbody_emission !: 54 56 55 57 INTERFACE calc_radiation … … 66 68 SUBROUTINE calc_radiation 67 69 68 USE arrays_3d 69 USE cloud_parameters 70 USE control_parameters 71 USE indices 70 USE arrays_3d, & 71 ONLY: dzw, pt, ql, tend 72 73 USE cloud_parameters, & 74 ONLY: cp, l_d_cp, pt_d_t, t_d_pt 75 76 USE control_parameters, & 77 ONLY: rho_surface 78 79 USE indices, & 80 ONLY: nxl, nxr, nyn, nys, nzb, nzb_2d, nzt 81 82 USE kinds 83 72 84 USE pegrid 73 85 86 74 87 IMPLICIT NONE 75 88 76 INTEGER :: i, j, k, k_help 89 INTEGER(iwp) :: i !: 90 INTEGER(iwp) :: j !: 91 INTEGER(iwp) :: k !: 92 INTEGER(iwp) :: k_help !: 77 93 78 REAL :: df_p, df_m , effective_emission_up_m, effective_emission_up_p, & 79 effective_emission_down_m, effective_emission_down_p, & 80 f_up_m, f_up_p, f_down_m, f_down_p, impinging_flux_at_top, & 81 temperature 94 REAL(wp) :: df_p !: 95 REAL(wp) :: df_m !: 96 REAL(wp) :: effective_emission_up_m !: 97 REAL(wp) :: effective_emission_up_p !: 98 REAL(wp) :: effective_emission_down_m !: 99 REAL(wp) :: effective_emission_down_p !: 100 REAL(wp) :: f_up_m !: 101 REAL(wp) :: f_up_p !: 102 REAL(wp) :: f_down_m !: 103 REAL(wp) :: f_down_p !: 104 REAL(wp) :: impinging_flux_at_top !: 105 REAL(wp) :: temperature !: 82 106 83 107 … … 85 109 !-- On first call, allocate temporary arrays 86 110 IF ( first_call ) THEN 87 ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1), &111 ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1), & 88 112 lwp_top(nzb:nzt+1) ) 89 113 first_call = .FALSE. … … 105 129 106 130 k_help = ( nzt+nzb+1 ) - k 107 lwp_ground(k) = lwp_ground(k-1) + rho_surface * ql(k,j,i) * &131 lwp_ground(k) = lwp_ground(k-1) + rho_surface * ql(k,j,i) * & 108 132 dzw(k) 109 133 110 lwp_top(k_help) = lwp_top(k_help+1) + &134 lwp_top(k_help) = lwp_top(k_help+1) + & 111 135 rho_surface * ql(k_help,j,i) * dzw(k_help) 112 136 … … 116 140 ENDDO 117 141 118 lwp_ground(nzt+1) = lwp_ground(nzt) + &142 lwp_ground(nzt+1) = lwp_ground(nzt) + & 119 143 rho_surface * ql(nzt+1,j,i) * dzw(nzt+1) 120 144 lwp_top(nzb) = lwp_top(nzb+1) 121 145 122 temperature = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp * &146 temperature = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp * & 123 147 ql(nzt+1,j,i) 124 148 blackbody_emission(nzt+1) = sigma * temperature**4.0 … … 135 159 ! 136 160 !-- Compute effective emissivities 137 effective_emission_up_p = 1.0 - &161 effective_emission_up_p = 1.0 - & 138 162 EXP( -130.0 * lwp_ground(k+1) ) 139 effective_emission_up_m = 1.0 - &163 effective_emission_up_m = 1.0 - & 140 164 EXP( -130.0 * lwp_ground(k-1) ) 141 effective_emission_down_p = 1.0 - &165 effective_emission_down_p = 1.0 - & 142 166 EXP( -158.0 * lwp_top(k+1) ) 143 effective_emission_down_m = 1.0 - &167 effective_emission_down_m = 1.0 - & 144 168 EXP( -158.0 * lwp_top(k-1) ) 145 169 146 170 ! 147 171 !-- Compute vertical long wave radiation fluxes 148 f_up_p = blackbody_emission(nzb) + &149 effective_emission_up_p * &172 f_up_p = blackbody_emission(nzb) + & 173 effective_emission_up_p * & 150 174 ( blackbody_emission(k) - blackbody_emission(nzb) ) 151 175 152 f_up_m = blackbody_emission(nzb) + &153 effective_emission_up_m * &176 f_up_m = blackbody_emission(nzb) + & 177 effective_emission_up_m * & 154 178 ( blackbody_emission(k-1) - blackbody_emission(nzb) ) 155 179 156 f_down_p = impinging_flux_at_top + &157 effective_emission_down_p * &180 f_down_p = impinging_flux_at_top + & 181 effective_emission_down_p * & 158 182 ( blackbody_emission(k) - impinging_flux_at_top ) 159 183 160 f_down_m = impinging_flux_at_top + &161 effective_emission_down_m * &184 f_down_m = impinging_flux_at_top + & 185 effective_emission_down_m * & 162 186 ( blackbody_emission(k-1) - impinging_flux_at_top ) 163 187 … … 169 193 ! 170 194 !-- Compute tendency term 171 tend(k,j,i) = tend(k,j,i) - &172 ( pt_d_t(k) / ( rho_surface * cp ) * &195 tend(k,j,i) = tend(k,j,i) - & 196 ( pt_d_t(k) / ( rho_surface * cp ) * & 173 197 ( df_p - df_m ) / dzw(k) ) 174 198 … … 187 211 SUBROUTINE calc_radiation_ij( i, j ) 188 212 189 USE arrays_3d 190 USE cloud_parameters 191 USE control_parameters 192 USE indices 213 USE arrays_3d, & 214 ONLY: dzw, pt, ql, tend 215 216 USE cloud_parameters, & 217 ONLY: cp, l_d_cp, pt_d_t, t_d_pt 218 219 USE control_parameters, & 220 ONLY: rho_surface 221 222 USE indices, & 223 ONLY: nzb, nzb_2d, nzt 224 225 USE kinds 226 193 227 USE pegrid 228 194 229 195 230 IMPLICIT NONE 196 231 197 INTEGER :: i, j, k, k_help 198 199 REAL :: df_p, df_m , effective_emission_up_m, effective_emission_up_p, & 200 effective_emission_down_m, effective_emission_down_p, & 201 f_up_m, f_up_p, f_down_m, f_down_p, impinging_flux_at_top, & 202 temperature 203 232 INTEGER(iwp) :: i !: 233 INTEGER(iwp) :: j !: 234 INTEGER(iwp) :: k !: 235 INTEGER(iwp) :: k_help !: 236 237 REAL(wp) :: df_p !: 238 REAL(wp) :: df_m !: 239 REAL(wp) :: effective_emission_up_m !: 240 REAL(wp) :: effective_emission_up_p !: 241 REAL(wp) :: effective_emission_down_m !: 242 REAL(wp) :: effective_emission_down_p !: 243 REAL(wp) :: f_up_m !: 244 REAL(wp) :: f_up_p !: 245 REAL(wp) :: f_down_m !: 246 REAL(wp) :: f_down_p !: 247 REAL(wp) :: impinging_flux_at_top !: 248 REAL(wp) :: temperature !: 249 250 204 251 ! 205 252 !-- On first call, allocate temporary arrays 206 253 IF ( first_call ) THEN 207 ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1), &254 ALLOCATE( blackbody_emission(nzb:nzt+1), lwp_ground(nzb:nzt+1), & 208 255 lwp_top(nzb:nzt+1) ) 209 256 first_call = .FALSE. … … 223 270 lwp_ground(k) = lwp_ground(k-1) + rho_surface * ql(k,j,i) * dzw(k) 224 271 225 lwp_top(k_help) = lwp_top(k_help+1) + &272 lwp_top(k_help) = lwp_top(k_help+1) + & 226 273 rho_surface * ql(k_help,j,i) * dzw(k_help) 227 274 … … 230 277 231 278 ENDDO 232 lwp_ground(nzt+1) = lwp_ground(nzt) + &279 lwp_ground(nzt+1) = lwp_ground(nzt) + & 233 280 rho_surface * ql(nzt+1,j,i) * dzw(nzt+1) 234 281 lwp_top(nzb) = lwp_top(nzb+1) 235 282 236 temperature = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp * &283 temperature = pt(nzt+1,j,i) * t_d_pt(nzt+1) + l_d_cp * & 237 284 ql(nzt+1,j,i) 238 285 blackbody_emission(nzt+1) = sigma * temperature**4.0 … … 249 296 ! 250 297 !-- Compute effective emissivities 251 effective_emission_up_p = 1.0 - &298 effective_emission_up_p = 1.0 - & 252 299 EXP( -130.0 * lwp_ground(k+1) ) 253 effective_emission_up_m = 1.0 - &300 effective_emission_up_m = 1.0 - & 254 301 EXP( -130.0 * lwp_ground(k-1) ) 255 effective_emission_down_p = 1.0 - &302 effective_emission_down_p = 1.0 - & 256 303 EXP( -158.0 * lwp_top(k+1) ) 257 effective_emission_down_m = 1.0 - &304 effective_emission_down_m = 1.0 - & 258 305 EXP( -158.0 * lwp_top(k-1) ) 259 306 260 307 ! 261 308 !-- Compute vertical long wave radiation fluxes 262 f_up_p = blackbody_emission(nzb) + effective_emission_up_p * &309 f_up_p = blackbody_emission(nzb) + effective_emission_up_p * & 263 310 ( blackbody_emission(k) - blackbody_emission(nzb) ) 264 311 265 f_up_m = blackbody_emission(nzb) + effective_emission_up_m * &312 f_up_m = blackbody_emission(nzb) + effective_emission_up_m * & 266 313 ( blackbody_emission(k-1) - blackbody_emission(nzb) ) 267 314 268 f_down_p = impinging_flux_at_top + effective_emission_down_p * &315 f_down_p = impinging_flux_at_top + effective_emission_down_p * & 269 316 ( blackbody_emission(k) - impinging_flux_at_top ) 270 317 271 f_down_m = impinging_flux_at_top + effective_emission_down_m * &318 f_down_m = impinging_flux_at_top + effective_emission_down_m * & 272 319 ( blackbody_emission(k-1) - impinging_flux_at_top ) 273 320 … … 279 326 ! 280 327 !-- Compute tendency term 281 tend(k,j,i) = tend(k,j,i) - ( pt_d_t(k) / ( rho_surface * cp ) * &328 tend(k,j,i) = tend(k,j,i) - ( pt_d_t(k) / ( rho_surface * cp ) * & 282 329 ( df_p - df_m ) / dzw(k) ) 283 330
Note: See TracChangeset
for help on using the changeset viewer.
