00001
00002
00003 module ice_domain
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 use ice_kinds_mod
00025 use ice_constants
00026 use ice_communicate
00027 use ice_broadcast
00028 use ice_blocks
00029 use ice_distribution
00030 use ice_exit
00031 use ice_fileunits
00032 use ice_boundary
00033 use ice_domain_size
00034
00035 implicit none
00036 private
00037 save
00038
00039
00040
00041 public :: init_domain_blocks ,&
00042 init_domain_distribution
00043
00044
00045
00046
00047
00048 integer (int_kind), public ::
00049 nblocks
00050
00051 integer (int_kind), dimension(:), pointer, public ::
00052 blocks_ice
00053
00054 type (distrb), public ::
00055 distrb_info
00056
00057 type (ice_halo), public ::
00058 halo_info
00059
00060 logical (log_kind), public ::
00061 ltripole_grid
00062
00063 character (char_len), public ::
00064 ew_boundary_type,
00065 ns_boundary_type
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077 character (char_len), public ::
00078 distribution_type,
00079
00080
00081
00082 distribution_wght
00083
00084
00085
00086 character (char_len), public ::
00087 distribution_wght
00088
00089
00090
00091
00092
00093
00094 character (char_len_long), public ::
00095 distribution_wght_file
00096
00097 integer (int_kind) ::
00098 nprocs
00099
00100 logical (log_kind), public :: profile_barrier
00101
00102 logical (log_kind), public :: FixMaxBlock
00103 integer (int_kind), public :: maxBlock
00104
00105
00106
00107
00108 contains
00109
00110
00111
00112
00113
00114
00115 subroutine init_domain_blocks
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126 use ice_global_reductions
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136 integer (int_kind) ::
00137 nml_error
00138
00139
00140
00141
00142
00143
00144
00145 namelist /domain_nml/ nprocs, &
00146 processor_shape, &
00147 distribution_type, &
00148 distribution_wght, &
00149 distribution_wght_file, &
00150 ew_boundary_type, &
00151 ns_boundary_type, &
00152 maxBlock, &
00153 FixMaxBlock, &
00154 profile_barrier
00155
00156
00157
00158
00159
00160
00161
00162 nprocs = -1
00163 processor_shape = 'slenderX2'
00164 distribution_type = 'cartesian'
00165 distribution_wght = 'latitude'
00166 distribution_wght_file = 'unknown_distribution_wght_file'
00167 ew_boundary_type = 'cyclic'
00168 ns_boundary_type = 'open'
00169 maxBlock = max_blocks
00170 profile_barrier = .false.
00171 FixMaxBlock = .false.
00172
00173 call get_fileunit(nu_nml)
00174 if (my_task == master_task) then
00175 open (nu_nml, file=nml_filename, status='old',iostat=nml_error)
00176 if (nml_error /= 0) then
00177 nml_error = -1
00178 else
00179 nml_error = 1
00180 endif
00181 do while (nml_error > 0)
00182 read(nu_nml, nml=domain_nml,iostat=nml_error)
00183 if (nml_error > 0) read(nu_nml,*)
00184 end do
00185 if (nml_error == 0) close(nu_nml)
00186 endif
00187 call release_fileunit(nu_nml)
00188
00189 call broadcast_scalar(nml_error, master_task)
00190 if (nml_error /= 0) then
00191 call abort_ice('ice: error reading domain_nml')
00192 endif
00193
00194 call broadcast_scalar(nprocs, master_task)
00195 call broadcast_scalar(processor_shape, master_task)
00196 call broadcast_scalar(distribution_type, master_task)
00197
00198 call broadcast_scalar(distribution_wght_file, master_task)
00199 call broadcast_scalar(distribution_wght, master_task)
00200
00201 call broadcast_scalar(ew_boundary_type, master_task)
00202 call broadcast_scalar(ns_boundary_type, master_task)
00203 call broadcast_scalar(profile_barrier, master_task)
00204 call broadcast_scalar(maxBlock, master_task)
00205
00206
00207
00208
00209
00210
00211 if(trim(distribution_type) == 'spacecurve') then
00212 if(trim(distribution_wght_file) == 'unknown_distribution_wght_file') then
00213 distribution_wght = 'erfc'
00214 else
00215 distribution_wght = 'file'
00216 endif
00217 endif
00218
00219 if (trim(ns_boundary_type) == 'tripole') then
00220 ltripole_grid = .true.
00221 else
00222 ltripole_grid = .false.
00223 endif
00224
00225 if (nx_global < 1 .or. ny_global < 1 .or. ncat < 1) then
00226
00227
00228
00229 call abort_ice('ice: Invalid domain: size < 1')
00230 else if (nprocs /= get_num_procs()) then
00231
00232
00233
00234 #ifdef CCSMCOUPLED
00235 nprocs = get_num_procs()
00236 #else
00237 call abort_ice('ice: Input nprocs not same as system request')
00238 #endif
00239 else if (nghost < 1) then
00240
00241
00242
00243 call abort_ice('ice: Not enough ghost cells allocated')
00244 endif
00245
00246
00247
00248
00249
00250 call init_global_reductions (ltripole_grid)
00251
00252
00253
00254
00255
00256
00257
00258 call create_blocks(nx_global, ny_global, trim(ew_boundary_type), &
00259 trim(ns_boundary_type))
00260
00261
00262
00263
00264
00265
00266
00267
00268 if (my_task == master_task) then
00269 write(nu_diag,'(/,a18,/)')'Domain Information'
00270 write(nu_diag,'(a26,i6)') ' Horizontal domain: nx = ',nx_global
00271 write(nu_diag,'(a26,i6)') ' ny = ',ny_global
00272 write(nu_diag,'(a26,i6)') ' No. of categories: nc = ',ncat
00273 write(nu_diag,'(a26,i6)') ' No. of ice layers: ni = ',nilyr
00274 write(nu_diag,'(a26,i6)') ' No. of snow layers:ns = ',nslyr
00275 write(nu_diag,'(a26,i6)') ' Processors: total = ',nprocs
00276 write(nu_diag,'(a25,a10)') ' Processor shape: ', &
00277 trim(processor_shape)
00278 write(nu_diag,'(a25,a10)') ' Distribution type: ', &
00279 trim(distribution_type)
00280
00281
00282 write(nu_diag,'(a25,a10)') ' Distribution weight: ', &
00283 trim(distribution_wght)
00284 if(trim(distribution_wght) == 'file') then
00285 write(nu_diag,'(a30,a80)') ' Distribution weight file: ', &
00286 trim(distribution_wght_file)
00287 endif
00288 write(nu_diag,'(a26,i6)') ' max_blocks = ', max_blocks
00289 write(nu_diag,'(a26,i6,/)')' Number of ghost cells: ', nghost
00290 endif
00291
00292
00293
00294
00295 end subroutine init_domain_blocks
00296
00297
00298
00299
00300
00301
00302 subroutine init_domain_distribution(KMTG,ULATG,work_per_block,prob_per_block,blockType,bStats)
00303
00304
00305
00306
00307
00308
00309
00310
00311
00312
00313
00314
00315 real (dbl_kind), dimension(nx_global,ny_global), intent(in) ::
00316 KMTG ,
00317 ULATG
00318
00319 integer(int_kind), intent(in), dimension(:) :: work_per_block,blockType
00320
00321 real (dbl_kind), intent(in), dimension(:) :: prob_per_block
00322
00323 real (dbl_kind), intent(in), dimension(:,:) :: bStats
00324
00325
00326
00327
00328
00329
00330
00331
00332
00333 integer (int_kind), dimension (nx_global, ny_global) ::
00334 flat
00335
00336 character (char_len) :: outstring
00337
00338 integer (int_kind), parameter ::
00339 max_work_unit=10
00340
00341 integer (int_kind) ::
00342 i,j,k,n ,
00343 ig,jg ,
00344 work_unit ,
00345 nblocks_tmp ,
00346 nblocks_max
00347
00348 integer (int_kind), dimension(:), allocatable ::
00349 nocn
00350
00351
00352 type (block) ::
00353 this_block
00354
00355
00356
00357
00358
00359
00360
00361
00362
00363 if (trim(ns_boundary_type) == 'closed') then
00364 allocate(nocn(nblocks_tot))
00365 nocn = 0
00366 do n=1,nblocks_tot
00367 this_block = get_block(n,n)
00368 if (this_block%jblock == nblocks_y) then
00369 do j = this_block%jhi-1, this_block%jhi
00370 if (this_block%j_glob(j) > 0) then
00371 do i = 1, nx_block
00372 if (this_block%i_glob(i) > 0) then
00373 ig = this_block%i_glob(i)
00374 jg = this_block%j_glob(j)
00375 if (KMTG(ig,jg) > puny) nocn(n) = nocn(n) + 1
00376 endif
00377 enddo
00378 endif
00379 enddo
00380 endif
00381 if (this_block%jblock == 1) then
00382 do j = this_block%jlo, this_block%jlo+1
00383 if (this_block%j_glob(j) > 0) then
00384 do i = 1, nx_block
00385 if (this_block%i_glob(i) > 0) then
00386 ig = this_block%i_glob(i)
00387 jg = this_block%j_glob(j)
00388 if (KMTG(ig,jg) > puny) nocn(n) = nocn(n) + 1
00389 endif
00390 enddo
00391 endif
00392 enddo
00393 endif
00394 if (nocn(n) > 0) then
00395 print*, 'ice: Not enough land cells along ns edge'
00396 call abort_ice('ice: Not enough land cells along ns edge')
00397 endif
00398 enddo
00399 deallocate(nocn)
00400 endif
00401 if (trim(ew_boundary_type) == 'closed') then
00402 allocate(nocn(nblocks_tot))
00403 nocn = 0
00404 do n=1,nblocks_tot
00405 this_block = get_block(n,n)
00406 if (this_block%iblock == nblocks_x) then
00407 do j = 1, ny_block
00408 if (this_block%j_glob(j) > 0) then
00409 do i = this_block%ihi-1, this_block%ihi
00410 if (this_block%i_glob(i) > 0) then
00411 ig = this_block%i_glob(i)
00412 jg = this_block%j_glob(j)
00413 if (KMTG(ig,jg) > puny) nocn(n) = nocn(n) + 1
00414 endif
00415 enddo
00416 endif
00417 enddo
00418 endif
00419 if (this_block%iblock == 1) then
00420 do j = 1, ny_block
00421 if (this_block%j_glob(j) > 0) then
00422 do i = this_block%ilo, this_block%ilo+1
00423 if (this_block%i_glob(i) > 0) then
00424 ig = this_block%i_glob(i)
00425 jg = this_block%j_glob(j)
00426 if (KMTG(ig,jg) > puny) nocn(n) = nocn(n) + 1
00427 endif
00428 enddo
00429 endif
00430 enddo
00431 endif
00432 if (nocn(n) > 0) then
00433 print*, 'ice: Not enough land cells along ew edge'
00434 call abort_ice('ice: Not enough land cells along ew edge')
00435 endif
00436 enddo
00437 deallocate(nocn)
00438 endif
00439
00440
00441
00442
00443
00444
00445
00446
00447 if (distribution_wght == 'latitude') then
00448 flat = NINT(abs(ULATG*rad_to_deg), int_kind)
00449 else
00450 flat = 1
00451 endif
00452
00453 allocate(nocn(nblocks_tot))
00454
00455 nocn = 0
00456 do n=1,nblocks_tot
00457 this_block = get_block(n,n)
00458 do j=this_block%jlo,this_block%jhi
00459 if (this_block%j_glob(j) > 0) then
00460 do i=this_block%ilo,this_block%ihi
00461 if (this_block%i_glob(i) > 0) then
00462 ig = this_block%i_glob(i)
00463 jg = this_block%j_glob(j)
00464 if (KMTG(ig,jg) > puny .and. &
00465 (ULATG(ig,jg) < shlat/rad_to_deg .or. &
00466 ULATG(ig,jg) > nhlat/rad_to_deg) ) &
00467 nocn(n) = nocn(n) + flat(ig,jg)
00468 endif
00469 end do
00470 endif
00471 end do
00472
00473
00474
00475
00476
00477
00478
00479
00480 if (distribution_wght == 'block' .and. &
00481 nocn(n) > 0) nocn(n) = nx_block*ny_block
00482
00483 end do
00484
00485 work_unit = maxval(nocn)/max_work_unit + 1
00486
00487
00488
00489 deallocate(nocn)
00490
00491
00492
00493
00494
00495
00496
00497
00498 distrb_info = create_distribution(distribution_type, nprocs, maxBlock, &
00499 work_per_block, prob_per_block, blockType, bStats, FixMaxBlock )
00500
00501
00502
00503
00504
00505
00506
00507
00508
00509
00510 call create_local_block_ids(blocks_ice, distrb_info)
00511
00512
00513 if (associated(blocks_ice)) then
00514 nblocks = size(blocks_ice)
00515 else
00516 nblocks = 0
00517 endif
00518 nblocks_max = 0
00519 do n=0,distrb_info%nprocs - 1
00520 nblocks_tmp = nblocks
00521 call broadcast_scalar(nblocks_tmp, n)
00522 nblocks_max = max(nblocks_max,nblocks_tmp)
00523 end do
00524
00525 if (nblocks_max > max_blocks) then
00526 write(outstring,*) &
00527 'ice: no. blocks exceed max: increase max to', nblocks_max
00528 call abort_ice(trim(outstring))
00529 else if (nblocks_max < max_blocks) then
00530 write(outstring,*) &
00531 'ice: no. blocks too large: decrease max to', nblocks_max
00532 if (my_task == master_task) then
00533 write(nu_diag,*) ' ********WARNING***********'
00534 write(nu_diag,*) trim(outstring)
00535 write(nu_diag,*) ' **************************'
00536 write(nu_diag,*) ' '
00537 endif
00538 endif
00539
00540
00541
00542
00543
00544
00545
00546
00547
00548 halo_info = ice_HaloCreate(distrb_info, &
00549 trim(ns_boundary_type), &
00550 trim(ew_boundary_type), &
00551 nx_global)
00552
00553
00554
00555
00556 end subroutine init_domain_distribution
00557
00558
00559
00560
00561 end module ice_domain
00562
00563