Changeset 4648 for palm/trunk/SOURCE/init_masks.f90
- Timestamp:
- Aug 25, 2020 7:52:08 AM (4 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/init_masks.f90 (modified) (46 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/init_masks.f90
r4521 r4648 1 1 !> @file init_masks.f90 2 !------------------------------------------------------------------------------ !2 !--------------------------------------------------------------------------------------------------! 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software 7 ! Foundation, either version 3 of the License, or (at your option) any later 8 ! version. 9 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY 11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR 12 ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. 13 ! 14 ! You should have received a copy of the GNU General Public License along with 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 8 ! 9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 12 ! 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 16 15 ! 17 16 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !17 !--------------------------------------------------------------------------------------------------! 19 18 ! 20 19 ! Current revisions: 21 20 ! ----------------- 22 ! 23 ! 21 ! 22 ! 24 23 ! Former revisions: 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4521 2020-05-06 11:39:49Z schwenkel 27 29 ! Rename variable 28 ! 30 ! 29 31 ! 4502 2020-04-17 16:14:16Z schwenkel 30 32 ! Implementation of ice microphysics 31 ! 33 ! 32 34 ! 4444 2020-03-05 15:59:50Z raasch 33 35 ! bugfix: cpp-directives for serial mode added 34 ! 36 ! 35 37 ! 4360 2020-01-07 11:25:50Z suehring 36 38 ! Corrected "Former revisions" section 37 ! 39 ! 38 40 ! 4069 2019-07-01 14:05:51Z Giersch 39 ! Masked output running index mid has been introduced as a local variable to 40 ! avoid runtime error (Loop variable has been modified) in time_integration41 ! 41 ! Masked output running index mid has been introduced as a local variable to avoid runtime error 42 ! (Loop variable has been modified) in time_integration 43 ! 42 44 ! 3766 2019-02-26 16:23:41Z raasch 43 45 ! unused variables removed 44 ! 46 ! 45 47 ! 3687 2019-01-22 10:42:06Z knoop 46 48 ! unused variables removed 47 ! 49 ! 48 50 ! 3655 2019-01-07 16:51:22Z knoop 49 ! Move the control parameter "salsa" from salsa_mod to control_parameters 50 ! (M. Kurppa) 51 ! Move the control parameter "salsa" from salsa_mod to control_parameters (M. Kurppa) 51 52 ! 52 53 ! 410 2009-12-04 17:05:40Z letzel … … 57 58 ! ------------ 58 59 !> Initialize masked data output 59 !------------------------------------------------------------------------------ !60 !--------------------------------------------------------------------------------------------------! 60 61 SUBROUTINE init_masks 61 62 62 USE arrays_3d, &63 USE arrays_3d, & 63 64 ONLY: zu, zw 64 65 65 USE bulk_cloud_model_mod, & 66 ONLY: bulk_cloud_model, microphysics_morrison, microphysics_seifert, & 67 microphysics_ice_phase 68 69 USE control_parameters, & 70 ONLY: constant_diffusion, cloud_droplets, & 71 data_output_masks, data_output_masks_user, & 72 doav, doav_n, domask, domask_no, dz, dz_stretch_level_start, & 73 humidity, mask, masks, mask_scale, mask_i, & 74 mask_i_global, mask_j, mask_j_global, mask_k, mask_k_global, & 75 mask_k_over_surface, & 76 mask_loop, mask_size, mask_size_l, mask_start_l, & 77 mask_surface, mask_x, & 78 mask_x_loop, mask_xyz_dimension, mask_y, mask_y_loop, mask_z, & 79 mask_z_loop, max_masks, message_string, & 80 passive_scalar, ocean_mode, varnamelength 81 82 USE grid_variables, & 66 USE bulk_cloud_model_mod, & 67 ONLY: bulk_cloud_model, microphysics_ice_phase, microphysics_morrison, & 68 microphysics_seifert 69 70 71 USE control_parameters, & 72 ONLY: constant_diffusion, cloud_droplets, data_output_masks, data_output_masks_user, doav,& 73 doav_n, domask, domask_no, dz, dz_stretch_level_start, humidity, mask, masks, & 74 mask_scale, mask_i, mask_i_global, mask_j, mask_j_global, mask_k, mask_k_global, & 75 mask_k_over_surface, mask_loop, mask_size, mask_size_l, mask_start_l, mask_surface, & 76 mask_x, mask_x_loop, mask_xyz_dimension, mask_y, mask_y_loop, mask_z, mask_z_loop, & 77 max_masks, message_string, passive_scalar, ocean_mode, varnamelength 78 79 USE grid_variables, & 83 80 ONLY: dx, dy 84 81 85 USE indices, &82 USE indices, & 86 83 ONLY: nx, nxl, nxr, ny, nyn, nys, nz, nzb, nzt 87 84 88 85 USE kinds 89 86 90 USE module_interface, &87 USE module_interface, & 91 88 ONLY: module_interface_init_masks 92 89 93 USE netcdf_interface, &90 USE netcdf_interface, & 94 91 ONLY: domask_unit, netcdf_data_format 95 92 96 USE particle_attributes, &93 USE particle_attributes, & 97 94 ONLY: particle_advection 98 95 … … 103 100 CHARACTER (LEN=varnamelength) :: var !< contains variable name 104 101 CHARACTER (LEN=7) :: unit !< contains unit of variable 105 102 106 103 CHARACTER (LEN=varnamelength), DIMENSION(max_masks,100) :: do_mask !< list of output variables 107 104 CHARACTER (LEN=varnamelength), DIMENSION(max_masks,100) :: do_mask_user !< list of user-specified output variables … … 120 117 INTEGER(iwp) :: sender !< PE id of sending PE 121 118 #endif 122 119 123 120 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: tmp_array !< temporary 1D array 124 121 … … 126 123 127 124 ! 128 !-- Initial values are explicitly set here due to a bug in the Cray compiler 129 !-- in case of assignments of initial values in declaration statements for130 !-- arrays with more than 9999 elements(appears with -eD only)125 !-- Initial values are explicitly set here due to a bug in the Cray compiler in case of assignments 126 !-- of initial values in declaration statements for arrays with more than 9999 elements 127 !-- (appears with -eD only) 131 128 domask = ' ' 132 129 … … 135 132 ALLOCATE( tmp_array( MAX(nx,ny,nz)+2 ) ) 136 133 137 ALLOCATE( mask_i(max_masks,nxr-nxl+2), &138 mask_j(max_masks,nyn-nys+2), &134 ALLOCATE( mask_i(max_masks,nxr-nxl+2), & 135 mask_j(max_masks,nyn-nys+2), & 139 136 mask_k(max_masks,nzt-nzb+2) ) 140 137 ! 141 138 !-- internal mask arrays ("mask,dimension,selection") 142 ALLOCATE( mask(max_masks,3,mask_xyz_dimension), & 143 mask_loop(max_masks,3,3) ) 144 145 ! 146 !-- Parallel mask output not yet supported. In check_parameters data format 147 !-- is restricted and is switched back to non-parallel output. Therefore the 148 !-- following error can not occur at the moment. 139 ALLOCATE( mask(max_masks,3,mask_xyz_dimension), mask_loop(max_masks,3,3) ) 140 141 ! 142 !-- Parallel mask output not yet supported. In check_parameters data format is restricted and is 143 !-- switched back to non-parallel output. Therefore the following error can not occur at the moment. 149 144 IF ( netcdf_data_format > 4 ) THEN 150 message_string = 'netCDF file formats '// &151 '5 and 6 (with parallel I/O support)'// &145 message_string = 'netCDF file formats '// & 146 '5 and 6 (with parallel I/O support)'// & 152 147 ' are currently not supported.' 153 148 CALL message( 'init_masks', 'PA0328', 1, 2, 0, 6, 0 ) … … 157 152 !-- Store data output parameters for masked data output in few shared arrays 158 153 DO mid = 1, masks 159 154 160 155 do_mask (mid,:) = data_output_masks(mid,:) 161 156 do_mask_user(mid,:) = data_output_masks_user(mid,:) 162 mask (mid,1,:) = mask_x(mid,:) 157 mask (mid,1,:) = mask_x(mid,:) 163 158 mask (mid,2,:) = mask_y(mid,:) 164 mask (mid,3,:) = mask_z(mid,:) 159 mask (mid,3,:) = mask_z(mid,:) 165 160 ! 166 161 !-- Flag a mask as terrain following … … 169 164 ENDIF 170 165 171 IF ( mask_x_loop(mid,1) == -1.0_wp .AND. mask_x_loop(mid,2) == -1.0_wp &172 .AND.mask_x_loop(mid,3) == -1.0_wp ) THEN166 IF ( mask_x_loop(mid,1) == -1.0_wp .AND. mask_x_loop(mid,2) == -1.0_wp .AND. & 167 mask_x_loop(mid,3) == -1.0_wp ) THEN 173 168 mask_loop(mid,1,1:2) = -1.0_wp 174 169 mask_loop(mid,1,3) = 0.0_wp … … 176 171 mask_loop(mid,1,:) = mask_x_loop(mid,:) 177 172 ENDIF 178 IF ( mask_y_loop(mid,1) == -1.0_wp .AND. mask_y_loop(mid,2) == -1.0_wp &179 .AND.mask_y_loop(mid,3) == -1.0_wp ) THEN173 IF ( mask_y_loop(mid,1) == -1.0_wp .AND. mask_y_loop(mid,2) == -1.0_wp .AND. & 174 mask_y_loop(mid,3) == -1.0_wp ) THEN 180 175 mask_loop(mid,2,1:2) = -1.0_wp 181 176 mask_loop(mid,2,3) = 0.0_wp … … 183 178 mask_loop(mid,2,:) = mask_y_loop(mid,:) 184 179 ENDIF 185 IF ( mask_z_loop(mid,1) == -1.0_wp .AND. mask_z_loop(mid,2) == -1.0_wp &186 .AND.mask_z_loop(mid,3) == -1.0_wp ) THEN180 IF ( mask_z_loop(mid,1) == -1.0_wp .AND. mask_z_loop(mid,2) == -1.0_wp .AND. & 181 mask_z_loop(mid,3) == -1.0_wp ) THEN 187 182 mask_loop(mid,3,1:2) = -1.0_wp 188 183 mask_loop(mid,3,3) = 0.0_wp … … 190 185 mask_loop(mid,3,:) = mask_z_loop(mid,:) 191 186 ENDIF 192 187 193 188 ENDDO 194 189 195 190 mask_i = -1; mask_j = -1; mask_k = -1 196 191 197 192 ! 198 193 !-- Global arrays are required by define_netcdf_header. 199 194 IF ( myid == 0 .OR. netcdf_data_format > 4 ) THEN 200 ALLOCATE( mask_i_global(max_masks,nx+2), &201 mask_j_global(max_masks,ny+2), &195 ALLOCATE( mask_i_global(max_masks,nx+2), & 196 mask_j_global(max_masks,ny+2), & 202 197 mask_k_global(max_masks,nz+2) ) 203 198 mask_i_global = -1; mask_j_global = -1; mask_k_global = -1 … … 217 212 DO WHILE ( do_mask_user(mid,j) /= ' ' .AND. j <= 100 ) 218 213 IF ( i > 100 ) THEN 219 WRITE ( message_string, * ) 'number of output quantitities ', &220 'given by data_output_mask and data_output_mask_user ',&221 'exceeds the limit of 100'214 WRITE ( message_string, * ) 'number of output quantitities ', & 215 'given by data_output_mask and data_output_mask_user ',& 216 'exceeds the limit of 100' 222 217 CALL message( 'init_masks', 'PA0329', 1, 2, 0, 6, 0 ) 223 218 ENDIF … … 249 244 CASE ( 'e' ) 250 245 IF ( constant_diffusion ) THEN 251 WRITE ( message_string, * ) 'output of "', TRIM( var ), &252 '" requires constant_diffusion = .FALSE.'246 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 247 '" requires constant_diffusion = .FALSE.' 253 248 CALL message( 'init_masks', 'PA0103', 1, 2, 0, 6, 0 ) 254 249 ENDIF … … 257 252 CASE ( 'thetal' ) 258 253 IF ( .NOT. bulk_cloud_model ) THEN 259 WRITE ( message_string, * ) 'output of "', TRIM( var ), &260 '" requires bulk_cloud_model = .TRUE.'254 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 255 '" requires bulk_cloud_model = .TRUE.' 261 256 CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 ) 262 257 ENDIF … … 265 260 CASE ( 'nc' ) 266 261 IF ( .NOT. bulk_cloud_model ) THEN 267 WRITE ( message_string, * ) 'output of "', TRIM( var ), &268 '" requires bulk_cloud_model = .TRUE.'262 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 263 '" requires bulk_cloud_model = .TRUE.' 269 264 CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 ) 270 ELSEIF ( .NOT. microphysics_morrison ) THEN 271 message_string = 'output of "' // TRIM( var ) // '" ' // & 272 'requires = morrison' 265 ELSEIF ( .NOT. microphysics_morrison ) THEN 266 message_string = 'output of "' // TRIM( var ) // '" ' // 'requires = morrison' 273 267 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) 274 268 ENDIF … … 277 271 CASE ( 'ni' ) 278 272 IF ( .NOT. bulk_cloud_model ) THEN 279 WRITE ( message_string, * ) 'output of "', TRIM( var ), &280 '" requires bulk_cloud_model = .TRUE.'273 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 274 '" requires bulk_cloud_model = .TRUE.' 281 275 CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 ) 282 ELSEIF ( .NOT. microphysics_ice_phase ) THEN283 message_string = 'output of "' // TRIM( var ) // '" ' // &284 'requires microphysics_ice_phase = .TRUE.'276 ELSEIF ( .NOT. microphysics_ice_phase ) THEN 277 message_string = 'output of "' // TRIM( var ) // '" ' // & 278 'requires microphysics_ice_phase = .TRUE.' 285 279 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) 286 280 ENDIF … … 289 283 CASE ( 'nr' ) 290 284 IF ( .NOT. bulk_cloud_model ) THEN 291 WRITE ( message_string, * ) 'output of "', TRIM( var ), &292 '" requires bulk_cloud_model = .TRUE.'285 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 286 '" requires bulk_cloud_model = .TRUE.' 293 287 CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 ) 294 ELSEIF ( .NOT. microphysics_seifert )THEN295 message_string = 'output of "' // TRIM( var ) // '"' // &296 'requires cloud_scheme = seifert_beheng'288 ELSEIF ( .NOT. microphysics_seifert ) THEN 289 message_string = 'output of "' // TRIM( var ) // '"' // & 290 'requires cloud_scheme = seifert_beheng' 297 291 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) 298 292 ENDIF … … 301 295 CASE ( 'pc', 'pr' ) 302 296 IF ( .NOT. particle_advection ) THEN 303 WRITE ( message_string, * ) 'output of "', TRIM( var ), &304 '" requires a "particles_par"-NAMELIST in the ',&305 'parameter file (PARIN)'297 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 298 '" requires a "particles_par"-NAMELIST in the ', & 299 'parameter file (PARIN)' 306 300 CALL message( 'init_masks', 'PA0104', 1, 2, 0, 6, 0 ) 307 301 ENDIF … … 311 305 CASE ( 'q', 'thetav' ) 312 306 IF ( .NOT. humidity ) THEN 313 WRITE ( message_string, * ) 'output of "', TRIM( var ), &314 '" requires humidity = .TRUE.'307 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 308 '" requires humidity = .TRUE.' 315 309 CALL message( 'init_masks', 'PA0105', 1, 2, 0, 6, 0 ) 316 310 ENDIF … … 320 314 CASE ( 'qc' ) 321 315 IF ( .NOT. bulk_cloud_model ) THEN 322 message_string = 'output of "' // TRIM( var ) // '"' // &323 'requires bulk_cloud_model = .TRUE.'316 message_string = 'output of "' // TRIM( var ) // '"' // & 317 'requires bulk_cloud_model = .TRUE.' 324 318 CALL message( 'check_parameters', 'PA0108', 1, 2, 0, 6, 0 ) 325 319 ENDIF … … 328 322 CASE ( 'ql' ) 329 323 IF ( .NOT. ( bulk_cloud_model .OR. cloud_droplets ) ) THEN 330 WRITE ( message_string, * ) 'output of "', TRIM( var ), &331 '" requires bulk_cloud_model = .TRUE. or ',&332 'cloud_droplets = .TRUE.'324 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 325 '" requires bulk_cloud_model = .TRUE. or ', & 326 'cloud_droplets = .TRUE.' 333 327 CALL message( 'init_masks', 'PA0106', 1, 2, 0, 6, 0 ) 334 328 ENDIF … … 337 331 CASE ( 'ql_c', 'ql_v', 'ql_vp' ) 338 332 IF ( .NOT. cloud_droplets ) THEN 339 WRITE ( message_string, * ) 'output of "', TRIM( var ), &340 '" requires cloud_droplets = .TRUE.'333 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 334 '" requires cloud_droplets = .TRUE.' 341 335 CALL message( 'init_masks', 'PA0107', 1, 2, 0, 6, 0 ) 342 336 ENDIF … … 347 341 CASE ( 'qv' ) 348 342 IF ( .NOT. bulk_cloud_model ) THEN 349 WRITE ( message_string, * ) 'output of "', TRIM( var ), &350 ' " requires bulk_cloud_model = .TRUE.'343 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 344 ' " requires bulk_cloud_model = .TRUE.' 351 345 CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 ) 352 346 ENDIF … … 355 349 CASE ( 'qi' ) 356 350 IF ( .NOT. bulk_cloud_model ) THEN 357 message_string = 'output of "' // TRIM( var ) // '" ' // &358 'requires bulk_cloud_model = .TRUE.'351 message_string = 'output of "' // TRIM( var ) // '" ' // & 352 'requires bulk_cloud_model = .TRUE.' 359 353 CALL message( 'check_parameters', 'PA0108', 1, 2, 0, 6, 0 ) 360 354 ELSEIF ( .NOT. microphysics_ice_phase ) THEN 361 message_string = 'output of "' // TRIM( var ) // '" ' // &362 'requires microphysics_ice_phase = .TRUE.'355 message_string = 'output of "' // TRIM( var ) // '" ' // & 356 'requires microphysics_ice_phase = .TRUE.' 363 357 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) 364 358 ENDIF … … 367 361 CASE ( 'qr' ) 368 362 IF ( .NOT. bulk_cloud_model ) THEN 369 message_string = 'output of "' // TRIM( var ) // '" ' // &370 'requires bulk_cloud_model = .TRUE.'363 message_string = 'output of "' // TRIM( var ) // '" ' // & 364 'requires bulk_cloud_model = .TRUE.' 371 365 CALL message( 'check_parameters', 'PA0108', 1, 2, 0, 6, 0 ) 372 366 ELSEIF ( .NOT. microphysics_seifert ) THEN 373 message_string = 'output of "' // TRIM( var ) // '" ' // &374 'requires cloud_scheme = seifert_beheng'367 message_string = 'output of "' // TRIM( var ) // '" ' // & 368 'requires cloud_scheme = seifert_beheng' 375 369 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) 376 370 ENDIF … … 379 373 CASE ( 'rho_sea_water' ) 380 374 IF ( .NOT. ocean_mode ) THEN 381 WRITE ( message_string, * ) 'output of "', TRIM( var ), &382 '" requires ocean mode'375 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 376 '" requires ocean mode' 383 377 CALL message( 'init_masks', 'PA0109', 1, 2, 0, 6, 0 ) 384 378 ENDIF … … 387 381 CASE ( 's' ) 388 382 IF ( .NOT. passive_scalar ) THEN 389 WRITE ( message_string, * ) 'output of "', TRIM( var ), &390 '" requires passive_scalar = .TRUE.'383 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 384 '" requires passive_scalar = .TRUE.' 391 385 CALL message( 'init_masks', 'PA0110', 1, 2, 0, 6, 0 ) 392 386 ENDIF … … 395 389 CASE ( 'sa' ) 396 390 IF ( .NOT. ocean_mode ) THEN 397 WRITE ( message_string, * ) 'output of "', TRIM( var ), & 398 '" requires ocean mode' 391 WRITE ( message_string, * ) 'output of "', TRIM( var ), '" requires ocean mode' 399 392 CALL message( 'init_masks', 'PA0109', 1, 2, 0, 6, 0 ) 400 393 ENDIF … … 402 395 403 396 CASE ( 'us*', 't*', 'lwp*', 'pra*', 'prr*', 'z0*', 'z0h*' ) 404 WRITE ( message_string, * ) 'illegal value for data_', & 405 'output: "', TRIM( var ), '" is only allowed', & 406 'for horizontal cross section' 397 WRITE ( message_string, * ) 'illegal value for data_', 'output: "', TRIM( var ), & 398 '" is only allowed', 'for horizontal cross section' 407 399 CALL message( 'init_masks', 'PA0111', 1, 2, 0, 6, 0 ) 408 400 … … 422 414 IF ( unit == 'illegal' ) THEN 423 415 IF ( do_mask_user(mid,1) /= ' ' ) THEN 424 WRITE ( message_string, * ) 'illegal value for data_', &425 'output_masks or data_output_masks_user: "',&426 TRIM( do_mask(mid,i) ), '"'416 WRITE ( message_string, * ) 'illegal value for data_', & 417 'output_masks or data_output_masks_user: "', & 418 TRIM( do_mask(mid,i) ), '"' 427 419 CALL message( 'init_masks', 'PA0018', 1, 2, 0, 6, 0 ) 428 420 ELSE 429 WRITE ( message_string, * ) 'illegal value for data_', &430 ' output_masks : "', TRIM( do_mask(mid,i) ), '"'421 WRITE ( message_string, * ) 'illegal value for data_', & 422 ' output_masks : "', TRIM( do_mask(mid,i) ), '"' 431 423 CALL message( 'init_masks', 'PA0330', 1, 2, 0, 6, 0 ) 432 424 ENDIF … … 471 463 ELSE 472 464 ! 473 !-- Set vertical mask locations and size in case of terrain-following 474 !-- output 465 !-- Set vertical mask locations and size in case of terrain-following output 475 466 count = 0 476 467 DO WHILE ( mask_k_over_surface(mid, count+1) >= 0 ) 477 468 m = mask_k_over_surface(mid, count+1) 478 469 IF ( m > nz+1 ) THEN 479 WRITE ( message_string, '(I3,A,I3,A,I1,3A,I3)' ) &480 m,' in mask ',mid,' along dimension ', 3,&481 ' exceeds (nz+1) = ',nz+1470 WRITE ( message_string, '(I3,A,I3,A,I1,3A,I3)' ) m, ' in mask ', mid, & 471 ' along dimension ', 3, & 472 ' exceeds (nz+1) = ', nz+1 482 473 CALL message( 'init_masks', 'PA0331', 1, 2, 0, 6, 0 ) 483 474 ENDIF … … 491 482 ENDIF 492 483 ! 493 !-- Set global masks along all three dimensions (required by 494 !-- define_netcdf_header). 484 !-- Set global masks along all three dimensions (required by define_netcdf_header). 495 485 #if defined( __parallel ) 496 486 ! 497 !-- PE0 receives partial arrays from all processors of the respective mask 498 !-- a nd outputs them. Here a barrier has to be set, because otherwise499 !-- "-MPI- FATAL: Remote protocol queue full" mayoccur.487 !-- PE0 receives partial arrays from all processors of the respective mask and outputs them. Here 488 !-- a barrier has to be set, because otherwise "-MPI- FATAL: Remote protocol queue full" may 489 !-- occur. 500 490 501 491 CALL MPI_BARRIER( comm2d, ierr ) … … 519 509 !-- Receive index limits first, then arrays. 520 510 !-- Index limits are received in arbitrary order from the PEs. 521 CALL MPI_RECV( ind(1), 6, MPI_INTEGER, MPI_ANY_SOURCE, 0, & 522 comm2d, status, ierr ) 511 CALL MPI_RECV( ind(1), 6, MPI_INTEGER, MPI_ANY_SOURCE, 0, comm2d, status, ierr ) 523 512 ! 524 513 !-- Not all PEs have data for the mask. 525 514 IF ( ind(1) /= -9999 ) THEN 526 515 sender = status(MPI_SOURCE) 527 CALL MPI_RECV( tmp_array(ind(1)), ind(2)-ind(1)+1, &528 MPI_INTEGER, sender, 1, comm2d,status, ierr )516 CALL MPI_RECV( tmp_array(ind(1)), ind(2)-ind(1)+1, MPI_INTEGER, sender, 1, comm2d, & 517 status, ierr ) 529 518 mask_i_global(mid,ind(1):ind(2)) = tmp_array(ind(1):ind(2)) 530 CALL MPI_RECV( tmp_array(ind(3)), ind(4)-ind(3)+1, &531 MPI_INTEGER, sender, 2, comm2d,status, ierr )519 CALL MPI_RECV( tmp_array(ind(3)), ind(4)-ind(3)+1, MPI_INTEGER, sender, 2, comm2d, & 520 status, ierr ) 532 521 mask_j_global(mid,ind(3):ind(4)) = tmp_array(ind(3):ind(4)) 533 CALL MPI_RECV( tmp_array(ind(5)), ind(6)-ind(5)+1, &534 MPI_INTEGER, sender, 3, comm2d,status, ierr )522 CALL MPI_RECV( tmp_array(ind(5)), ind(6)-ind(5)+1, MPI_INTEGER, sender, 3, comm2d, & 523 status, ierr ) 535 524 mask_k_global(mid,ind(5):ind(6)) = tmp_array(ind(5):ind(6)) 536 525 ENDIF … … 539 528 ELSE 540 529 ! 541 !-- If at least part of the mask resides on the PE, send the index limits 542 !-- for the targetarray, otherwise send -9999 to PE0.543 IF ( mask_size_l(mid,1) > 0 .AND. mask_size_l(mid,2) > 0 .AND. &530 !-- If at least part of the mask resides on the PE, send the index limits for the target 531 !-- array, otherwise send -9999 to PE0. 532 IF ( mask_size_l(mid,1) > 0 .AND. mask_size_l(mid,2) > 0 .AND. & 544 533 mask_size_l(mid,3) > 0 ) THEN 545 534 ind(1) = mask_start_l(mid,1) … … 559 548 IF ( ind(1) /= -9999 ) THEN 560 549 tmp_array(:mask_size_l(mid,1)) = mask_i(mid,:mask_size_l(mid,1)) 561 CALL MPI_SEND( tmp_array(1), mask_size_l(mid,1), & 562 MPI_INTEGER, 0, 1, comm2d, ierr ) 550 CALL MPI_SEND( tmp_array(1), mask_size_l(mid,1), MPI_INTEGER, 0, 1, comm2d, ierr ) 563 551 tmp_array(:mask_size_l(mid,2)) = mask_j(mid,:mask_size_l(mid,2)) 564 CALL MPI_SEND( tmp_array(1), mask_size_l(mid,2), & 565 MPI_INTEGER, 0, 2, comm2d, ierr ) 552 CALL MPI_SEND( tmp_array(1), mask_size_l(mid,2), MPI_INTEGER, 0, 2, comm2d, ierr ) 566 553 tmp_array(:mask_size_l(mid,3)) = mask_k(mid,:mask_size_l(mid,3)) 567 CALL MPI_SEND( tmp_array(1), mask_size_l(mid,3), & 568 MPI_INTEGER, 0, 3, comm2d, ierr ) 554 CALL MPI_SEND( tmp_array(1), mask_size_l(mid,3), MPI_INTEGER, 0, 3, comm2d, ierr ) 569 555 ENDIF 570 556 ENDIF 571 557 ! 572 !-- A barrier has to be set, because otherwise some PEs may proceed too fast 573 !-- so that PE0 mayreceive wrong data on tag 0.558 !-- A barrier has to be set, because otherwise some PEs may proceed too fast so that PE0 may 559 !-- receive wrong data on tag 0. 574 560 CALL MPI_BARRIER( comm2d, ierr ) 575 561 576 562 IF ( netcdf_data_format > 4 ) THEN 577 578 CALL MPI_BCAST( mask_i_global(mid,:), nx+2, MPI_INTEGER, 0, comm2d, & 579 ierr ) 580 CALL MPI_BCAST( mask_j_global(mid,:), ny+2, MPI_INTEGER, 0, comm2d, & 581 ierr ) 582 CALL MPI_BCAST( mask_k_global(mid,:), nz+2, MPI_INTEGER, 0, comm2d, & 583 ierr ) 584 563 564 CALL MPI_BCAST( mask_i_global(mid,:), nx+2, MPI_INTEGER, 0, comm2d, ierr ) 565 CALL MPI_BCAST( mask_j_global(mid,:), ny+2, MPI_INTEGER, 0, comm2d, ierr ) 566 CALL MPI_BCAST( mask_k_global(mid,:), nz+2, MPI_INTEGER, 0, comm2d, ierr ) 567 585 568 ENDIF 586 569 … … 596 579 DEALLOCATE( tmp_array ) 597 580 ! 598 !-- Internal mask arrays cannot be deallocated on PE 0 because they are 599 !-- required for header outputon PE 0.581 !-- Internal mask arrays cannot be deallocated on PE 0 because they are required for header output 582 !-- on PE 0. 600 583 IF ( myid /= 0 ) DEALLOCATE( mask, mask_loop ) 601 584 602 585 CONTAINS 603 586 604 !------------------------------------------------------------------------------ !587 !--------------------------------------------------------------------------------------------------! 605 588 ! Description: 606 589 ! ------------ 607 590 !> Set local mask for each subdomain along 'dim' direction. 608 !------------------------------------------------------------------------------! 609 SUBROUTINE set_mask_locations( dim, dxyz, dxyz_string, nxyz, nxyz_string, & 610 lb, ub ) 591 !--------------------------------------------------------------------------------------------------! 592 SUBROUTINE set_mask_locations( dim, dxyz, dxyz_string, nxyz, nxyz_string, lb, ub ) 611 593 612 594 IMPLICIT NONE … … 614 596 CHARACTER (LEN=2) :: dxyz_string !< 615 597 CHARACTER (LEN=2) :: nxyz_string !< 616 598 617 599 INTEGER(iwp) :: count !< 618 600 INTEGER(iwp) :: count_l !< … … 625 607 INTEGER(iwp) :: nxyz !< 626 608 INTEGER(iwp) :: ub !< 627 609 628 610 REAL(wp) :: dxyz !< 629 611 REAL(wp) :: ddxyz !< … … 631 613 REAL(wp) :: tmp2 !< 632 614 633 count = 0; count_l = 0 634 ddxyz = 1.0_wp / dxyz 615 count = 0; count_l = 0 616 ddxyz = 1.0_wp / dxyz 635 617 tmp1 = 0.0_wp 636 618 tmp2 = 0.0_wp … … 638 620 IF ( mask(mid,dim,1) >= 0.0_wp ) THEN 639 621 ! 640 !-- use predefined mask_* array622 !-- Use predefined mask_* array 641 623 DO WHILE ( mask(mid,dim,count+1) >= 0.0_wp ) 642 624 count = count + 1 643 IF ( dim == 1 .OR.dim == 2 ) THEN625 IF ( dim == 1 .OR. dim == 2 ) THEN 644 626 m = NINT( mask(mid,dim,count) * mask_scale(dim) * ddxyz - 0.5_wp ) 645 627 IF ( m < 0 ) m = 0 ! avoid negative values … … 650 632 ENDIF 651 633 IF ( m > (nxyz+1) ) THEN 652 WRITE ( message_string, '(I3,A,I3,A,I1,3A,I3)' ) & 653 m,' in mask ',mid,' along dimension ',dim, & 654 ' exceeds (',nxyz_string,'+1) = ',nxyz+1 634 WRITE ( message_string, '(I3,A,I3,A,I1,3A,I3)' ) m, ' in mask ', mid, & 635 ' along dimension ' ,dim, & 636 ' exceeds (' ,nxyz_string, & 637 '+1) = ', nxyz+1 655 638 CALL message( 'init_masks', 'PA0331', 1, 2, 0, 6, 0 ) 656 639 ENDIF 657 IF ( ( m >= lb .AND. m <= ub ) .OR. & 658 ( m == (nxyz+1) .AND. ub == nxyz ) ) THEN 640 IF ( ( m >= lb .AND. m <= ub ) .OR. ( m == (nxyz+1) .AND. ub == nxyz ) ) THEN 659 641 IF ( count_l == 0 ) mask_start_l(mid,dim) = count 660 642 count_l = count_l + 1 … … 674 656 ELSE 675 657 ! 676 !-- use predefined mask_loop_* array, or use the default (all grid points677 !-- along thisdirection)658 !-- Use predefined mask_loop_* array, or use the default (all grid points along this 659 !-- direction) 678 660 IF ( mask_loop(mid,dim,1) < 0.0_wp ) THEN 679 661 tmp1 = mask_loop(mid,dim,1) … … 687 669 IF ( MAXVAL( mask_loop(mid,dim,1:2) ) & 688 670 > (nxyz+1) * dxyz / mask_scale(dim) ) THEN 689 WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),5A,I1,A,F9.3)' ) & 690 'mask_loop(',mid,',',dim,',1)=',mask_loop(mid,dim,1), & 691 ' and/or mask_loop(',mid,',',dim,',2)=', & 692 mask_loop(mid,dim,2),' exceed (', & 693 nxyz_string,'+1)*',dxyz_string,'/mask_scale(',dim,')=', & 671 WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),5A,I1,A,F9.3)' ) & 672 'mask_loop(', mid, ',', dim, ',1)=', mask_loop(mid,dim,1), & 673 ' and/or mask_loop(', mid, ',', dim, ',2)=', mask_loop(mid,dim,2), & 674 ' exceed (', nxyz_string,'+1)*',dxyz_string,'/mask_scale(',dim,')=', & 694 675 (nxyz+1)*dxyz/mask_scale(dim) 695 676 CALL message( 'init_masks', 'PA0332', 1, 2, 0, 6, 0 ) 696 677 ENDIF 697 loop_begin = NINT( mask_loop(mid,dim,1) * mask_scale(dim) & 698 * ddxyz - 0.5_wp ) 699 loop_end = NINT( mask_loop(mid,dim,2) * mask_scale(dim) & 700 * ddxyz - 0.5_wp ) 701 loop_stride = NINT( mask_loop(mid,dim,3) * mask_scale(dim) & 702 * ddxyz ) 678 loop_begin = NINT( mask_loop(mid,dim,1) * mask_scale(dim) * ddxyz - 0.5_wp ) 679 loop_end = NINT( mask_loop(mid,dim,2) * mask_scale(dim) * ddxyz - 0.5_wp ) 680 loop_stride = NINT( mask_loop(mid,dim,3) * mask_scale(dim) * ddxyz ) 703 681 IF ( loop_begin == -1 ) loop_begin = 0 ! avoid negative values 704 682 ELSEIF ( dim == 3 ) THEN … … 707 685 mask_loop(mid,dim,2) = zu(nz+1) / mask_scale(dim) ! (default) 708 686 ENDIF 709 IF ( MAXVAL( mask_loop(mid,dim,1:2) ) & 710 > zu(nz+1) / mask_scale(dim) ) THEN 711 WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),A,I1,A,F9.3)' ) & 712 'mask_loop(',mid,',',dim,',1)=',mask_loop(mid,dim,1), & 713 ' and/or mask_loop(',mid,',',dim,',2)=', & 714 mask_loop(mid,dim,2),' exceed zu(nz+1)/mask_scale(',dim, & 715 ')=',zu(nz+1)/mask_scale(dim) 687 IF ( MAXVAL( mask_loop(mid,dim,1:2) ) > zu(nz+1) / mask_scale(dim) ) THEN 688 WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),A,I1,A,F9.3)' ) & 689 'mask_loop(', mid, ',', dim, ',1)=', mask_loop(mid,dim,1), & 690 ' and/or mask_loop(', mid, ',', dim, ',2)=', mask_loop(mid,dim,2), & 691 ' exceed zu(nz+1)/mask_scale(', dim, ')=',zu(nz+1)/mask_scale(dim) 716 692 CALL message( 'init_masks', 'PA0333', 1, 2, 0, 6, 0 ) 717 693 ENDIF 718 ind_array = & 719 MINLOC( ABS( mask_loop(mid,dim,1) * mask_scale(dim) - zu ) ) 720 loop_begin = & 721 ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1 722 ind_array = & 723 MINLOC( ABS( mask_loop(mid,dim,2) * mask_scale(dim) - zu ) ) 724 loop_end = ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1 725 ! 726 !-- The following line assumes a constant vertical grid spacing within 727 !-- the vertical mask range; it fails for vertical grid stretching. 728 !-- Maybe revise later. Issue warning but continue execution. ABS(...) 729 !-- within the IF statement is necessary because the default value of 730 !-- dz_stretch_level_start is -9999999.9_wp. 694 ind_array = MINLOC( ABS( mask_loop(mid,dim,1) * mask_scale(dim) - zu ) ) 695 loop_begin = ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1 696 ind_array = MINLOC( ABS( mask_loop(mid,dim,2) * mask_scale(dim) - zu ) ) 697 loop_end = ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1 698 ! 699 !-- The following line assumes a constant vertical grid spacing within the vertical mask 700 !-- range; it fails for vertical grid stretching. 701 !-- Maybe revise later. Issue warning but continue execution. ABS(...) within the IF 702 !-- statement is necessary because the default value of dz_stretch_level_start is 703 !-- -9999999.9_wp. 731 704 loop_stride = NINT( mask_loop(mid,dim,3) * mask_scale(dim) * ddxyz ) 732 705 733 IF ( mask_loop(mid,dim,2) * mask_scale(dim) > & 734 ABS( dz_stretch_level_start(1) ) ) THEN 735 WRITE ( message_string, '(A,I3,A,I1,A,F9.3,A,F8.2,3A)' ) & 736 'mask_loop(',mid,',',dim,',2)=', mask_loop(mid,dim,2), & 737 ' exceeds dz_stretch_level=',dz_stretch_level_start(1), & 738 '.&Vertical mask locations will not ', & 739 'match the desired heights within the stretching ', & 740 'region.' 706 IF ( mask_loop(mid,dim,2) * mask_scale(dim) > ABS( dz_stretch_level_start(1) ) ) THEN 707 WRITE ( message_string, '(A,I3,A,I1,A,F9.3,A,F8.2,3A)' ) & 708 'mask_loop(', mid, ',', dim, ',2)=', mask_loop(mid,dim,2), & 709 ' exceeds dz_stretch_level=', dz_stretch_level_start(1), & 710 '.&Vertical mask locations will not ', & 711 'match the desired heights within the stretching ', 'region.' 741 712 CALL message( 'init_masks', 'PA0334', 0, 1, 0, 6, 0 ) 742 713 ENDIF … … 748 719 IF ( tmp2 < 0.0_wp ) mask_loop(mid,dim,2) = tmp2 749 720 ! 750 !-- The default stride +/-1 (every grid point) applies if 751 !-- mask_loop(mid,dim,3) is notspecified (its default is zero).721 !-- The default stride +/-1 (every grid point) applies if mask_loop(mid,dim,3) is not 722 !-- specified (its default is zero). 752 723 IF ( loop_stride == 0 ) THEN 753 724 IF ( loop_end >= loop_begin ) THEN … … 759 730 DO m = loop_begin, loop_end, loop_stride 760 731 count = count + 1 761 IF ( ( m >= lb .AND. m <= ub ) .OR. & 762 ( m == (nxyz+1) .AND. ub == nxyz ) ) THEN 732 IF ( ( m >= lb .AND. m <= ub ) .OR. ( m == (nxyz+1) .AND. ub == nxyz ) ) THEN 763 733 IF ( count_l == 0 ) mask_start_l(mid,dim) = count 764 734 count_l = count_l + 1
Note: See TracChangeset
for help on using the changeset viewer.
