19 #ifdef test_mpp_domains 21 use mpp_mod,
only : fatal, warning, mpp_debug, note, mpp_clock_sync,mpp_clock_detailed
22 use mpp_mod,
only : mpp_pe, mpp_npes, mpp_node, mpp_root_pe,
mpp_error, mpp_set_warn_level
23 use mpp_mod,
only : mpp_declare_pelist, mpp_set_current_pelist, mpp_sync, mpp_sync_self
24 use mpp_mod,
only : mpp_clock_begin, mpp_clock_end, mpp_clock_id
28 use mpp_domains_mod,
only : global_data_domain, bitwise_exact_sum, bgrid_ne, cgrid_ne, dgrid_ne, agrid
29 use mpp_domains_mod,
only : fold_south_edge, fold_north_edge, fold_west_edge, fold_east_edge
30 use mpp_domains_mod,
only : mpp_domain_time, cyclic_global_domain, nupdate,eupdate, xupdate, yupdate, scalar_pair
38 use mpp_domains_mod,
only : north, north_east, east, south_east, corner, center
39 use mpp_domains_mod,
only : south, south_west, west, north_west, mpp_define_mosaic_pelist
56 #include <fms_platform.h> 58 integer :: nx=128, ny=128, nz=40, stackmax=4000000
60 integer :: stdunit = 6
61 logical :: debug=.false., opened
64 integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2
65 integer :: x_cyclic_offset = 3
66 integer :: y_cyclic_offset = -4
67 character(len=32) :: warn_level =
"fatal" 68 integer :: wide_halo_x = 0, wide_halo_y = 0
69 integer :: nx_cubic = 0, ny_cubic = 0
70 logical :: test_performance = .false.
71 logical :: test_interface = .true.
72 logical :: test_nest_domain = .false.
73 logical :: test_edge_update = .false.
74 logical :: test_nonsym_edge = .false.
75 logical :: test_group = .false.
76 logical :: test_cubic_grid_redistribute = .false.
77 logical :: check_parallel = .false.
78 logical :: test_get_nbr = .false.
79 logical :: test_boundary = .false.
80 logical :: test_global_sum = .false.
81 logical :: test_halosize_performance = .false.
82 integer :: ensemble_size = 1
83 integer :: layout_cubic(2) = (/0,0/)
84 integer :: layout_tripolar(2) = (/0,0/)
85 integer :: layout_ensemble(2) = (/0,0/)
86 logical :: do_sleep = .false.
87 integer :: num_iter = 1
88 integer :: num_fields = 4
91 integer :: tile_fine = 1
92 integer :: tile_coarse = 1
93 integer :: istart_fine = 0, iend_fine = -1, jstart_fine = 0, jend_fine = -1
94 integer :: istart_coarse = 0, iend_coarse = -1, jstart_coarse = 0, jend_coarse = -1
95 integer :: npes_coarse = 0
96 integer :: npes_fine = 0
97 integer :: extra_halo = 0
98 logical :: mix_2D_3D = .false.
99 logical :: test_subset = .false.
100 logical :: test_unstruct = .false.
101 integer :: nthreads = 1
102 logical :: test_adjoint = .false.
103 logical :: wide_halo = .false.
105 namelist / test_mpp_domains_nml / nx, ny, nz, stackmax, debug, mpes, check_parallel, &
106 whalo, ehalo, shalo, nhalo, x_cyclic_offset, y_cyclic_offset, &
107 warn_level, wide_halo_x, wide_halo_y, nx_cubic, ny_cubic, &
108 test_performance, test_interface, num_fields, do_sleep, num_iter, &
109 test_nest_domain, tile_fine, tile_coarse, istart_fine, iend_fine, &
110 jstart_fine, jend_fine, istart_coarse, iend_coarse, jstart_coarse, &
111 jend_coarse, extra_halo, npes_fine, npes_coarse, mix_2d_3d, test_get_nbr, &
112 test_edge_update, test_cubic_grid_redistribute, ensemble_size, &
113 layout_cubic, layout_ensemble, nthreads, test_boundary, &
114 layout_tripolar, test_group, test_global_sum, test_subset, test_unstruct, &
115 test_nonsym_edge, test_halosize_performance, test_adjoint, wide_halo
119 integer :: outunit, errunit, io_status
120 integer :: get_cpu_affinity, base_cpu, omp_get_num_threads, omp_get_thread_num
127 #ifdef INTERNAL_FILE_NML 128 read (input_nml_file, test_mpp_domains_nml, status=io_status)
131 inquire( unit=unit, opened=opened )
132 if( .NOT.opened )
exit 134 if( unit.EQ.100 )
call mpp_error( fatal,
'Unable to locate unit number.' )
136 open( unit=unit, file=
'input.nml', iostat=io_status )
137 read( unit,test_mpp_domains_nml, iostat=io_status )
141 if (io_status > 0)
then 142 call mpp_error(fatal,
'=>test_mpp_domains: Error reading input.nml')
145 select case(trim(warn_level))
147 call mpp_set_warn_level(fatal)
149 call mpp_set_warn_level(warning)
151 call mpp_error(fatal,
"test_mpp_domains: warn_level should be fatal or warning")
158 call mpp_domains_init(mpp_debug)
160 call mpp_domains_init(mpp_domain_time)
162 call mpp_domains_set_stack_size(stackmax)
170 if( pe.EQ.mpp_root_pe() )print
'(a,9i6)',
'npes, mpes, nx, ny, nz, whalo, ehalo, shalo, nhalo =', &
171 npes, mpes, nx, ny, nz, whalo, ehalo, shalo, nhalo
175 if( wide_halo_x < 0 .OR. wide_halo_y < 0)
call mpp_error(fatal, &
176 "test_mpp_domain: both wide_halo_x and wide_halo_y should be non-negative")
177 if( wide_halo_x == 0 .NEQV. wide_halo_y == 0)
call mpp_error(fatal, &
178 "test_mpp_domain: wide_halo_x and wide_halo_y should be both zero or both positive")
181 if( nx_cubic < 0 .OR. ny_cubic < 0)
call mpp_error(fatal, &
182 "test_mpp_domain: both nx_cubic and ny_cubic should be non-negative")
183 if( nx_cubic == 0 .NEQV. ny_cubic == 0)
call mpp_error(fatal, &
184 "test_mpp_domain: nx_cubic and ny_cubic should be both zero or both positive")
186 if( test_nest_domain )
then 187 if( istart_fine > iend_fine .OR. jstart_fine > jend_fine )
call mpp_error(fatal, &
188 "test_mpp_domain: check the setting of namelist variable istart_fine, iend_fine, jstart_fine, jend_fine")
189 if( istart_coarse > iend_coarse .OR. jstart_coarse > jend_coarse )
call mpp_error(fatal, &
190 "test_mpp_domain: check the setting of namelist variable istart_coarse, iend_coarse, jstart_coarse, jend_coarse")
192 call test_update_nest_domain(
'Cubic-Grid')
196 call test_subset_update()
199 if( test_halosize_performance )
then 200 call test_halosize_update(
'Folded-north' )
201 call test_halosize_update(
'Folded-north symmetry' )
202 call test_halosize_update(
'Cubic-Grid' )
205 if( test_edge_update )
then 206 call test_update_edge(
'Cyclic' )
207 call test_update_edge(
'Folded-north' )
208 call test_update_edge(
'Folded-north symmetry' )
211 if( test_nonsym_edge )
then 212 call test_update_nonsym_edge(
'Folded-north' )
213 call test_update_nonsym_edge(
'Folded-north symmetry' )
216 if( test_performance)
then 217 call update_domains_performance(
'Folded-north')
218 call update_domains_performance(
'Cubic-Grid')
221 if( test_global_sum )
then 222 call test_mpp_global_sum(
'Folded-north')
225 if( test_cubic_grid_redistribute )
then 226 call cubic_grid_redistribute()
229 if(test_boundary)
then 230 call test_get_boundary(
'torus')
231 call test_get_boundary(
'Four-Tile')
232 call test_get_boundary(
'Cubic-Grid')
233 call test_get_boundary(
'Folded-north')
237 if (test_adjoint)
then 238 call test_get_boundary_ad(
'Four-Tile')
239 call test_halo_update_ad(
'Simple' )
240 call test_global_reduce_ad(
'Simple')
243 if( test_unstruct)
then 244 call test_unstruct_update(
'Cubic-Grid' )
248 call test_group_update(
'Folded-north' )
249 call test_group_update(
'Cubic-Grid' )
252 if( test_interface )
then 253 call test_modify_domain()
258 if(.not. wide_halo)
call test_uniform_mosaic(
'Single-Tile')
259 call test_uniform_mosaic(
'Folded-north mosaic')
260 call test_uniform_mosaic(
'Folded-north symmetry mosaic')
261 if(.not. wide_halo)
then 262 call test_uniform_mosaic(
'Folded-south symmetry mosaic')
263 call test_uniform_mosaic(
'Folded-west symmetry mosaic')
264 call test_uniform_mosaic(
'Folded-east symmetry mosaic')
265 call test_uniform_mosaic(
'Four-Tile')
267 call test_uniform_mosaic(
'Cubic-Grid')
268 call test_nonuniform_mosaic(
'Five-Tile')
270 call test_halo_update(
'Simple' )
271 call test_halo_update(
'Cyclic' )
272 call test_halo_update(
'Folded-north' )
274 call test_halo_update(
'Folded xy_halo' )
275 if(.not. wide_halo)
then 276 call test_halo_update(
'Simple symmetry' )
277 call test_halo_update(
'Cyclic symmetry' )
279 call test_halo_update(
'Folded-north symmetry' )
280 if(.not. wide_halo)
then 281 call test_halo_update(
'Folded-south symmetry' )
282 call test_halo_update(
'Folded-west symmetry' )
283 call test_halo_update(
'Folded-east symmetry' )
290 call test_global_field(
'Non-symmetry' )
291 call test_global_field(
'Symmetry center' )
292 call test_global_field(
'Symmetry corner' )
293 call test_global_field(
'Symmetry east' )
294 call test_global_field(
'Symmetry north' )
296 if(.not. wide_halo)
then 297 call test_global_reduce(
'Simple')
298 call test_global_reduce(
'Simple symmetry center')
299 call test_global_reduce(
'Simple symmetry corner')
300 call test_global_reduce(
'Simple symmetry east')
301 call test_global_reduce(
'Simple symmetry north')
302 call test_global_reduce(
'Cyclic symmetry center')
303 call test_global_reduce(
'Cyclic symmetry corner')
304 call test_global_reduce(
'Cyclic symmetry east')
305 call test_global_reduce(
'Cyclic symmetry north')
308 call test_redistribute(
'Complete pelist' )
311 if(.not. wide_halo)
then 312 call test_define_mosaic_pelist(
'One tile', 1)
313 call test_define_mosaic_pelist(
'Two uniform tile', 2)
314 call test_define_mosaic_pelist(
'Two nonuniform tile', 2)
315 call test_define_mosaic_pelist(
'Ten tile', 10)
316 call test_define_mosaic_pelist(
'Ten tile with nonuniform cost', 10)
320 if( check_parallel)
then 321 call test_parallel( )
327 if( test_get_nbr )
then 328 call test_get_neighbor_1d
329 call test_get_neighbor_non_cyclic
330 call test_get_neighbor_cyclic
331 call test_get_neighbor_folded_north
332 call test_get_neighbor_mask
335 call mpp_domains_exit()
339 subroutine test_openmp()
341 integer :: omp_get_num_thread, omp_get_max_threads, omp_get_thread_num
342 real,
allocatable :: a(:,:,:)
343 type(domain2D) :: domain
345 integer :: i,j,k, jthr
346 integer :: thrnum, maxthr
347 integer(LONG_KIND) :: sum1, sum2
353 allocate( a(isd:ied,jsd:jed,nz) )
354 maxthr = omp_get_max_threads()
355 write( outunit,
'(a,4i6)' )
'pe,js,je,maxthr=', pe, js, je, maxthr
356 if( mod(je-js+1,maxthr).NE.0 ) &
357 call mpp_error( fatal,
'maxthr must divide domain (TEMPORARY).' )
358 jthr = (je-js+1)/maxthr
360 thrnum = omp_get_thread_num()
361 write( outunit,
'(a,4i6)' )
'pe,thrnum,js,je=', &
362 pe, thrnum, js+thrnum*jthr,js+(thrnum+1)*jthr-1
363 write( outunit,
'(a,3i6)' )
'pe,thrnum,node=', pe, thrnum, mpp_node()
368 do j = js+thrnum*jthr,js+(thrnum+1)*jthr-1
371 a(i,j,k) = global(i,j,k)
379 if( sum1.EQ.sum2 )
then 380 call mpp_error( note,
'OMP parallel test OK.' )
382 if( mpp_pe().EQ.mpp_root_pe() )
write( errunit,
'(a,2z18)' )
'OMP checksums: ', sum1, sum2
383 call mpp_error( fatal,
'OMP parallel test failed.' )
387 end subroutine test_openmp
389 subroutine test_redistribute( type )
391 character(len=*),
intent(in) :: type
392 type(domain2D) :: domainx, domainy
393 type(DomainCommunicator2D),
pointer,
save :: dch =>null()
394 real,
allocatable,
dimension(:,:,:) :: gcheck, global
395 real,
allocatable,
dimension(:,:,:),
save :: x, y
396 real,
allocatable,
dimension(:,:,:),
save :: x2, y2
397 real,
allocatable,
dimension(:,:,:),
save :: x3, y3
398 real,
allocatable,
dimension(:,:,:),
save :: x4, y4
399 real,
allocatable,
dimension(:,:,:),
save :: x5, y5
400 real,
allocatable,
dimension(:,:,:),
save :: x6, y6
401 integer,
allocatable :: pelist(:)
403 integer :: is, ie, js, je, isd, ied, jsd, jed
410 allocate( gcheck(nx,ny,nz), global(nx,ny,nz) )
415 global(i,j,k) = k + i*1e-3 + j*1e-6
422 case(
'Complete pelist' )
426 "test_mpp_domains(test_redistribute): nx is less than npes, no test will be done for complete pelist")
429 allocate( pelist(0:npes-1) )
430 pelist = (/ (i,i=0,npes-1) /)
431 call mpp_declare_pelist( pelist )
432 case(
'Overlap pelist' )
434 allocate( pelist(0:pemax) )
435 pelist = (/ (i,i=0,pemax) /)
436 call mpp_declare_pelist( pelist )
437 case(
'Disjoint pelist' )
439 if( pemax+1.GE.npes )
return 440 allocate( pelist(0:pemax) )
441 pelist = (/ (i,i=0,pemax) /)
443 call mpp_declare_pelist( pelist )
446 call mpp_declare_pelist( (/ (i,i=pemax+1,npes-1) /))
448 call mpp_error( fatal,
'TEST_REDISTRIBUTE: no such test: '//
type )
453 case(
'Complete pelist' )
459 allocate( x(isd:ied,jsd:jed,nz) )
460 allocate( x2(isd:ied,jsd:jed,nz) )
461 allocate( x3(isd:ied,jsd:jed,nz) )
462 allocate( x4(isd:ied,jsd:jed,nz) )
463 allocate( x5(isd:ied,jsd:jed,nz) )
464 allocate( x6(isd:ied,jsd:jed,nz) )
466 x(is:ie,js:je,:) = global(is:ie,js:je,:)
467 x2 = x; x3 = x; x4 = x; x5 = x; x6 = x
472 allocate( y(isd:ied,jsd:jed,nz) )
473 allocate( y2(isd:ied,jsd:jed,nz) )
474 allocate( y3(isd:ied,jsd:jed,nz) )
475 allocate( y4(isd:ied,jsd:jed,nz) )
476 allocate( y5(isd:ied,jsd:jed,nz) )
477 allocate( y6(isd:ied,jsd:jed,nz) )
479 y2 = 0.;y3 = 0.;y4 = 0.;y5 = 0.;y6 = 0.
480 case(
'Overlap pelist' )
487 allocate( x(isd:ied,jsd:jed,nz) )
488 allocate( x2(isd:ied,jsd:jed,nz) )
489 allocate( x3(isd:ied,jsd:jed,nz) )
490 allocate( x4(isd:ied,jsd:jed,nz) )
491 allocate( x5(isd:ied,jsd:jed,nz) )
492 allocate( x6(isd:ied,jsd:jed,nz) )
494 x(is:ie,js:je,:) = global(is:ie,js:je,:)
495 x2 = x; x3 = x; x4 = x; x5 = x; x6 = x
497 if( any(pelist.EQ.pe) )
then 498 call mpp_set_current_pelist(pelist)
503 allocate( y(isd:ied,jsd:jed,nz) )
504 allocate( y2(isd:ied,jsd:jed,nz) )
505 allocate( y3(isd:ied,jsd:jed,nz) )
506 allocate( y4(isd:ied,jsd:jed,nz) )
507 allocate( y5(isd:ied,jsd:jed,nz) )
508 allocate( y6(isd:ied,jsd:jed,nz) )
510 y2 = 0.;y3 = 0.;y4 = 0.;y5 = 0.;y6 = 0.
512 case(
'Disjoint pelist' )
516 if( any(pelist.EQ.pe) )
then 517 call mpp_set_current_pelist(pelist)
522 allocate( y(isd:ied,jsd:jed,nz) )
523 allocate( y2(isd:ied,jsd:jed,nz) )
524 allocate( y3(isd:ied,jsd:jed,nz) )
525 allocate( y4(isd:ied,jsd:jed,nz) )
526 allocate( y5(isd:ied,jsd:jed,nz) )
527 allocate( y6(isd:ied,jsd:jed,nz) )
529 y2 = 0.;y3 = 0.;y4 = 0.;y5 = 0.;y6 = 0.
532 call mpp_set_current_pelist( (/ (i,i=pemax+1,npes-1) /) )
537 allocate( x(isd:ied,jsd:jed,nz) )
538 allocate( x2(isd:ied,jsd:jed,nz) )
539 allocate( x3(isd:ied,jsd:jed,nz) )
540 allocate( x4(isd:ied,jsd:jed,nz) )
541 allocate( x5(isd:ied,jsd:jed,nz) )
542 allocate( x6(isd:ied,jsd:jed,nz) )
544 x(is:ie,js:je,:) = global(is:ie,js:je,:)
545 x2 = x; x3 = x; x4 = x; x5 = x; x6 = x
550 call mpp_set_current_pelist()
554 id = mpp_clock_id(
type, flags=mpp_clock_sync+mpp_clock_detailed )
555 call mpp_clock_begin(id)
557 call mpp_clock_end (id)
560 if( any(pelist.EQ.pe) )
then 561 call mpp_set_current_pelist(pelist)
566 call mpp_set_current_pelist()
568 call mpp_clock_begin(id)
575 call mpp_redistribute( domainx, x6, domainy, y6, complete=.true., dc_handle=dch )
576 call mpp_clock_end (id)
579 if( any(pelist.EQ.pe) )
then 580 call mpp_set_current_pelist(pelist)
595 call mpp_set_current_pelist()
597 if(
type ==
'Complete pelist')then
598 write(outunit,*)
'Use domain communicator handle' 599 call mpp_clock_begin(id)
601 y=0.; y2=0.; y3=0.; y4=0.; y5=0.; y6=0.
608 call mpp_redistribute( domainx, x6, domainy, y6, complete=.true., dc_handle=dch )
609 call mpp_clock_end (id)
612 if( any(pelist.EQ.pe) )
then 613 call mpp_set_current_pelist(pelist)
630 call mpp_set_current_pelist()
632 deallocate(gcheck, global)
633 if(
ALLOCATED(pelist))
deallocate(pelist)
637 deallocate(x,x2,x3,x4,x5,x6)
639 if(
ALLOCATED(y))
deallocate(y,y2,y3,y4,y5,y6)
640 end subroutine test_redistribute
642 subroutine cubic_grid_redistribute
644 integer :: npes, npes_per_ensemble, npes_per_tile
645 integer :: ensemble_id, tile_id, ensemble_tile_id
646 integer :: i, j, p, n, ntiles, my_root_pe
647 integer :: isc_ens, iec_ens, jsc_ens, jec_ens
648 integer :: isd_ens, ied_ens, jsd_ens, jed_ens
649 integer :: isc, iec, jsc, jec
650 integer :: isd, ied, jsd, jed
651 integer,
allocatable :: my_ensemble_pelist(:), pe_start(:), pe_end(:)
652 integer,
allocatable :: global_indices(:,:), layout2D(:,:)
653 real,
allocatable :: x(:,:,:,:), x_ens(:,:,:), y(:,:,:)
655 type(domain2D) :: domain
656 type(domain2D),
allocatable :: domain_ensemble(:)
657 character(len=128) :: mesg
661 if(mod(npes, ensemble_size) .NE. 0)
call mpp_error(fatal, &
662 "test_mpp_domains: npes is not divisible by ensemble_size")
663 npes_per_ensemble = npes/ensemble_size
664 allocate(my_ensemble_pelist(0:npes_per_ensemble-1))
665 ensemble_id = mpp_pe()/npes_per_ensemble + 1
666 do p = 0, npes_per_ensemble-1
667 my_ensemble_pelist(p) = (ensemble_id-1)*npes_per_ensemble + p
670 call mpp_declare_pelist(my_ensemble_pelist)
676 if( mod(npes, ntiles) .NE. 0 )
call mpp_error(fatal, &
677 "test_mpp_domains: npes is not divisible by ntiles")
679 npes_per_tile = npes/ntiles
680 tile_id = mpp_pe()/npes_per_tile + 1
681 if( npes_per_tile == layout_cubic(1) * layout_cubic(2) )
then 682 layout = layout_cubic
686 allocate(global_indices(4, ntiles))
687 allocate(layout2d(2, ntiles))
688 allocate(pe_start(ntiles), pe_end(ntiles))
690 global_indices(:,n) = (/1,nx_cubic,1,ny_cubic/)
691 layout2d(:,n) = layout
695 pe_start(n) = (n-1)*npes_per_tile
696 pe_end(n) = n*npes_per_tile-1
699 call define_cubic_mosaic(
"cubic_grid", domain, (/nx_cubic,nx_cubic,nx_cubic,nx_cubic,nx_cubic,nx_cubic/), &
700 (/ny_cubic,ny_cubic,ny_cubic,ny_cubic,ny_cubic,ny_cubic/), &
701 global_indices, layout2d, pe_start, pe_end )
703 allocate(domain_ensemble(ensemble_size))
705 call mpp_set_current_pelist( my_ensemble_pelist )
706 if( mod(npes_per_ensemble, ntiles) .NE. 0 )
call mpp_error(fatal, &
707 "test_mpp_domains: npes_per_ensemble is not divisible by ntiles")
708 npes_per_tile = npes_per_ensemble/ntiles
709 my_root_pe = my_ensemble_pelist(0)
710 ensemble_tile_id = (mpp_pe() - my_root_pe)/npes_per_tile + 1
712 if( npes_per_tile == layout_ensemble(1) * layout_ensemble(2) )
then 713 layout = layout_ensemble
718 global_indices(:,n) = (/1,nx_cubic,1,ny_cubic/)
719 layout2d(:,n) = layout
723 pe_start(n) = my_root_pe + (n-1)*npes_per_tile
724 pe_end(n) = my_root_pe + n*npes_per_tile-1
727 call define_cubic_mosaic(
"cubic_grid", domain_ensemble(ensemble_id), (/nx_cubic,nx_cubic,nx_cubic,nx_cubic,nx_cubic,nx_cubic/), &
728 (/ny_cubic,ny_cubic,ny_cubic,ny_cubic,ny_cubic,ny_cubic/), &
729 global_indices, layout2d, pe_start, pe_end )
731 call mpp_set_current_pelist()
732 do n = 1, ensemble_size
736 call mpp_get_data_domain( domain_ensemble(ensemble_id), isd_ens, ied_ens, jsd_ens, jed_ens)
741 allocate(x_ens(isd_ens:ied_ens, jsd_ens:jed_ens, nz))
742 allocate(x(isd:ied, jsd:jed, nz, ensemble_size))
743 allocate(y(isd:ied, jsd:jed, nz))
747 do j = jsc_ens, jec_ens
748 do i = isc_ens, iec_ens
749 x_ens(i,j,k) = ensemble_id *1e6 + ensemble_tile_id*1e3 + i + j * 1.e-3 + k * 1.e-6
754 do n = 1, ensemble_size
761 y(i,j,k) = n *1e6 + tile_id*1e3 + i + j * 1.e-3 + k * 1.e-6
765 write(mesg,
'(a,i4)')
"cubic_grid redistribute from ensemble", n
766 call compare_checksums( x(isc:iec,jsc:jec,:,n), y(isc:iec,jsc:jec,:), trim(mesg) )
770 deallocate(x,y,x_ens)
771 allocate(x(isd:ied, jsd:jed, nz, ensemble_size))
772 allocate(x_ens(isd_ens:ied_ens, jsd_ens:jed_ens, nz))
773 allocate(y(isd_ens:ied_ens, jsd_ens:jed_ens, nz))
779 x(i,j,k,:) = i + j * 1.e-3 + k * 1.e-6
784 do n = 1, ensemble_size
788 if( ensemble_id == n )
then 790 do j = jsc_ens, jec_ens
791 do i = isc_ens, iec_ens
792 y(i,j,k) = i + j * 1.e-3 + k * 1.e-6
797 write(mesg,
'(a,i4)')
"cubic_grid redistribute to ensemble", n
798 call compare_checksums( x_ens(isc_ens:iec_ens,jsc_ens:jec_ens,:), y(isc_ens:iec_ens,jsc_ens:jec_ens,:), trim(mesg) )
801 deallocate(x, y, x_ens)
803 do n = 1, ensemble_size
806 deallocate(domain_ensemble)
808 end subroutine cubic_grid_redistribute
811 subroutine test_uniform_mosaic( type )
812 character(len=*),
intent(in) :: type
814 type(domain2D) :: domain
815 integer :: num_contact, ntiles, npes_per_tile, ntile_per_pe, update_flags
816 integer :: i, j, k, l, n, shift, tw, te, ts, tn, tsw, tnw, tse, tne
817 integer :: ism, iem, jsm, jem, wh, eh, sh, nh
818 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
821 integer,
allocatable,
dimension(:) :: tile
822 integer,
allocatable,
dimension(:) :: pe_start, pe_end, tile1, tile2
823 integer,
allocatable,
dimension(:) :: istart1, iend1, jstart1, jend1
824 integer,
allocatable,
dimension(:) :: istart2, iend2, jstart2, jend2
825 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
826 real,
allocatable,
dimension(:,:) :: global2D
827 real,
allocatable,
dimension(:,:,:) :: local1, local2
828 real,
allocatable,
dimension(:,:,:,:) :: x, y, x1, x2, x3, x4, y1, y2, y3, y4
829 real,
allocatable,
dimension(:,:,:,:) :: global1, global2, gcheck
830 real,
allocatable,
dimension(:,:,:,:) :: global1_all, global2_all, global_all
831 character(len=256) :: type2, type3
832 logical :: folded_north, folded_north_sym, folded_north_nonsym
833 logical :: folded_south_sym, folded_west_sym, folded_east_sym
834 logical :: cubic_grid, single_tile, four_tile
835 integer :: whalo_save, ehalo_save, nhalo_save, shalo_save
836 integer :: nx_save, ny_save
837 logical :: same_layout = .false.
842 if(
type ==
'Cubic-Grid' .and. nx_cubic >0)
then 847 if(wide_halo_x > 0)
then 852 if(
type ==
'Single-Tile' .OR. type ==
'Folded-north mosaic' .OR.
type ==
'Cubic-Grid') then
860 folded_north_nonsym = .false.
861 folded_north_sym = .false.
862 folded_north = .false.
863 folded_south_sym = .false.
864 folded_west_sym = .false.
865 folded_east_sym = .false.
867 single_tile = .false.
871 case (
'Single-Tile' )
875 case (
'Folded-north mosaic' )
878 folded_north_nonsym = .true.
879 case (
'Folded-north symmetry mosaic' )
882 folded_north_sym = .true.
883 case (
'Folded-south symmetry mosaic' )
886 folded_south_sym = .true.
887 case (
'Folded-west symmetry mosaic' )
890 folded_west_sym = .true.
891 case (
'Folded-east symmetry mosaic' )
894 folded_east_sym = .true.
899 case (
'Cubic-Grid' )
904 call mpp_error(note,
'TEST_MPP_DOMAINS: for Cubic_grid mosaic, nx should equal ny, '//&
905 'No test is done for Cubic-Grid mosaic. ' )
906 if(wide_halo_x > 0)
then 917 call mpp_error(fatal,
'TEST_MPP_DOMAINS: no such test: '//type)
920 folded_north = folded_north_nonsym .OR. folded_north_sym
922 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
923 if( mod(npes, ntiles) == 0 )
then 924 npes_per_tile = npes/ntiles
925 write(outunit,*)
'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
926 '", each tile will be distributed over ', npes_per_tile,
' processors.' 928 allocate(tile(ntile_per_pe))
929 tile = pe/npes_per_tile+1
932 pe_start(n) = (n-1)*npes_per_tile
933 pe_end(n) = n*npes_per_tile-1
935 else if ( mod(ntiles, npes) == 0 )
then 936 ntile_per_pe = ntiles/npes
937 write(outunit,*)
'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
938 '", there will be ', ntile_per_pe,
' tiles on each processor.' 939 allocate(tile(ntile_per_pe))
940 do n = 1, ntile_per_pe
941 tile(n) = pe*ntile_per_pe + n
944 pe_start(n) = (n-1)/ntile_per_pe
945 pe_end(n) = pe_start(n)
949 call mpp_error(note,
'TEST_MPP_DOMAINS: npes should be multiple of ntiles or ' // &
950 'ntiles should be multiple of npes. No test is done for '//trim(type) )
953 if(wide_halo_x > 0)
then 963 global_indices(:,n) = (/1,nx,1,ny/)
964 layout2d(:,n) = layout
966 same_layout = .false.
967 if(layout(1) == layout(2)) same_layout = .true.
969 allocate(tile1(num_contact), tile2(num_contact) )
970 allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) )
971 allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) )
977 tile1(1) = 1; tile2(1) = 1
978 istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny
979 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
981 tile1(2) = 1; tile2(2) = 1
982 istart1(2) = 1; iend1(2) = nx; jstart1(2) = 1; jend1(2) = 1
983 istart2(2) = 1; iend2(2) = nx; jstart2(2) = ny; jend2(2) = ny
984 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
985 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
986 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
987 name =
type, symmetry = .false. )
988 else if(folded_north)
then 990 tile1(1) = 1; tile2(1) = 1
991 istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny
992 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
994 tile1(2) = 1; tile2(2) = 1
995 istart1(2) = 1; iend1(2) = nx/2; jstart1(2) = ny; jend1(2) = ny
996 istart2(2) = nx; iend2(2) = nx/2+1; jstart2(2) = ny; jend2(2) = ny
997 if(folded_north_nonsym)
then 998 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
999 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
1000 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1001 name =
type, symmetry = .false. )
1003 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
1004 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
1005 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1006 name =
type, symmetry = .true. )
1008 else if(folded_south_sym)
then 1010 tile1(1) = 1; tile2(1) = 1
1011 istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny
1012 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
1014 tile1(2) = 1; tile2(2) = 1
1015 istart1(2) = 1; iend1(2) = nx/2; jstart1(2) = 1; jend1(2) = 1
1016 istart2(2) = nx; iend2(2) = nx/2+1; jstart2(2) = 1; jend2(2) = 1
1017 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
1018 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
1019 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1020 name =
type, symmetry = .true. )
1021 else if(folded_west_sym)
then 1023 tile1(1) = 1; tile2(1) = 1
1024 istart1(1) = 1; iend1(1) = nx; jstart1(1) = ny; jend1(1) = ny
1025 istart2(1) = 1; iend2(1) = nx; jstart2(1) = 1; jend2(1) = 1
1027 tile1(2) = 1; tile2(2) = 1
1028 istart1(2) = 1; iend1(2) = 1; jstart1(2) = 1; jend1(2) = ny/2
1029 istart2(2) = 1; iend2(2) = 1; jstart2(2) = ny; jend2(2) = ny/2+1
1030 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
1031 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
1032 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1033 name =
type, symmetry = .true. )
1034 else if(folded_east_sym)
then 1036 tile1(1) = 1; tile2(1) = 1
1037 istart1(1) = 1; iend1(1) = nx; jstart1(1) = ny; jend1(1) = ny
1038 istart2(1) = 1; iend2(1) = nx; jstart2(1) = 1; jend2(1) = 1
1040 tile1(2) = 1; tile2(2) = 1
1041 istart1(2) = nx; iend1(2) = nx; jstart1(2) = 1; jend1(2) = ny/2
1042 istart2(2) = nx; iend2(2) = nx; jstart2(2) = ny; jend2(2) = ny/2+1
1043 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
1044 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
1045 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1046 name =
type, symmetry = .true. )
1047 else if( four_tile )
then 1048 call define_fourtile_mosaic(
type, domain, (/nx,nx,nx,nx/), (/ny,ny,ny,ny/), global_indices, &
1049 layout2D, pe_start, pe_end, symmetry = .false. )
1050 else if( cubic_grid )
then 1051 call define_cubic_mosaic(
type, domain, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
1052 global_indices, layout2D, pe_start, pe_end )
1057 allocate(global2(1-whalo:nx+ehalo,1-shalo:ny+nhalo,nz, ntile_per_pe) )
1058 allocate(global_all(1:nx,1:ny,nz, ntiles) )
1064 global_all(i,j,k,l) = l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1070 do n = 1, ntile_per_pe
1071 global2(1:nx,1:ny,:,n) = global_all(:,:,:,tile(n))
1077 allocate( gcheck(nx, ny, nz, ntile_per_pe) )
1078 allocate( x(ism:iem,jsm:jem,nz, ntile_per_pe) )
1079 allocate( x1(ism:iem,jsm:jem,nz, ntile_per_pe) )
1080 allocate( x2(ism:iem,jsm:jem,nz, ntile_per_pe) )
1081 allocate( x3(ism:iem,jsm:jem,nz, ntile_per_pe) )
1082 allocate( x4(ism:iem,jsm:jem,nz, ntile_per_pe) )
1084 x(isc:iec,jsc:jec,:,:) = global2(isc:iec,jsc:jec,:,:)
1085 x1 = x; x2 = x; x3 = x; x4 = x;
1089 allocate(global2d(nx,ny))
1093 global2d(i,j) = sum(global_all(i,j,:,n))
1096 gsum = gsum + sum(global2d)
1099 do n = 1, ntile_per_pe
1102 if( pe.EQ.mpp_root_pe() )print
'(a,2es15.8,a,es12.4)', type//
' Fast sum=', lsum, gsum
1105 do n = 1, ntile_per_pe
1106 lsum =
mpp_global_sum( domain, x(:,:,:,n), bitwise_exact_sum, tile_count=n)
1108 call compare_data_scalar(lsum, gsum, fatal, type//
' mpp_global_exact_sum')
1112 id = mpp_clock_id( type//
' global field ', flags=mpp_clock_sync+mpp_clock_detailed )
1113 call mpp_clock_begin(id)
1114 do n = 1, ntile_per_pe
1117 call mpp_clock_end (id)
1119 do n = 1, ntile_per_pe
1120 call compare_checksums( global2(1:nx,1:ny,:,n), gcheck(:,:,:,n), type//
' mpp_global_field ' )
1123 id = mpp_clock_id(
type, flags=mpp_clock_sync+mpp_clock_detailed )
1124 do n = 1, ntile_per_pe
1126 if(single_tile)
then 1127 call fill_regular_mosaic_halo(global2(:,:,:,n), global_all, 1, 1, 1, 1, 1, 1, 1, 1)
1128 else if(folded_north)
then 1129 call fill_folded_north_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
1130 else if(folded_south_sym)
then 1131 call fill_folded_south_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
1132 else if(folded_west_sym)
then 1133 call fill_folded_west_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
1134 else if(folded_east_sym)
then 1135 call fill_folded_east_halo(global2(:,:,:,n), 0, 0, 0, 0, 1)
1136 else if(four_tile)
then 1137 select case ( tile(n) )
1139 tw = 2; ts = 3; tsw = 4
1141 tw = 1; ts = 4; tsw = 3
1143 tw = 4; ts = 1; tsw = 2
1145 tw = 3; ts = 2; tsw = 1
1147 te = tw; tn = ts; tse = tsw; tnw = tsw; tne = tsw
1148 call fill_regular_mosaic_halo(global2(:,:,:,n), global_all, te, tse, ts, tsw, tw, tnw, tn, tne )
1149 else if(cubic_grid)
then 1150 call fill_cubic_grid_halo(global2(:,:,:,n), global_all, global_all, tile(n), 0, 0, 1, 1 )
1154 call mpp_clock_begin(id)
1155 if(ntile_per_pe == 1)
then 1160 call mpp_clock_end (id)
1163 do n = 1, ntile_per_pe
1164 if(ntile_per_pe>1)
write(type2, *)
type,
" at tile_count = ",n
1165 call compare_checksums( x(ism:ism+ied-isd,jsm:jsm+jed-jsd,:,n), global2(isd:ied,jsd:jed,:,n), trim(type2) )
1169 if(ntile_per_pe == 1 )
then 1170 id = mpp_clock_id( type//
' partial', flags=mpp_clock_sync+mpp_clock_detailed )
1171 call mpp_clock_begin(id)
1176 call mpp_clock_end (id)
1177 call compare_checksums( x1(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//
' partial x1' )
1178 call compare_checksums( x2(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//
' partial x2' )
1179 call compare_checksums( x3(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//
' partial x3' )
1180 call compare_checksums( x4(isc:ied,jsc:jed,:,1), global2(isc:ied,jsc:jed,:,1), type//
' partial x4' )
1183 if(wide_halo_x == 0)
then 1184 if(single_tile .or. four_tile .or. (cubic_grid .and. same_layout) .or. folded_north )
then 1185 allocate(local2(isd:ied,jsd:jed,nz) )
1188 if(wh .NE. eh) cycle
1191 if(sh .NE. nh) cycle
1192 local2(isd:ied,jsd:jed,:) = global2(isd:ied,jsd:jed,:,1)
1194 x(isc:iec,jsc:jec,:,1) = local2(isc:iec,jsc:jec,:)
1195 call fill_halo_zero(local2, wh, eh, sh, nh, 0, 0, isc, iec, jsc, jec, isd, ied, jsd, jed)
1196 write(type2,
'(a,a,i2,a,i2,a,i2,a,i2)') trim(type),
' with whalo = ', wh, &
1197 ', ehalo = ',eh,
', shalo = ', sh,
', nhalo = ', nh
1198 call mpp_update_domains( x, domain, whalo=wh, ehalo=eh, shalo=sh, nhalo=nh, name = type2 )
1209 deallocate(global2, global_all, x, x1, x2, x3, x4)
1215 if(single_tile .or. four_tile .or. folded_north_nonsym)
then 1221 allocate(global1(1-whalo:nx+shift+ehalo,1-shalo:ny+shift+nhalo,nz,ntile_per_pe) )
1222 allocate(global2(1-whalo:nx+shift+ehalo,1-shalo:ny+shift+nhalo,nz,ntile_per_pe) )
1223 allocate(global1_all(nx+shift,ny+shift,nz, ntiles), global2_all(nx+shift,ny+shift,nz, ntiles))
1224 global1 = 0; global2 = 0
1229 global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1230 global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1244 if( cubic_grid )
then 1246 if(mod(l,2) == 0)
then 1249 if(te>6) te = te - 6
1250 if(tn > 6) tn = tn - 6
1251 global1_all(nx+shift,1:ny+1,:,l) = global2_all(nx+shift:1:-1,1,:,te)
1252 global2_all(nx+shift,1:ny+1,:,l) = global1_all(nx+shift:1:-1,1,:,te)
1253 global1_all(1:nx,ny+shift,:,l) = global1_all(1:nx,1,:,tn)
1254 global2_all(1:nx,ny+shift,:,l) = global2_all(1:nx,1,:,tn)
1258 if(tn > 6) tn = tn - 6
1259 global1_all(nx+shift,:,:,l) = global1_all(1,:,:,te)
1260 global2_all(nx+shift,:,:,l) = global2_all(1,:,:,te)
1261 global1_all(1:nx+1,ny+shift,:,l) = global2_all(1,ny+shift:1:-1,:,tn)
1262 global2_all(1:nx+1,ny+shift,:,l) = global1_all(1,ny+shift:1:-1,:,tn)
1266 global1_all(1,ny+1,:,:) = 0; global1_all(nx+1,1,:,:) = 0; global1_all(1,1,:,:) = 0; global1_all(nx+1,ny+1,:,:) = 0
1267 global2_all(1,ny+1,:,:) = 0; global2_all(nx+1,1,:,:) = 0; global2_all(1,1,:,:) = 0; global2_all(nx+1,ny+1,:,:) = 0
1270 do n = 1, ntile_per_pe
1271 global1(1:nx+shift,1:ny+shift,:,n) = global1_all(:,:,:,tile(n))
1272 global2(1:nx+shift,1:ny+shift,:,n) = global2_all(:,:,:,tile(n))
1275 if(folded_north)
then 1276 call fill_folded_north_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)
1277 call fill_folded_north_halo(global2(:,:,:,1), 1, 1, shift, shift, -1)
1278 else if(folded_south_sym)
then 1279 call fill_folded_south_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)
1280 call fill_folded_south_halo(global2(:,:,:,1), 1, 1, shift, shift, -1)
1281 else if(folded_west_sym)
then 1282 call fill_folded_west_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)
1283 call fill_folded_west_halo(global2(:,:,:,1), 1, 1, shift, shift, -1)
1284 else if(folded_east_sym)
then 1285 call fill_folded_east_halo(global1(:,:,:,1), 1, 1, shift, shift, -1)
1286 call fill_folded_east_halo(global2(:,:,:,1), 1, 1, shift, shift, -1)
1289 allocate( x(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1290 allocate( y(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1291 allocate( x1(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1292 allocate( x2(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1293 allocate( x3(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1294 allocate( x4(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1295 allocate( y1(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1296 allocate( y2(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1297 allocate( y3(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1298 allocate( y4(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1301 x(isc:iec+shift,jsc:jec+shift,:,:) = global1(isc:iec+shift,jsc:jec+shift,:,:)
1302 y(isc:iec+shift,jsc:jec+shift,:,:) = global2(isc:iec+shift,jsc:jec+shift,:,:)
1303 x1 = x; x2 = x; x3 = x; x4 = x
1304 y1 = y; y2 = y; y3 = y; y4 = y
1310 type2 = type//
' paired-scalar BGRID_NE' 1311 update_flags = scalar_pair
1313 type2 = type//
' vector BGRID_NE' 1314 update_flags = xupdate + yupdate
1317 id = mpp_clock_id( trim(type2), flags=mpp_clock_sync+mpp_clock_detailed )
1320 do n = 1, ntile_per_pe
1321 if(single_tile)
then 1322 call fill_regular_mosaic_halo(global1(:,:,:,n), global1_all, 1, 1, 1, 1, 1, 1, 1, 1)
1323 call fill_regular_mosaic_halo(global2(:,:,:,n), global2_all, 1, 1, 1, 1, 1, 1, 1, 1)
1324 else if(folded_north)
then 1326 global1(nx/2+shift, ny+shift,:,:) = 0.
1327 global1(nx+shift , ny+shift,:,:) = 0.
1328 global1(nx/2+1+shift:nx-1+shift, ny+shift,:,:) = -global1(nx/2-1+shift:1+shift:-1, ny+shift,:,:)
1329 global1(1-whalo:shift, ny+shift,:,:) = -global1(nx-whalo+1:nx+shift, ny+shift,:,:)
1330 global1(nx+1+shift:nx+ehalo+shift, ny+shift,:,:) = -global1(1+shift:ehalo+shift, ny+shift,:,:)
1331 global2(nx/2+shift, ny+shift,:,:) = 0.
1332 global2(nx+shift , ny+shift,:,:) = 0.
1333 global2(nx/2+1+shift:nx-1+shift, ny+shift,:,:) = -global2(nx/2-1+shift:1+shift:-1, ny+shift,:,:)
1334 global2(1-whalo:shift, ny+shift,:,:) = -global2(nx-whalo+1:nx+shift, ny+shift,:,:)
1335 global2(nx+1+shift:nx+ehalo+shift, ny+shift,:,:) = -global2(1+shift:ehalo+shift, ny+shift,:,:)
1338 global1(shift,ny+shift,:,:) = 0.
1339 global2(shift,ny+shift,:,:) = 0.
1341 else if(folded_south_sym)
then 1342 global1(nx/2+shift, 1,:,:) = 0.
1343 global1(nx+shift , 1,:,:) = 0.
1344 global1(nx/2+1+shift:nx-1+shift, 1,:,:) = -global1(nx/2-1+shift:1+shift:-1, 1,:,:)
1345 global1(1-whalo:shift, 1,:,:) = -global1(nx-whalo+1:nx+shift, 1,:,:)
1346 global1(nx+1+shift:nx+ehalo+shift, 1,:,:) = -global1(1+shift:ehalo+shift, 1,:,:)
1347 global2(nx/2+shift, 1,:,:) = 0.
1348 global2(nx+shift , 1,:,:) = 0.
1349 global2(nx/2+1+shift:nx-1+shift, 1,:,:) = -global2(nx/2-1+shift:1+shift:-1, 1,:,:)
1350 global2(1-whalo:shift, 1,:,:) = -global2(nx-whalo+1:nx+shift, 1,:,:)
1351 global2(nx+1+shift:nx+ehalo+shift, 1,:,:) = -global2(1+shift:ehalo+shift, 1,:,:)
1354 global1(shift,1,:,:) = 0.
1355 global2(shift,1,:,:) = 0.
1357 else if(folded_west_sym)
then 1358 global1(1, ny/2+shift, :,:) = 0.
1359 global1(1, ny+shift, :,:) = 0.
1360 global1(1, ny/2+1+shift:ny-1+shift, :,:) = -global1(1, ny/2-1+shift:1+shift:-1, :,:)
1361 global1(1, 1-shalo:shift, :,:) = -global1(1, ny-shalo+1:ny+shift, :,:)
1362 global1(1, ny+1+shift:ny+nhalo+shift, :,:) = -global1(1, 1+shift:nhalo+shift, :,:)
1363 global2(1, ny/2+shift, :,:) = 0.
1364 global2(1, ny+shift, :,:) = 0.
1365 global2(1, ny/2+1+shift:ny-1+shift, :,:) = -global2(1, ny/2-1+shift:1+shift:-1, :,:)
1366 global2(1, 1-shalo:shift, :,:) = -global2(1, ny-shalo+1:ny+shift, :,:)
1367 global2(1, ny+1+shift:ny+nhalo+shift, :,:) = -global2(1, 1+shift:nhalo+shift, :,:)
1370 global1(1, shift, :, :) = 0.
1371 global2(1, shift, :, :) = 0.
1373 else if(folded_east_sym)
then 1374 global1(nx+shift, ny/2+shift, :,:) = 0.
1375 global1(nx+shift, ny+shift, :,:) = 0.
1376 global1(nx+shift, ny/2+1+shift:ny-1+shift, :,:) = -global1(nx+shift, ny/2-1+shift:1+shift:-1, :,:)
1377 global1(nx+shift, 1-shalo:shift, :,:) = -global1(nx+shift, ny-shalo+1:ny+shift, :,:)
1378 global1(nx+shift, ny+1+shift:ny+nhalo+shift, :,:) = -global1(nx+shift, 1+shift:nhalo+shift, :,:)
1379 global2(nx+shift, ny/2+shift, :,:) = 0.
1380 global2(nx+shift, ny+shift, :,:) = 0.
1381 global2(nx+shift, ny/2+1+shift:ny-1+shift, :,:) = -global2(nx+shift, ny/2-1+shift:1+shift:-1, :,:)
1382 global2(nx+shift, 1-shalo:shift, :,:) = -global2(nx+shift, ny-shalo+1:ny+shift, :,:)
1383 global2(nx+shift, ny+1+shift:ny+nhalo+shift, :,:) = -global2(nx+shift, 1+shift:nhalo+shift, :,:)
1386 global1(nx+shift, shift, :,:) = 0.
1387 global2(nx+shift, shift, :,:) = 0.
1389 else if(four_tile)
then 1390 select case ( tile(n) )
1392 tw = 2; ts = 3; tsw = 4
1394 tw = 1; ts = 4; tsw = 3
1396 tw = 4; ts = 1; tsw = 2
1398 tw = 3; ts = 2; tsw = 1
1400 te = tw; tn = ts; tse = tsw; tnw = tsw; tne = tsw
1401 call fill_regular_mosaic_halo(global1(:,:,:,n), global1_all, te, tse, ts, tsw, tw, tnw, tn, tne )
1402 call fill_regular_mosaic_halo(global2(:,:,:,n), global2_all, te, tse, ts, tsw, tw, tnw, tn, tne )
1403 else if(cubic_grid)
then 1404 call fill_cubic_grid_halo(global1(:,:,:,n), global1_all, global2_all, tile(n), 1, 1, 1, 1 )
1405 call fill_cubic_grid_halo(global2(:,:,:,n), global2_all, global1_all, tile(n), 1, 1, 1, 1 )
1408 if(ntile_per_pe > 1)
write(type3, *)trim(type2),
" at tile_count = ",n
1409 call mpp_clock_begin(id)
1410 if(ntile_per_pe == 1)
then 1411 call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, flags=update_flags, gridtype=bgrid_ne, name=type3)
1413 call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, flags=update_flags, gridtype=bgrid_ne, &
1414 name=type3, tile_count = n)
1416 call mpp_clock_end (id)
1419 do n = 1, ntile_per_pe
1420 if(ntile_per_pe > 1)
write(type3, *)trim(type2),
" at tile_count = ", n
1421 call compare_checksums( x(isd:ied+shift,jsd:jed+shift,:,n), global1(isd:ied+shift,jsd:jed+shift,:,n), trim(type3)//
' X' )
1422 call compare_checksums( y(isd:ied+shift,jsd:jed+shift,:,n), global2(isd:ied+shift,jsd:jed+shift,:,n), trim(type3)//
' Y' )
1425 if(ntile_per_pe == 1)
then 1426 call mpp_clock_begin(id)
1427 call mpp_update_domains( x1, y1, domain, flags=update_flags, gridtype=bgrid_ne, complete=.false., name=type2)
1428 call mpp_update_domains( x2, y2, domain, flags=update_flags, gridtype=bgrid_ne, complete=.false., name=type2)
1429 call mpp_update_domains( x3, y3, domain, flags=update_flags, gridtype=bgrid_ne, complete=.false., name=type2)
1430 call mpp_update_domains( x4, y4, domain, flags=update_flags, gridtype=bgrid_ne, complete=.true., name=type2)
1431 call mpp_clock_end (id)
1433 call compare_checksums( x1(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' X1')
1434 call compare_checksums( x2(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' X2')
1435 call compare_checksums( x3(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' X3')
1436 call compare_checksums( x4(isd:ied+shift,jsd:jed+shift,:,1), global1(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' X4')
1437 call compare_checksums( y1(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' Y1')
1438 call compare_checksums( y2(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' Y2')
1439 call compare_checksums( y3(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' Y3')
1440 call compare_checksums( y4(isd:ied+shift,jsd:jed+shift,:,1), global2(isd:ied+shift,jsd:jed+shift,:,1), trim(type2)//
' Y4')
1443 if(wide_halo_x == 0)
then 1444 if(single_tile .or. four_tile .or. (cubic_grid .and. same_layout) .or. folded_north)
then 1445 allocate(local1(isd:ied+shift,jsd:jed+shift,nz) )
1446 allocate(local2(isd:ied+shift,jsd:jed+shift,nz) )
1449 if(wh .NE. eh) cycle
1452 if(nh .NE. sh) cycle
1454 local1(isd:ied+shift,jsd:jed+shift,:) = global1(isd:ied+shift,jsd:jed+shift,:,1)
1455 local2(isd:ied+shift,jsd:jed+shift,:) = global2(isd:ied+shift,jsd:jed+shift,:,1)
1457 x(isc:iec+shift,jsc:jec+shift,:,1) = global1(isc:iec+shift,jsc:jec+shift,:,1)
1458 y(isc:iec+shift,jsc:jec+shift,:,1) = global2(isc:iec+shift,jsc:jec+shift,:,1)
1460 call fill_halo_zero(local1, wh, eh, sh, nh, shift, shift, isc, iec, jsc, jec, isd, ied, jsd, jed)
1461 call fill_halo_zero(local2, wh, eh, sh, nh, shift, shift, isc, iec, jsc, jec, isd, ied, jsd, jed)
1462 write(type3,
'(a,a,i2,a,i2,a,i2,a,i2)') trim(type2),
' with whalo = ', wh, &
1463 ', ehalo = ',eh,
', shalo = ', sh,
', nhalo = ', nh
1465 whalo=wh, ehalo=eh, shalo=sh, nhalo=nh, name=type3)
1466 call compare_checksums( x(isd:ied+shift,jsd:jed+shift,:,1), local1, trim(type3)//
' X' )
1467 call compare_checksums( y(isd:ied+shift,jsd:jed+shift,:,1), local2, trim(type3)//
' Y' )
1472 deallocate(local1, local2)
1480 if(cubic_grid .or. folded_north .or. folded_south_sym .or. folded_west_sym .or. folded_east_sym )
then 1481 deallocate(global1_all, global2_all)
1482 allocate(global1_all(nx+shift,ny,nz, ntiles), global2_all(nx,ny+shift,nz, ntiles))
1483 deallocate(global1, global2, x, y, x1, x2, x3, x4, y1, y2, y3, y4)
1484 allocate(global1(1-whalo:nx+shift+ehalo,1-shalo:ny +nhalo,nz,ntile_per_pe) )
1485 allocate( x(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
1486 allocate( y(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
1487 allocate( x1(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
1488 allocate( x2(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
1489 allocate( x3(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
1490 allocate( x4(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
1491 allocate( y1(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
1492 allocate( y2(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
1493 allocate( y3(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
1494 allocate( y4(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
1495 allocate(global2(1-whalo:nx +ehalo,1-shalo:ny+shift+nhalo,nz,ntile_per_pe) )
1496 global1 = 0; global2 = 0
1501 global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1506 global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1512 if( folded_north .or. folded_south_sym .or. folded_west_sym .or. folded_east_sym )
then 1513 do n = 1, ntile_per_pe
1514 global1(1:nx+shift,1:ny ,:,n) = global1_all(1:nx+shift,1:ny, :,tile(n))
1515 global2(1:nx ,1:ny+shift,:,n) = global2_all(1:nx ,1:ny+shift,:,tile(n))
1519 if( cubic_grid )
then 1526 if(mod(l,2) == 0)
then 1529 if(te>6) te = te - 6
1530 if(tn > 6) tn = tn - 6
1531 global1_all(nx+shift,1:ny,:,l) = global2_all(nx:1:-1,1,:,te)
1532 global2_all(1:nx,ny+shift,:,l) = global2_all(1:nx,1,:,tn)
1536 if(tn > 6) tn = tn - 6
1537 global1_all(nx+shift,:,:,l) = global1_all(1,:,:,te)
1538 global2_all(1:nx,ny+shift,:,l) = global1_all(1,ny:1:-1,:,tn)
1541 do n = 1, ntile_per_pe
1542 global1(1:nx+shift,1:ny ,:,n) = global1_all(1:nx+shift,1:ny, :,tile(n))
1543 global2(1:nx ,1:ny+shift,:,n) = global2_all(1:nx ,1:ny+shift,:,tile(n))
1545 else if( folded_north )
then 1546 call fill_folded_north_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
1547 call fill_folded_north_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
1548 else if(folded_south_sym )
then 1549 call fill_folded_south_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
1550 call fill_folded_south_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
1551 else if(folded_west_sym )
then 1552 call fill_folded_west_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
1553 call fill_folded_west_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
1554 else if(folded_east_sym )
then 1555 call fill_folded_east_halo(global1(:,:,:,1), 1, 0, shift, 0, -1)
1556 call fill_folded_east_halo(global2(:,:,:,1), 0, 1, 0, shift, -1)
1559 x(isc:iec+shift,jsc:jec ,:,:) = global1(isc:iec+shift,jsc:jec ,:,:)
1560 y(isc:iec ,jsc:jec+shift,:,:) = global2(isc:iec ,jsc:jec+shift,:,:)
1561 x1 = x; x2 = x; x3 = x; x4 = x
1562 y1 = y; y2 = y; y3 = y; y4 = y
1572 id = mpp_clock_id( type//
' vector CGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
1574 do n = 1, ntile_per_pe
1575 if( cubic_grid )
then 1576 call fill_cubic_grid_halo(global1(:,:,:,n), global1_all, global2_all, tile(n), 1, 0, 1, -1 )
1577 call fill_cubic_grid_halo(global2(:,:,:,n), global2_all, global1_all, tile(n), 0, 1, -1, 1 )
1578 else if( folded_north )
then 1580 global2(nx/2+1:nx, ny+shift,:,:) = -global2(nx/2:1:-1, ny+shift,:,:)
1581 global2(1-whalo:0, ny+shift,:,:) = -global2(nx-whalo+1:nx, ny+shift,:,:)
1582 global2(nx+1:nx+ehalo, ny+shift,:,:) = -global2(1:ehalo, ny+shift,:,:)
1583 else if( folded_south_sym )
then 1584 global2(nx/2+1:nx, 1,:,:) = -global2(nx/2:1:-1, 1,:,:)
1585 global2(1-whalo:0, 1,:,:) = -global2(nx-whalo+1:nx, 1, :,:)
1586 global2(nx+1:nx+ehalo, 1,:,:) = -global2(1:ehalo, 1, :,:)
1587 else if( folded_west_sym )
then 1588 global1(1, ny/2+1:ny, :,:) = -global1(1, ny/2:1:-1, :,:)
1589 global1(1, 1-shalo:0, :,:) = -global1(1, ny-shalo+1:ny, :,:)
1590 global1(1, ny+1:ny+nhalo, :,:) = -global1(1, 1:nhalo, :,:)
1591 else if( folded_east_sym )
then 1592 global1(nx+shift, ny/2+1:ny, :,:) = -global1(nx+shift, ny/2:1:-1, :,:)
1593 global1(nx+shift, 1-shalo:0, :,:) = -global1(nx+shift, ny-shalo+1:ny, :,:)
1594 global1(nx+shift, ny+1:ny+nhalo, :,:) = -global1(nx+shift, 1:nhalo, :,:)
1597 if(ntile_per_pe > 1)
write(type2, *)
type,
" at tile_count = ",n
1598 call mpp_clock_begin(id)
1599 if(ntile_per_pe == 1)
then 1600 call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=cgrid_ne, name=type2//
' vector CGRID_NE')
1602 call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=cgrid_ne, &
1603 name=type2//
' vector CGRID_NE', tile_count = n)
1605 call mpp_clock_end (id)
1610 do n = 1, ntile_per_pe
1611 if(ntile_per_pe > 1)
write(type2, *)
type,
" at tile_count = ",n
1612 call compare_checksums( x(isd:ied+shift,jsd:jed,:,n), global1(isd:ied+shift,jsd:jed, :,n), &
1613 trim(type2)//
' CGRID_NE X')
1614 call compare_checksums( y(isd:ied,jsd:jed+shift,:,n), global2(isd:ied, jsd:jed+shift,:,n), &
1615 trim(type2)//
' CGRID_NE Y')
1618 if(ntile_per_pe == 1)
then 1619 call mpp_clock_begin(id)
1620 call mpp_update_domains( x1, y1, domain, gridtype=cgrid_ne, complete=.false., name=type//
' vector CGRID_NE' )
1621 call mpp_update_domains( x2, y2, domain, gridtype=cgrid_ne, complete=.false., name=type//
' vector CGRID_NE')
1622 call mpp_update_domains( x3, y3, domain, gridtype=cgrid_ne, complete=.false., name=type//
' vector CGRID_NE' )
1623 call mpp_update_domains( x4, y4, domain, gridtype=cgrid_ne, complete=.true. , name=type//
' vector CGRID_NE')
1624 call mpp_clock_end (id)
1626 call compare_checksums( x1(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//
' CGRID_NE X1')
1627 call compare_checksums( x2(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//
' CGRID_NE X2')
1628 call compare_checksums( x3(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//
' CGRID_NE X3')
1629 call compare_checksums( x4(isd:ied+shift,jsd:jed,:,1), global1(isd:ied+shift,jsd:jed,:,1), type//
' CGRID_NE X4')
1630 call compare_checksums( y1(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//
' CGRID_NE Y1')
1631 call compare_checksums( y2(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//
' CGRID_NE Y2')
1632 call compare_checksums( y3(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//
' CGRID_NE Y3')
1633 call compare_checksums( y4(isd:ied,jsd:jed+shift,:,1), global2(isd:ied,jsd:jed+shift,:,1), type//
' CGRID_NE Y4')
1636 if(wide_halo_x ==0)
then 1637 if(single_tile .or. four_tile .or. (cubic_grid .and. same_layout) .or. folded_north )
then 1638 allocate(local1(isd:ied+shift,jsd:jed, nz) )
1639 allocate(local2(isd:ied, jsd:jed+shift,nz) )
1643 if(wh .NE. eh) cycle
1646 if(sh .NE. nh) cycle
1647 local1(isd:ied+shift,jsd:jed, :) = global1(isd:ied+shift,jsd:jed, :,1)
1648 local2(isd:ied, jsd:jed+shift,:) = global2(isd:ied, jsd:jed+shift,:,1)
1650 x(isc:iec+shift,jsc:jec, :,1) = global1(isc:iec+shift,jsc:jec, :,1)
1651 y(isc:iec, jsc:jec+shift,:,1) = global2(isc:iec, jsc:jec+shift,:,1)
1652 call fill_halo_zero(local1, wh, eh, sh, nh, shift, 0, isc, iec, jsc, jec, isd, ied, jsd, jed)
1653 call fill_halo_zero(local2, wh, eh, sh, nh, 0, shift, isc, iec, jsc, jec, isd, ied, jsd, jed)
1655 write(type3,
'(a,a,i2,a,i2,a,i2,a,i2)') trim(type),
' vector CGRID_NE with whalo = ', &
1656 wh,
', ehalo = ',eh,
', shalo = ', sh,
', nhalo = ', nh
1658 shalo=sh, nhalo=nh, name=type3)
1659 call compare_checksums( x(isd:ied+shift,jsd:jed, :,1), local1, trim(type3)//
' X' )
1660 call compare_checksums( y(isd:ied,jsd:jed+shift, :,1), local2, trim(type3)//
' Y' )
1665 deallocate(local1, local2)
1670 deallocate(global1, global2, x, y, x1, x2, x3, x4, y1, y2, y3, y4, global1_all, global2_all)
1671 deallocate(layout2d, global_indices, pe_start, pe_end, tile1, tile2)
1672 deallocate(istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2 )
1674 if(wide_halo_x > 0)
then 1683 end subroutine test_uniform_mosaic
1686 subroutine update_domains_performance( type )
1687 character(len=*),
intent(in) :: type
1689 type(domain2D) :: domain
1690 integer :: num_contact, ntiles, npes_per_tile, ntile_per_pe
1691 integer :: i, j, k, l, n, shift
1692 integer :: ism, iem, jsm, jem
1693 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
1695 integer,
allocatable,
dimension(:) :: tile
1696 integer,
allocatable,
dimension(:) :: pe_start, pe_end, tile1, tile2
1697 integer,
allocatable,
dimension(:) :: istart1, iend1, jstart1, jend1
1698 integer,
allocatable,
dimension(:) :: istart2, iend2, jstart2, jend2
1699 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
1700 real,
allocatable,
dimension(:,:,:,:) :: x, x1, y, y1, x_save, y_save
1701 real,
allocatable,
dimension(:,:,:,:) :: a, a1, b, b1
1702 real,
allocatable,
dimension(:,:,: ) :: a1_2D, b1_2D
1703 integer :: id_update
1705 logical :: folded_north
1706 logical :: cubic_grid, single_tile, four_tile
1707 character(len=3) :: text
1708 integer :: nx_save, ny_save
1709 integer :: id_single, id_update_single
1711 folded_north = .false.
1712 cubic_grid = .false.
1713 single_tile = .false.
1719 case (
'Single-Tile' )
1720 single_tile = .true.
1723 case (
'Folded-north' )
1726 folded_north = .true.
1727 case (
'Four-Tile' )
1731 case (
'Cubic-Grid' )
1732 if( nx_cubic == 0 )
then 1733 call mpp_error(note,
'update_domains_performance: for Cubic_grid mosaic, nx_cubic is zero, '//&
1734 'No test is done for Cubic-Grid mosaic. ' )
1737 if( nx_cubic .NE. ny_cubic )
then 1738 call mpp_error(note,
'update_domains_performance: for Cubic_grid mosaic, nx_cubic does not equal ny_cubic, '//&
1739 'No test is done for Cubic-Grid mosaic. ' )
1750 call mpp_error(fatal,
'update_domains_performance: no such test: '//type)
1753 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
1754 if( mod(npes, ntiles) == 0 )
then 1755 npes_per_tile = npes/ntiles
1756 write(outunit,*)
'NOTE from update_domains_performance ==> For Mosaic "', trim(type), &
1757 '", each tile will be distributed over ', npes_per_tile,
' processors.' 1759 allocate(tile(ntile_per_pe))
1760 tile = pe/npes_per_tile+1
1767 pe_start(n) = (n-1)*npes_per_tile
1768 pe_end(n) = n*npes_per_tile-1
1770 else if ( mod(ntiles, npes) == 0 )
then 1771 ntile_per_pe = ntiles/npes
1772 write(outunit,*)
'NOTE from update_domains_performance ==> For Mosaic "', trim(type), &
1773 '", there will be ', ntile_per_pe,
' tiles on each processor.' 1774 allocate(tile(ntile_per_pe))
1775 do n = 1, ntile_per_pe
1776 tile(n) = pe*ntile_per_pe + n
1779 pe_start(n) = (n-1)/ntile_per_pe
1780 pe_end(n) = pe_start(n)
1784 call mpp_error(note,
'update_domains_performance: npes should be multiple of ntiles or ' // &
1785 'ntiles should be multiple of npes. No test is done for '//trim(type) )
1790 global_indices(:,n) = (/1,nx,1,ny/)
1791 layout2d(:,n) = layout
1794 allocate(tile1(num_contact), tile2(num_contact) )
1795 allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) )
1796 allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) )
1799 if(single_tile)
then 1801 tile1(1) = 1; tile2(1) = 1
1802 istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny
1803 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
1805 tile1(2) = 1; tile2(2) = 1
1806 istart1(2) = 1; iend1(2) = nx; jstart1(2) = 1; jend1(2) = 1
1807 istart2(2) = 1; iend2(2) = nx; jstart2(2) = ny; jend2(2) = ny
1808 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
1809 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
1810 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1811 name =
type, symmetry = .false. )
1812 else if(folded_north)
then 1814 tile1(1) = 1; tile2(1) = 1
1815 istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny
1816 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
1818 tile1(2) = 1; tile2(2) = 1
1819 istart1(2) = 1; iend1(2) = nx/2; jstart1(2) = ny; jend1(2) = ny
1820 istart2(2) = nx; iend2(2) = nx/2+1; jstart2(2) = ny; jend2(2) = ny
1821 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
1822 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
1823 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1824 name =
type, symmetry = .false. )
1825 else if( four_tile )
then 1826 call define_fourtile_mosaic(
type, domain, (/nx,nx,nx,nx/), (/ny,ny,ny,ny/), global_indices, &
1827 layout2D, pe_start, pe_end, symmetry = .false. )
1828 else if( cubic_grid )
then 1829 call define_cubic_mosaic(
type, domain, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
1830 global_indices, layout2D, pe_start, pe_end )
1837 allocate( x(ism:iem,jsm:jem,nz, ntile_per_pe) )
1838 allocate( x_save(ism:iem,jsm:jem,nz, ntile_per_pe) )
1839 allocate( a(ism:iem,jsm:jem,nz, ntile_per_pe) )
1841 do l = 1, ntile_per_pe
1845 x(i, j, k, l) = tile(l) + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1854 if(num_fields<1)
then 1855 call mpp_error(fatal,
"test_mpp_domains: num_fields must be a positive integer")
1858 id1 = mpp_clock_id(
type, flags=mpp_clock_sync)
1859 id_single = mpp_clock_id( type//
' non-blocking', flags=mpp_clock_sync)
1862 call mpp_clock_begin(id1)
1864 call mpp_clock_end (id1)
1866 call mpp_clock_begin(id_single)
1868 call mpp_clock_end (id_single)
1871 if(do_sleep)
call sleep(1)
1873 id1 = mpp_clock_id( type//
' group', flags=mpp_clock_sync )
1874 id2 = mpp_clock_id( type//
' group non-blocking', flags=mpp_clock_sync )
1877 if(ntile_per_pe == 1)
then 1878 allocate( x1(ism:iem,jsm:jem,nz, num_fields) )
1879 allocate( a1(ism:iem,jsm:jem,nz, num_fields) )
1880 if(mix_2d_3d)
allocate( a1_2d(ism:iem,jsm:jem,num_fields) )
1883 do l = 1, num_fields
1884 x1(:,:,:,l) = x_save(:,:,:,1)
1885 a1(:,:,:,l) = x_save(:,:,:,1)
1886 if(mix_2d_3d) a1_2d(:,:,l) = x_save(:,:,1,1)
1889 call mpp_clock_begin(id1)
1890 do l = 1, num_fields
1893 call mpp_clock_end (id1)
1896 call mpp_clock_begin(id2)
1898 do l = 1, num_fields
1903 do l = 1, num_fields
1908 call mpp_clock_end (id2)
1911 if(do_sleep)
call sleep(1)
1913 call mpp_clock_begin(id2)
1914 do l = 1, num_fields
1918 call mpp_clock_end (id2)
1922 do l = 1, num_fields
1923 write(text,
'(i3.3)') l
1929 if(mix_2d_3d)
deallocate(a1_2d)
1932 call mpp_clock_begin(id_single)
1934 call mpp_clock_end (id_single)
1936 deallocate(x, a, x_save)
1944 if(single_tile .or. four_tile .or. folded_north)
then 1950 allocate( x(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1951 allocate( y(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1952 allocate( x_save(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1953 allocate( y_save(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1954 allocate( a(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1955 allocate( b(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
1958 do l = 1, ntile_per_pe
1960 do j = jsc, jec+shift
1961 do i = isc, iec+shift
1962 x(i,j,k,l) = 1.0e3 + tile(l) + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1963 y(i,j,k,l) = 2.0e3 + tile(l) + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
1969 x_save = x; y_save = y
1971 id1 = mpp_clock_id( trim(type)//
' BGRID', flags=mpp_clock_sync )
1972 id_single = mpp_clock_id( trim(type)//
' BGRID non-blocking', flags=mpp_clock_sync )
1974 call mpp_clock_begin(id1)
1976 call mpp_clock_end (id1)
1979 call mpp_clock_begin(id_single)
1981 call mpp_clock_end (id_single)
1984 if(do_sleep)
call sleep(1)
1986 id1 = mpp_clock_id( trim(type)//
' BGRID group', flags=mpp_clock_sync)
1987 id2 = mpp_clock_id( trim(type)//
' BGRID group non-blocking', flags=mpp_clock_sync)
1988 if(ntile_per_pe == 1)
then 1989 allocate( x1(ism:iem+shift,jsm:jem+shift,nz,num_fields) )
1990 allocate( y1(ism:iem+shift,jsm:jem+shift,nz,num_fields) )
1991 allocate( a1(ism:iem+shift,jsm:jem+shift,nz,num_fields) )
1992 allocate( b1(ism:iem+shift,jsm:jem+shift,nz,num_fields) )
1994 allocate( a1_2d(ism:iem+shift,jsm:jem+shift,num_fields) )
1995 allocate( b1_2d(ism:iem+shift,jsm:jem+shift,num_fields) )
1999 do l = 1, num_fields
2000 x1(:,:,:,l) = x_save(:,:,:,1)
2001 a1(:,:,:,l) = x_save(:,:,:,1)
2002 y1(:,:,:,l) = y_save(:,:,:,1)
2003 b1(:,:,:,l) = y_save(:,:,:,1)
2005 a1_2d(:,:,l) = x_save(:,:,1,1)
2006 b1_2d(:,:,l) = y_save(:,:,1,1)
2010 call mpp_clock_begin(id1)
2011 do l = 1, num_fields
2012 call mpp_update_domains( x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=bgrid_ne, complete=l==num_fields )
2014 call mpp_clock_end (id1)
2017 call mpp_clock_begin(id2)
2019 do l = 1, num_fields
2021 gridtype=bgrid_ne, complete=.false.)
2023 gridtype=bgrid_ne, complete=l==num_fields)
2026 do l = 1, num_fields
2028 update_id=id_update, complete=.false.)
2029 id_update =
mpp_start_update_domains(a1(:,:,:,l), b1(:,:,:,l), domain, gridtype=bgrid_ne, &
2030 update_id=id_update, complete=l==num_fields)
2033 call mpp_clock_end (id2)
2036 if(do_sleep)
call sleep(1)
2038 call mpp_clock_begin(id2)
2039 do l = 1, num_fields
2041 gridtype=bgrid_ne, complete=.false.)
2042 call mpp_complete_update_domains(id_update, a1(:,:,:,l), b1(:,:,:,l), domain, &
2043 gridtype=bgrid_ne, complete=l==num_fields)
2045 call mpp_clock_end (id2)
2048 do l = 1, num_fields
2049 write(text,
'(i3.3)') l
2062 deallocate(x1, y1, a1, b1)
2063 if(mix_2d_3d)
deallocate(a1_2d, b1_2d)
2066 call mpp_clock_begin(id_single)
2068 call mpp_clock_end (id_single)
2077 deallocate(x, y, a, b, x_save, y_save)
2081 allocate( x(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
2082 allocate( y(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
2083 allocate( a(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
2084 allocate( b(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
2085 allocate( x_save(ism:iem+shift,jsm:jem ,nz,ntile_per_pe) )
2086 allocate( y_save(ism:iem ,jsm:jem+shift,nz,ntile_per_pe) )
2091 do l = 1, ntile_per_pe
2094 do i = isc, iec+shift
2095 x(i,j,k,l) = 1.0e3 + tile(l) + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
2098 do j = jsc, jec+shift
2100 y(i,j,k,l) = 2.0e3 + tile(l) + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
2107 x_save = x; y_save = y
2109 id1 = mpp_clock_id( trim(type)//
' CGRID', flags=mpp_clock_sync )
2110 id_single = mpp_clock_id( trim(type)//
' CGRID non-blocking', flags=mpp_clock_sync )
2112 call mpp_clock_begin(id1)
2114 call mpp_clock_end (id1)
2117 call mpp_clock_begin(id_single)
2119 call mpp_clock_end (id_single)
2122 if(do_sleep)
call sleep(1)
2124 id1 = mpp_clock_id( trim(type)//
' CGRID group', flags=mpp_clock_sync )
2125 id2 = mpp_clock_id( trim(type)//
' CGRID group non-blocking', flags=mpp_clock_sync )
2127 if(ntile_per_pe == 1)
then 2128 allocate( x1(ism:iem+shift,jsm:jem ,nz,num_fields) )
2129 allocate( y1(ism:iem ,jsm:jem+shift,nz,num_fields) )
2130 allocate( a1(ism:iem+shift,jsm:jem ,nz,num_fields) )
2131 allocate( b1(ism:iem ,jsm:jem+shift,nz,num_fields) )
2133 allocate( a1_2d(ism:iem+shift,jsm:jem ,num_fields) )
2134 allocate( b1_2d(ism:iem ,jsm:jem+shift,num_fields) )
2138 do l = 1, num_fields
2139 x1(:,:,:,l) = x_save(:,:,:,1)
2140 a1(:,:,:,l) = x_save(:,:,:,1)
2141 y1(:,:,:,l) = y_save(:,:,:,1)
2142 b1(:,:,:,l) = y_save(:,:,:,1)
2144 a1_2d(:,:,l) = x_save(:,:,1,1)
2145 b1_2d(:,:,l) = y_save(:,:,1,1)
2149 call mpp_clock_begin(id1)
2150 do l = 1, num_fields
2151 call mpp_update_domains( x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=cgrid_ne, complete=l==num_fields )
2153 call mpp_clock_end (id1)
2156 call mpp_clock_begin(id2)
2158 do l = 1, num_fields
2160 gridtype=cgrid_ne, complete=.false.)
2162 gridtype=cgrid_ne, complete=l==num_fields)
2165 do l = 1, num_fields
2167 update_id=id_update, complete=.false.)
2168 id_update =
mpp_start_update_domains(a1(:,:,:,l), b1(:,:,:,l), domain, gridtype=cgrid_ne, &
2169 update_id=id_update, complete=l==num_fields)
2172 call mpp_clock_end (id2)
2175 if(do_sleep)
call sleep(1)
2177 call mpp_clock_begin(id2)
2178 do l = 1, num_fields
2180 gridtype=cgrid_ne, complete=.false.)
2181 call mpp_complete_update_domains(id_update, a1(:,:,:,l), b1(:,:,:,l), domain, &
2182 gridtype=cgrid_ne, complete=l==num_fields)
2184 call mpp_clock_end (id2)
2187 do l = 1, num_fields
2188 write(text,
'(i3.3)') l
2197 deallocate(x1, y1, a1, b1)
2198 if(mix_2d_3d)
deallocate(a1_2d, b1_2d)
2201 call mpp_clock_begin(id_single)
2203 call mpp_clock_end (id_single)
2210 deallocate(x, y, a, b, x_save, y_save)
2216 allocate( x(ism:iem,jsm:jem,nz,ntile_per_pe) )
2217 allocate( y(ism:iem,jsm:jem,nz,ntile_per_pe) )
2218 allocate( a(ism:iem,jsm:jem,nz,ntile_per_pe) )
2219 allocate( b(ism:iem,jsm:jem,nz,ntile_per_pe) )
2220 allocate( x_save(ism:iem,jsm:jem,nz,ntile_per_pe) )
2221 allocate( y_save(ism:iem,jsm:jem,nz,ntile_per_pe) )
2226 do l = 1, ntile_per_pe
2229 do i = isc, iec+shift
2230 x(i,j,k,l) = 1.0e3 + tile(l) + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
2233 do j = jsc, jec+shift
2235 y(i,j,k,l) = 2.0e3 + tile(l) + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
2242 x_save = x; y_save = y
2253 x = x_save; y = y_save
2254 a = x_save; b = y_save
2265 deallocate(x, y, a, b, x_save, y_save)
2270 deallocate(layout2d, global_indices, pe_start, pe_end, tile1, tile2)
2271 deallocate(istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2 )
2274 end subroutine update_domains_performance
2278 subroutine test_mpp_global_sum( type )
2279 character(len=*),
intent(in) :: type
2281 type(domain2D) :: domain
2282 integer :: num_contact, ntiles, npes_per_tile
2283 integer :: i, j, k, l, n, shift
2284 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
2285 integer :: ism, iem, jsm, jem
2287 integer,
allocatable,
dimension(:) :: pe_start, pe_end, tile1, tile2
2288 integer,
allocatable,
dimension(:) :: istart1, iend1, jstart1, jend1
2289 integer,
allocatable,
dimension(:) :: istart2, iend2, jstart2, jend2
2290 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
2291 real,
allocatable,
dimension(:,:,:) :: data_3D
2292 real,
allocatable,
dimension(:,:) :: data_2D
2294 integer(kind=8) :: mold
2295 logical :: folded_north, cubic_grid
2296 character(len=3) :: text
2297 integer :: nx_save, ny_save
2298 integer :: id1, id2, id3, id4
2299 real :: gsum1, gsum2, gsum3, gsum4
2301 folded_north = .false.
2302 cubic_grid = .false.
2308 case (
'Folded-north' )
2312 folded_north = .true.
2313 npes_per_tile = npes
2314 if(layout_tripolar(1)*layout_tripolar(2) == npes )
then 2315 layout = layout_tripolar
2319 case (
'Cubic-Grid' )
2320 if( nx_cubic == 0 )
then 2321 call mpp_error(note,
'test_group_update: for Cubic_grid mosaic, nx_cubic is zero, '//&
2322 'No test is done for Cubic-Grid mosaic. ' )
2325 if( nx_cubic .NE. ny_cubic )
then 2326 call mpp_error(note,
'test_group_update: for Cubic_grid mosaic, nx_cubic does not equal ny_cubic, '//&
2327 'No test is done for Cubic-Grid mosaic. ' )
2336 if( mod(npes, ntiles) == 0 )
then 2337 npes_per_tile = npes/ntiles
2338 write(outunit,*)
'NOTE from test_mpp_global_sum ==> For Mosaic "', trim(type), &
2339 '", each tile will be distributed over ', npes_per_tile,
' processors.' 2341 call mpp_error(note,
'test_group_update: npes should be multiple of ntiles No test is done for '//trim(type))
2344 if(layout_cubic(1)*layout_cubic(2) == npes_per_tile)
then 2345 layout = layout_cubic
2350 call mpp_error(fatal,
'test_mpp_global_sum: no such test: '//type)
2353 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
2355 pe_start(n) = (n-1)*npes_per_tile
2356 pe_end(n) = n*npes_per_tile-1
2360 global_indices(:,n) = (/1,nx,1,ny/)
2361 layout2d(:,n) = layout
2364 allocate(tile1(num_contact), tile2(num_contact) )
2365 allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) )
2366 allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) )
2369 if(folded_north)
then 2371 tile1(1) = 1; tile2(1) = 1
2372 istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny
2373 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
2375 tile1(2) = 1; tile2(2) = 1
2376 istart1(2) = 1; iend1(2) = nx/2; jstart1(2) = ny; jend1(2) = ny
2377 istart2(2) = nx; iend2(2) = nx/2+1; jstart2(2) = ny; jend2(2) = ny
2378 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
2379 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
2380 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
2381 name =
type, symmetry = .false. )
2382 else if( cubic_grid )
then 2383 call define_cubic_mosaic(
type, domain, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
2384 global_indices, layout2D, pe_start, pe_end )
2391 allocate(data_2d(isd:ied,jsd:jed))
2392 allocate(data_3d(isd:ied,jsd:jed,nz))
2397 data_3d(i,j,k) = k*1e3 + i + j*1e-3
2404 data_2d(i,j) = i*1e3 + j*1e-3
2408 id1 = mpp_clock_id( type//
' bitwise sum 3D', flags=mpp_clock_sync )
2409 id2 = mpp_clock_id( type//
' EFP sum 3D', flags=mpp_clock_sync )
2410 id3 = mpp_clock_id( type//
' EFP sum 3D check', flags=mpp_clock_sync )
2411 id4 = mpp_clock_id( type//
' non-bitwise sum 3D', flags=mpp_clock_sync )
2413 call mpp_clock_begin(id1)
2417 call mpp_clock_end(id1)
2419 call mpp_clock_begin(id2)
2423 call mpp_clock_end(id2)
2425 call mpp_clock_begin(id3)
2427 gsum3 =
mpp_global_sum(domain, data_3d, flags=bitwise_efp_sum, overflow_check=.true. )
2429 call mpp_clock_end(id3)
2431 call mpp_clock_begin(id4)
2435 call mpp_clock_end(id4)
2437 write(outunit, *)
" ********************************************************************************" 2438 write(outunit, *)
" global sum for "//type//
' bitwise exact sum 3D = ', gsum1
2439 write(outunit, *)
" global sum for "//type//
' bitwise EFP sum 3D = ', gsum2
2440 write(outunit, *)
" global sum for "//type//
' bitwise EFP sum 3D with overflow_check = ', gsum3
2441 write(outunit, *)
" global sum for "//type//
' non-bitwise sum 3D = ', gsum4
2442 write(outunit, *)
" " 2443 write(outunit, *)
" chksum for "//type//
' bitwise exact sum 3D = ', transfer(gsum1, mold)
2444 write(outunit, *)
" chksum for "//type//
' bitwise EFP sum 3D = ', transfer(gsum2, mold)
2445 write(outunit, *)
" chksum for "//type//
' bitwise EFP sum 3D with overflow_check = ', transfer(gsum3, mold)
2446 write(outunit, *)
" chksum for "//type//
' non-bitwise sum 3D = ', transfer(gsum4, mold)
2447 write(outunit, *)
" ********************************************************************************" 2449 id1 = mpp_clock_id( type//
' bitwise sum 2D', flags=mpp_clock_sync )
2450 id2 = mpp_clock_id( type//
' EFP sum 2D', flags=mpp_clock_sync )
2451 id3 = mpp_clock_id( type//
' EFP sum 2D check', flags=mpp_clock_sync )
2452 id4 = mpp_clock_id( type//
' non-bitwise sum 2D', flags=mpp_clock_sync )
2454 call mpp_clock_begin(id1)
2458 call mpp_clock_end(id1)
2460 call mpp_clock_begin(id2)
2464 call mpp_clock_end(id2)
2466 call mpp_clock_begin(id3)
2468 gsum3 =
mpp_global_sum(domain, data_2d, flags=bitwise_efp_sum, overflow_check=.true. )
2470 call mpp_clock_end(id3)
2472 call mpp_clock_begin(id4)
2476 call mpp_clock_end(id4)
2478 write(outunit, *)
" ********************************************************************************" 2479 write(outunit, *)
" global sum for "//type//
' bitwise exact sum 2D = ', gsum1
2480 write(outunit, *)
" global sum for "//type//
' bitwise EFP sum 2D = ', gsum2
2481 write(outunit, *)
" global sum for "//type//
' bitwise EFP sum 2D with overflow_check = ', gsum3
2482 write(outunit, *)
" global sum for "//type//
' non-bitwise sum 2D = ', gsum4
2483 write(outunit, *)
" " 2484 write(outunit, *)
" chksum for "//type//
' bitwise exact sum 2D = ', transfer(gsum1, mold)
2485 write(outunit, *)
" chksum for "//type//
' bitwise EFP sum 2D = ', transfer(gsum2, mold)
2486 write(outunit, *)
" chksum for "//type//
' bitwise EFP sum 2D with overflow_check = ', transfer(gsum3, mold)
2487 write(outunit, *)
" chksum for "//type//
' non-bitwise sum 2D = ', transfer(gsum4, mold)
2488 write(outunit, *)
" ********************************************************************************" 2495 end subroutine test_mpp_global_sum
2498 subroutine test_group_update( type )
2499 character(len=*),
intent(in) :: type
2501 type(domain2D) :: domain
2502 integer :: num_contact, ntiles, npes_per_tile
2503 integer :: i, j, k, l, n, shift
2504 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
2505 integer :: ism, iem, jsm, jem
2507 integer,
allocatable,
dimension(:) :: pe_start, pe_end, tile1, tile2
2508 integer,
allocatable,
dimension(:) :: istart1, iend1, jstart1, jend1
2509 integer,
allocatable,
dimension(:) :: istart2, iend2, jstart2, jend2
2510 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
2511 real,
allocatable,
dimension(:,:,:,:) :: x1, y1, x2, y2
2512 real,
allocatable,
dimension(:,:,:,:) :: a1, a2
2513 real,
allocatable,
dimension(:,:,:) :: base
2514 integer :: id1, id2, id3
2515 logical :: folded_north
2516 logical :: cubic_grid
2517 character(len=3) :: text
2518 integer :: nx_save, ny_save
2519 type(mpp_group_update_type) :: group_update
2520 type(mpp_group_update_type),
allocatable :: update_list(:)
2522 folded_north = .false.
2523 cubic_grid = .false.
2529 case (
'Folded-north' )
2533 folded_north = .true.
2534 npes_per_tile = npes
2535 if(layout_tripolar(1)*layout_tripolar(2) == npes )
then 2536 layout = layout_tripolar
2540 case (
'Cubic-Grid' )
2541 if( nx_cubic == 0 )
then 2542 call mpp_error(note,
'test_group_update: for Cubic_grid mosaic, nx_cubic is zero, '//&
2543 'No test is done for Cubic-Grid mosaic. ' )
2546 if( nx_cubic .NE. ny_cubic )
then 2547 call mpp_error(note,
'test_group_update: for Cubic_grid mosaic, nx_cubic does not equal ny_cubic, '//&
2548 'No test is done for Cubic-Grid mosaic. ' )
2557 if( mod(npes, ntiles) == 0 )
then 2558 npes_per_tile = npes/ntiles
2559 write(outunit,*)
'NOTE from update_domains_performance ==> For Mosaic "', trim(type), &
2560 '", each tile will be distributed over ', npes_per_tile,
' processors.' 2562 call mpp_error(note,
'test_group_update: npes should be multiple of ntiles No test is done for '//trim(type))
2565 if(layout_cubic(1)*layout_cubic(2) == npes_per_tile)
then 2566 layout = layout_cubic
2571 call mpp_error(fatal,
'test_group_update: no such test: '//type)
2574 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
2576 pe_start(n) = (n-1)*npes_per_tile
2577 pe_end(n) = n*npes_per_tile-1
2581 global_indices(:,n) = (/1,nx,1,ny/)
2582 layout2d(:,n) = layout
2585 allocate(tile1(num_contact), tile2(num_contact) )
2586 allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) )
2587 allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) )
2590 if(folded_north)
then 2592 tile1(1) = 1; tile2(1) = 1
2593 istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny
2594 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
2596 tile1(2) = 1; tile2(2) = 1
2597 istart1(2) = 1; iend1(2) = nx/2; jstart1(2) = ny; jend1(2) = ny
2598 istart2(2) = nx; iend2(2) = nx/2+1; jstart2(2) = ny; jend2(2) = ny
2599 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
2600 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
2601 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
2602 name =
type, symmetry = .false. )
2603 else if( cubic_grid )
then 2604 call define_cubic_mosaic(
type, domain, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
2605 global_indices, layout2D, pe_start, pe_end )
2613 if(num_fields<1)
then 2614 call mpp_error(fatal,
"test_mpp_domains: num_fields must be a positive integer")
2617 allocate(update_list(num_fields))
2619 id1 = mpp_clock_id( type//
' group 2D', flags=mpp_clock_sync )
2620 id2 = mpp_clock_id( type//
' non-group 2D', flags=mpp_clock_sync )
2621 id3 = mpp_clock_id( type//
' non-block group 2D', flags=mpp_clock_sync )
2623 allocate( a1(ism:iem, jsm:jem, nz, num_fields) )
2624 allocate( x1(ism:iem+shift,jsm:jem, nz, num_fields) )
2625 allocate( y1(ism:iem, jsm:jem+shift, nz, num_fields) )
2626 allocate( a2(ism:iem, jsm:jem, nz, num_fields) )
2627 allocate( x2(ism:iem+shift,jsm:jem, nz, num_fields) )
2628 allocate( y2(ism:iem, jsm:jem+shift, nz, num_fields) )
2629 allocate( base(isc:iec+shift,jsc:jec+shift,nz) )
2630 a1 = 0; x1 = 0; y1 = 0
2634 do j = jsc, jec+shift
2635 do i = isc, iec+shift
2636 base(i,j,k) = k + i*1e-3 + j*1e-6
2646 do l = 1, num_fields
2647 a1(isc:iec,jsc:jec,:,l) = base(isc:iec,jsc:jec,:) + l*1e3
2650 a1(i,jsc-1,k,l) = 999;
2651 a1(i,jec+1,k,l) = 999;
2654 a1(isc-1,j,k,l) = 999
2655 a1(iec+1,j,k,l) = 999
2663 do l = 1, num_fields
2664 call mpp_update_domains( a2(:,:,:,l), domain, flags=wupdate+supdate, complete=l==num_fields )
2667 do l = 1, num_fields
2668 write(text,
'(i3.3)') l
2669 call compare_checksums(a1(isd:ied,jsd:jed,:,l),a2(isd:ied,jsd:jed,:,l),type//
' CENTER South West '//text)
2672 call mpp_clear_group_update(group_update)
2675 if(
type ==
'Cubic-Grid' ) then
2678 call mpp_create_group_update(group_update, x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=dgrid_ne)
2681 do l = 1, num_fields
2682 y1(isc:iec+shift,jsc:jec, :,l) = base(isc:iec+shift,jsc:jec, :) + l*1e3 + 1e6
2683 x1(isc:iec, jsc:jec+shift,:,l) = base(isc:iec, jsc:jec+shift,:) + l*1e3 + 2*1e6
2689 do l = 1, num_fields
2690 call mpp_update_domains( x2(:,:,:,l), y2(:,:,:,l), domain, gridtype=dgrid_ne, complete=l==num_fields )
2694 do l = 1, num_fields
2695 write(text,
'(i3.3)') l
2696 call compare_checksums(x1(isd:ied+shift,jsd:jed, :,l),x2(isd:ied+shift,jsd:jed, :,l),type//
' DGRID X'//text)
2697 call compare_checksums(y1(isd:ied, jsd:jed+shift,:,l),y2(isd:ied, jsd:jed+shift,:,l),type//
' DGRID Y'//text)
2700 call mpp_clear_group_update(group_update)
2703 a1 = 0; x1 = 0; y1 = 0
2706 call mpp_create_group_update(group_update, x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=cgrid_ne)
2710 a1 = 0; x1 = 0; y1 = 0
2711 do l = 1, num_fields
2712 a1(isc:iec, jsc:jec, :,l) = base(isc:iec, jsc:jec, :) + l*1e3
2713 x1(isc:iec+shift,jsc:jec, :,l) = base(isc:iec+shift,jsc:jec, :) + l*1e3 + 1e6
2714 y1(isc:iec, jsc:jec+shift,:,l) = base(isc:iec, jsc:jec+shift,:) + l*1e3 + 2*1e6
2716 a2 = a1; x2 = x1; y2 = y1
2717 call mpp_clock_begin(id1)
2719 call mpp_clock_end (id1)
2721 call mpp_clock_begin(id2)
2722 do l = 1, num_fields
2725 do l = 1, num_fields
2726 call mpp_update_domains( x2(:,:,:,l), y2(:,:,:,l), domain, gridtype=cgrid_ne, complete=l==num_fields )
2728 call mpp_clock_end(id2)
2731 if( n == num_iter )
then 2732 do l = 1, num_fields
2733 write(text,
'(i3.3)') l
2734 call compare_checksums(a1(isd:ied, jsd:jed, :,l),a2(isd:ied, jsd:jed, :,l),type//
' CENTER '//text)
2735 call compare_checksums(x1(isd:ied+shift,jsd:jed, :,l),x2(isd:ied+shift,jsd:jed, :,l),type//
' CGRID X'//text)
2736 call compare_checksums(y1(isd:ied, jsd:jed+shift,:,l),y2(isd:ied, jsd:jed+shift,:,l),type//
' CGRID Y'//text)
2739 a1 = 0; x1 = 0; y1 = 0
2740 do l = 1, num_fields
2741 a1(isc:iec, jsc:jec, :,l) = base(isc:iec, jsc:jec, :) + l*1e3
2742 x1(isc:iec+shift,jsc:jec, :,l) = base(isc:iec+shift,jsc:jec, :) + l*1e3 + 1e6
2743 y1(isc:iec, jsc:jec+shift,:,l) = base(isc:iec, jsc:jec+shift,:) + l*1e3 + 2*1e6
2745 call mpp_clock_begin(id3)
2748 call mpp_clock_end (id3)
2750 if( n == num_iter )
then 2751 do l = 1, num_fields
2752 write(text,
'(i3.3)') l
2754 type//
' nonblock CENTER '//text)
2755 call compare_checksums(x1(isd:ied+shift,jsd:jed, :,l),x2(isd:ied+shift,jsd:jed, :,l), &
2756 type//
' nonblock CGRID X'//text)
2757 call compare_checksums(y1(isd:ied, jsd:jed+shift,:,l),y2(isd:ied, jsd:jed+shift,:,l), &
2758 type//
' nonblock CGRID Y'//text)
2763 call mpp_clear_group_update(group_update)
2766 if( num_fields > 1 )
then 2769 call mpp_create_group_update(update_list(l), x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=cgrid_ne)
2774 a1 = 0; x1 = 0; y1 = 0
2775 do l = 1, num_fields
2776 a1(isc:iec, jsc:jec, :,l) = base(isc:iec, jsc:jec, :) + l*1e3
2777 x1(isc:iec+shift,jsc:jec, :,l) = base(isc:iec+shift,jsc:jec, :) + l*1e3 + 1e6
2778 y1(isc:iec, jsc:jec+shift,:,l) = base(isc:iec, jsc:jec+shift,:) + l*1e3 + 2*1e6
2780 do l = 1, num_fields-1
2786 do l = 2, num_fields
2790 if( n == num_iter )
then 2791 do l = 1, num_fields
2792 write(text,
'(i3.3)') l
2794 type//
' multiple nonblock CENTER '//text)
2795 call compare_checksums(x1(isd:ied+shift,jsd:jed, :,l),x2(isd:ied+shift,jsd:jed, :,l), &
2796 type//
' multiple nonblock CGRID X'//text)
2797 call compare_checksums(y1(isd:ied, jsd:jed+shift,:,l),y2(isd:ied, jsd:jed+shift,:,l), &
2798 type//
' multiple nonblock CGRID Y'//text)
2805 call mpp_clear_group_update(update_list(l))
2807 deallocate(update_list)
2812 a1 = 0; x1 = 0; y1 = 0
2813 do l = 1, num_fields
2814 a1(isc:iec, jsc:jec, :,l) = base(isc:iec, jsc:jec, :) + l*1e3
2816 a2 = a1; x2 = x1; y2 = y1
2817 call mpp_clock_begin(id1)
2819 call mpp_clock_end (id1)
2821 call mpp_clock_begin(id2)
2823 call mpp_clock_end(id2)
2826 do l = 1, num_fields
2827 write(text,
'(i3.3)') l
2828 call compare_checksums(a1(isd:ied, jsd:jed, :,l),a2(isd:ied, jsd:jed, :,l),type//
' 4D CENTER '//text)
2832 do l = 1, num_fields
2833 a1(isc:iec, jsc:jec, :,l) = base(isc:iec, jsc:jec, :) + l*1e3
2835 call mpp_clock_begin(id3)
2838 call mpp_clock_end (id3)
2841 do l = 1, num_fields
2842 write(text,
'(i3.3)') l
2844 type//
' nonblock 4D CENTER '//text)
2850 deallocate(a1, x1, y1)
2851 deallocate(a2, x2, y2)
2852 call mpp_clear_group_update(group_update)
2854 allocate( a1(ism:iem+shift,jsm:jem+shift, nz, num_fields) )
2855 allocate( x1(ism:iem+shift,jsm:jem+shift, nz, num_fields) )
2856 allocate( y1(ism:iem+shift,jsm:jem+shift, nz, num_fields) )
2857 allocate( a2(ism:iem+shift,jsm:jem+shift, nz, num_fields) )
2858 allocate( x2(ism:iem+shift,jsm:jem+shift, nz, num_fields) )
2859 allocate( y2(ism:iem+shift,jsm:jem+shift, nz, num_fields) )
2863 call mpp_create_group_update(group_update, x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=bgrid_ne)
2867 a1 = 0; x1 = 0; y1 = 0
2868 do l = 1, num_fields
2869 a1(isc:iec+shift,jsc:jec+shift,:,l) = base(isc:iec+shift,jsc:jec+shift,:) + l*1e3
2870 x1(isc:iec+shift,jsc:jec+shift,:,l) = base(isc:iec+shift,jsc:jec+shift,:) + l*1e3 + 1e6
2871 y1(isc:iec+shift,jsc:jec+shift,:,l) = base(isc:iec+shift,jsc:jec+shift,:) + l*1e3 + 2*1e6
2873 a2 = a1; x2 = x1; y2 = y1
2874 call mpp_clock_begin(id1)
2876 call mpp_clock_end (id1)
2878 call mpp_clock_begin(id2)
2879 do l = 1, num_fields
2880 call mpp_update_domains( a2(:,:,:,l), domain, position=corner, complete=l==num_fields )
2882 do l = 1, num_fields
2883 call mpp_update_domains( x2(:,:,:,l), y2(:,:,:,l), domain, gridtype=bgrid_ne, complete=l==num_fields )
2885 call mpp_clock_end(id2)
2888 if( n == num_iter )
then 2889 do l = 1, num_fields
2890 write(text,
'(i3.3)') l
2891 call compare_checksums(a1(isd:ied+shift,jsd:jed+shift,:,l),a2(isd:ied+shift,jsd:jed+shift,:,l),type//
' CORNER '//text)
2892 call compare_checksums(x1(isd:ied+shift,jsd:jed+shift,:,l),x2(isd:ied+shift,jsd:jed+shift,:,l),type//
' BGRID X'//text)
2893 call compare_checksums(y1(isd:ied+shift,jsd:jed+shift,:,l),y2(isd:ied+shift,jsd:jed+shift,:,l),type//
' BGRID Y'//text)
2897 a1 = 0; x1 = 0; y1 = 0
2898 do l = 1, num_fields
2899 a1(isc:iec+shift,jsc:jec+shift,:,l) = base(isc:iec+shift,jsc:jec+shift,:) + l*1e3
2900 x1(isc:iec+shift,jsc:jec+shift,:,l) = base(isc:iec+shift,jsc:jec+shift,:) + l*1e3 + 1e6
2901 y1(isc:iec+shift,jsc:jec+shift,:,l) = base(isc:iec+shift,jsc:jec+shift,:) + l*1e3 + 2*1e6
2903 call mpp_clock_begin(id3)
2906 call mpp_clock_end (id3)
2908 if( n == num_iter )
then 2909 do l = 1, num_fields
2910 write(text,
'(i3.3)') l
2911 call compare_checksums(a1(isd:ied+shift,jsd:jed+shift,:,l),a2(isd:ied+shift,jsd:jed+shift,:,l), &
2912 type//
' nonblockCORNER '//text)
2913 call compare_checksums(x1(isd:ied+shift,jsd:jed+shift,:,l),x2(isd:ied+shift,jsd:jed+shift,:,l), &
2914 type//
' nonblock BGRID X'//text)
2915 call compare_checksums(y1(isd:ied+shift,jsd:jed+shift,:,l),y2(isd:ied+shift,jsd:jed+shift,:,l), &
2916 type//
' nonblock BGRID Y'//text)
2921 call mpp_clear_group_update(group_update)
2929 allocate( x1(ism:iem,jsm:jem, nz, num_fields) )
2930 allocate( y1(ism:iem,jsm:jem, nz, num_fields) )
2931 allocate( x2(ism:iem,jsm:jem, nz, num_fields) )
2932 allocate( y2(ism:iem,jsm:jem, nz, num_fields) )
2935 do l = 1, num_fields
2936 x1(isc:iec,jsc:jec,:,l) = base(isc:iec,jsc:jec,:) + l*1e3 + 1e6
2937 y1(isc:iec,jsc:jec,:,l) = base(isc:iec,jsc:jec,:) + l*1e3 + 2*1e6
2942 call mpp_create_group_update(group_update, x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=agrid)
2945 do l = 1, num_fields
2946 call mpp_update_domains( x2(:,:,:,l), y2(:,:,:,l), domain, gridtype=agrid, complete=l==num_fields )
2953 do l = 1, num_fields
2954 write(text,
'(i3.3)') l
2955 call compare_checksums(x1(isd:ied,jsd:jed,:,l),x2(isd:ied,jsd:jed,:,l),type//
' AGRID X'//text)
2956 call compare_checksums(y1(isd:ied,jsd:jed,:,l),y2(isd:ied,jsd:jed,:,l),type//
' AGRID Y'//text)
2959 call mpp_clear_group_update(group_update)
2962 do l = 1, num_fields
2963 x1(isc:iec,jsc:jec,:,l) = base(isc:iec,jsc:jec,:) + l*1e3 + 1e6
2964 y1(isc:iec,jsc:jec,:,l) = base(isc:iec,jsc:jec,:) + l*1e3 + 2*1e6
2969 call mpp_create_group_update(group_update, x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=agrid, flags=scalar_pair)
2972 do l = 1, num_fields
2973 call mpp_update_domains( x2(:,:,:,l), y2(:,:,:,l), domain, gridtype=agrid, flags=scalar_pair, complete=l==num_fields)
2980 do l = 1, num_fields
2981 write(text,
'(i3.3)') l
2982 call compare_checksums(x1(isd:ied,jsd:jed,:,l),x2(isd:ied,jsd:jed,:,l),type//
' AGRID SCALAR_PAIR X'//text)
2983 call compare_checksums(y1(isd:ied,jsd:jed,:,l),y2(isd:ied,jsd:jed,:,l),type//
' AGRID SCALAR_PAIR Y'//text)
2986 call mpp_clear_group_update(group_update)
2988 deallocate(pe_start, pe_end, tile1, tile2)
2989 deallocate(istart1, iend1, jstart1, jend1)
2990 deallocate(istart2, iend2, jstart2, jend2)
2991 deallocate(layout2d, global_indices)
2993 deallocate(a1, x1, y1)
2994 deallocate(a2, x2, y2)
2998 end subroutine test_group_update
3003 subroutine test_halosize_update( type )
3004 character(len=*),
intent(in) :: type
3006 type(domain2D) :: domain
3007 integer :: ntiles, npes_per_tile
3008 integer :: i, j, k, l, n, shift
3009 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
3010 integer :: ism, iem, jsm, jem
3012 integer,
allocatable,
dimension(:) :: pe_start, pe_end
3013 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
3014 real,
allocatable,
dimension(:,:,:,:) :: x1, y1, x2, y2
3015 real,
allocatable,
dimension(:,:,:,:) :: a1, a2
3016 real,
allocatable,
dimension(:,:,:,:) :: base, global_all, global
3017 real,
allocatable,
dimension(:,:,:,:) :: base1, global1_all, global1
3018 real,
allocatable,
dimension(:,:,:,:) :: base2, global2_all, global2
3020 integer :: id1, id2, id3
3021 logical :: folded_north
3022 logical :: cubic_grid, is_symmetry
3023 character(len=3) :: text
3024 character(len=1) :: halostr
3025 integer :: nx_save, ny_save
3027 type(mpp_group_update_type) :: group_update1, group_update2
3028 type(mpp_group_update_type),
allocatable :: update_list(:)
3030 if(whalo .ne. ehalo .or. whalo .ne. shalo .or. whalo .ne. nhalo)
then 3031 call mpp_error(fatal,
"test_mpp_domains: whalo, ehalo, shalo, nhalo must be the same when test_halosize_performance=true")
3034 folded_north = .false.
3035 cubic_grid = .false.
3041 case (
'Folded-north',
'Folded-north symmetry' )
3044 folded_north = .true.
3045 npes_per_tile = npes
3046 if(layout_tripolar(1)*layout_tripolar(2) == npes )
then 3047 layout = layout_tripolar
3051 if(index(
type,
'symmetry') == 0) then
3052 is_symmetry = .false.
3054 is_symmetry = .true.
3056 case (
'Cubic-Grid' )
3057 is_symmetry = .true.
3058 if( nx_cubic == 0 )
then 3059 call mpp_error(note,
'test_halosize_update: for Cubic_grid mosaic, nx_cubic is zero, '//&
3060 'No test is done for Cubic-Grid mosaic. ' )
3063 if( nx_cubic .NE. ny_cubic )
then 3064 call mpp_error(note,
'test_halosize_update: for Cubic_grid mosaic, nx_cubic does not equal ny_cubic, '//&
3065 'No test is done for Cubic-Grid mosaic. ' )
3071 if( mod(npes, ntiles) .ne. 0 )
then 3072 call mpp_error(note,
'test_halosize_update: npes is not divisible by ntiles, no test is done for '//trim(type) )
3075 npes_per_tile = npes/ntiles
3076 mytile = mpp_pe()/npes_per_tile + 1
3078 if(layout_cubic(1)*layout_cubic(2) == npes_per_tile)
then 3079 layout = layout_cubic
3084 call mpp_error(fatal,
'test_group_update: no such test: '//type)
3088 if(is_symmetry) shift = 1
3091 if(folded_north)
then 3093 xflags=cyclic_global_domain, yflags=fold_north_edge, &
3094 whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
3095 symmetry=is_symmetry, name=
type )
3096 else if( cubic_grid )
then 3097 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
3099 pe_start(n) = (n-1)*npes_per_tile
3100 pe_end(n) = n*npes_per_tile-1
3104 global_indices(:,n) = (/1,nx,1,ny/)
3105 layout2d(:,n) = layout
3108 call define_cubic_mosaic(
type, domain, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
3109 global_indices, layout2D, pe_start, pe_end, use_memsize=.false.)
3110 deallocate(pe_start, pe_end)
3111 deallocate(layout2d, global_indices)
3118 if(num_fields<1)
then 3119 call mpp_error(fatal,
"test_mpp_domains: num_fields must be a positive integer")
3123 write(halostr,
'(I1)') whalo
3124 id1 = mpp_clock_id( type//
' halo='//halostr//
' scalar', flags=mpp_clock_sync )
3125 id2 = mpp_clock_id( type//
' halo=1 scalar', flags=mpp_clock_sync )
3127 allocate( a1(isd:ied, jsd:jed, nz, num_fields) )
3128 allocate( a2(isd:ied, jsd:jed, nz, num_fields) )
3129 allocate(base(isc:iec, jsc:jec, nz, num_fields))
3130 allocate(global_all(1:nx,1:ny,nz,ntiles) )
3131 allocate(global(1-whalo:nx+ehalo, 1-shalo:ny+nhalo, nz, num_fields))
3137 global_all(i,j,k,n) = n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
3143 do l = 1, num_fields
3144 global(1:nx,1:ny,:,l) = global_all(:,:,:,mytile)
3147 base(isc:iec,jsc:jec,:,:) = global(isc:iec,jsc:jec,:,:)
3150 do l = 1, num_fields
3151 if(folded_north)
then 3152 call fill_folded_north_halo(global(:,:,:,l), 0, 0, 0, 0, 1)
3153 else if(cubic_grid)
then 3154 call fill_cubic_grid_halo(global(:,:,:,l), global_all, global_all, mytile, 0, 0, 1, 1 )
3158 a2(isd:ied,jsd:jed,:,:) = global(isd:ied,jsd:jed,:,:)
3169 a1(isc:iec,jsc:jec,:,:) = base(isc:iec,jsc:jec,:,:)
3171 call mpp_clock_begin(id1)
3173 call mpp_clock_end(id1)
3174 if(n==num_iter)
then 3175 do l = 1, num_fields
3176 write(text,
'(i3.3)') l
3177 call compare_checksums(a1(:,:,:,l),a2(:,:,:,l),type//
' halo='//halostr//
' scalar'//text)
3184 a1(isc:iec,jsc:jec,:,:) = base(isc:iec,jsc:jec,:,:)
3188 do l = 1, num_fields
3189 write(text,
'(i3.3)') l
3190 call compare_checksums(a1(:,:,:,l),a2(:,:,:,l),type//
'nonblock halo='//halostr//
' scalar'//text)
3195 a2(isc-1:iec+1,jsc-1:jec+1,:,:) = global(isc-1:iec+1,jsc-1:jec+1,:,:)
3199 a1(isc:iec,jsc:jec,:,:) = base(isc:iec,jsc:jec,:,:)
3200 call mpp_clock_begin(id2)
3202 call mpp_clock_end(id2)
3203 if(n==num_iter)
then 3204 do l = 1, num_fields
3205 write(text,
'(i3.3)') l
3212 a1(isc:iec,jsc:jec,:,:) = base(isc:iec,jsc:jec,:,:)
3215 do l = 1, num_fields
3216 write(text,
'(i3.3)') l
3217 call compare_checksums(a1(:,:,:,l),a2(:,:,:,l),type//
' nonblock halo=1 scalar'//text)
3220 call mpp_clear_group_update(group_update1)
3221 call mpp_clear_group_update(group_update2)
3222 deallocate(a1,a2,global,global_all,base)
3225 id1 = mpp_clock_id( type//
' halo='//halostr//
' CGRID', flags=mpp_clock_sync )
3226 id2 = mpp_clock_id( type//
' halo=1 CGRID', flags=mpp_clock_sync )
3228 allocate( x1(isd:ied+shift,jsd:jed, nz, num_fields) )
3229 allocate( y1(isd:ied, jsd:jed+shift, nz, num_fields) )
3230 allocate( x2(isd:ied+shift,jsd:jed, nz, num_fields) )
3231 allocate( y2(isd:ied, jsd:jed+shift, nz, num_fields) )
3232 allocate(base1(isc:iec+shift, jsc:jec, nz, num_fields))
3233 allocate(base2(isc:iec, jsc:jec+shift, nz, num_fields))
3234 allocate(global1_all(1:nx+shift,1:ny,nz,ntiles) )
3235 allocate(global2_all(1:nx,1:ny+shift,nz,ntiles) )
3236 allocate(global1(1-whalo:nx+ehalo+shift, 1-shalo:ny+nhalo, nz, num_fields))
3237 allocate(global2(1-whalo:nx+ehalo, 1-shalo:ny+nhalo+shift, nz, num_fields))
3242 global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
3247 global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
3253 global1 = 0.0; global2 = 0.0
3254 do l = 1, num_fields
3255 global1(1:nx+shift,1:ny,:,l) = global1_all(1:nx+shift,1:ny,:,mytile)
3256 global2(1:nx,1:ny+shift,:,l) = global2_all(1:nx,1:ny+shift,:,mytile)
3259 if(folded_north)
then 3260 do l = 1, num_fields
3261 call fill_folded_north_halo(global1(:,:,:,l), 1, 0, shift, 0, -1)
3262 call fill_folded_north_halo(global2(:,:,:,l), 0, 1, 0, shift, -1)
3266 base1(isc:iec+shift,jsc:jec,:,:) = global1(isc:iec+shift,jsc:jec,:,:)
3267 base2(isc:iec,jsc:jec+shift,:,:) = global2(isc:iec,jsc:jec+shift,:,:)
3269 if(folded_north)
then 3271 global2(nx/2+1:nx, ny+shift,:,:) = -global2(nx/2:1:-1, ny+shift,:,:)
3272 global2(1-whalo:0, ny+shift,:,:) = -global2(nx-whalo+1:nx, ny+shift,:,:)
3273 global2(nx+1:nx+ehalo, ny+shift,:,:) = -global2(1:ehalo, ny+shift,:,:)
3274 else if(cubic_grid)
then 3275 do l = 1, num_fields
3276 call fill_cubic_grid_halo(global1(:,:,:,l), global1_all, global2_all, mytile, 1, 0, 1, -1 )
3277 call fill_cubic_grid_halo(global2(:,:,:,l), global2_all, global1_all, mytile, 0, 1, -1, 1 )
3283 call mpp_create_group_update(group_update1, x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=cgrid_ne)
3286 call mpp_create_group_update(group_update2, x1(:,:,:,l), y1(:,:,:,l), domain, gridtype=cgrid_ne, &
3287 whalo=1, ehalo=1, shalo=1, nhalo=1 )
3290 x2(:,:,:,:) = global1(isd:ied+shift,jsd:jed,:,:)
3291 y2(:,:,:,:) = global2(isd:ied,jsd:jed+shift,:,:)
3295 x1(isc:iec+shift,jsc:jec, :,:) = base1(isc:iec+shift,jsc:jec, :,:)
3296 y1(isc:iec, jsc:jec+shift,:,:) = base2(isc:iec, jsc:jec+shift,:,:)
3297 call mpp_clock_begin(id1)
3299 call mpp_clock_end(id1)
3300 if(n==num_iter)
then 3301 do l = 1, num_fields
3302 write(text,
'(i3.3)') l
3303 call compare_checksums(x1(:,:,:,l),x2(:,:,:,l),type//
' halo='//halostr//
' CGRID X'//text)
3304 call compare_checksums(y1(:,:,:,l),y2(:,:,:,l),type//
' halo='//halostr//
' CGRID Y'//text)
3311 x1(isc:iec+shift,jsc:jec, :,:) = base1(isc:iec+shift,jsc:jec, :,:)
3312 y1(isc:iec, jsc:jec+shift,:,:) = base2(isc:iec, jsc:jec+shift,:,:)
3315 do l = 1, num_fields
3316 write(text,
'(i3.3)') l
3317 call compare_checksums(x1(:,:,:,l),x2(:,:,:,l),type//
' nonblock halo='//halostr//
' CGRID X'//text)
3318 call compare_checksums(y1(:,:,:,l),y2(:,:,:,l),type//
' nonblock halo='//halostr//
' CGRID Y'//text)
3322 x2(isc-1:iec+1+shift,jsc-1:jec+1,:,:) = global1(isc-1:iec+1+shift,jsc-1:jec+1,:,:)
3323 y2(isc-1:iec+1,jsc-1:jec+1+shift,:,:) = global2(isc-1:iec+1,jsc-1:jec+1+shift,:,:)
3327 x1(isc:iec+shift,jsc:jec, :,:) = base1(isc:iec+shift,jsc:jec, :,:)
3328 y1(isc:iec, jsc:jec+shift,:,:) = base2(isc:iec, jsc:jec+shift,:,:)
3329 call mpp_clock_begin(id2)
3331 call mpp_clock_end(id2)
3332 if(n==num_iter)
then 3333 do l = 1, num_fields
3334 write(text,
'(i3.3)') l
3342 x1(isc:iec+shift,jsc:jec, :,:) = base1(isc:iec+shift,jsc:jec, :,:)
3343 y1(isc:iec, jsc:jec+shift,:,:) = base2(isc:iec, jsc:jec+shift,:,:)
3346 do l = 1, num_fields
3347 write(text,
'(i3.3)') l
3348 call compare_checksums(x1(:,:,:,l),x2(:,:,:,l),type//
' nonblock halo=1 CGRID X'//text)
3349 call compare_checksums(y1(:,:,:,l),y2(:,:,:,l),type//
' nonblock halo=1 CGRID Y'//text)
3352 call mpp_clear_group_update(group_update1)
3353 call mpp_clear_group_update(group_update2)
3355 deallocate(x1, y1, global1, global2)
3356 deallocate(x2, y2, global1_all, global2_all)
3357 deallocate(base1, base2)
3360 end subroutine test_halosize_update
3363 subroutine test_unstruct_update( type )
3364 character(len=*),
intent(in) :: type
3366 type(domain2D) :: SG_domain
3367 type(domainUG) :: UG_domain
3368 integer :: num_contact, ntiles, npes_per_tile
3369 integer :: i, j, k, l, n, shift
3370 integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
3371 integer :: ism, iem, jsm, jem, lsg, leg
3373 integer,
allocatable,
dimension(:) :: pe_start, pe_end, npts_tile, grid_index, ntiles_grid
3374 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
3375 real,
allocatable,
dimension(:,:) :: x1, x2, g1, g2
3376 real,
allocatable,
dimension(:,:,:) :: a1, a2, gdata
3377 real,
allocatable,
dimension(:,:) :: rmask
3378 real,
allocatable,
dimension(:) :: frac_crit
3379 logical,
allocatable,
dimension(:,:,:) :: lmask
3380 integer,
allocatable,
dimension(:) :: isl, iel, jsl, jel
3381 logical :: cubic_grid
3382 character(len=3) :: text
3383 integer :: nx_save, ny_save, tile
3384 integer :: ntotal_land, istart, iend, pos
3386 cubic_grid = .false.
3392 case (
'Cubic-Grid' )
3393 if( nx_cubic == 0 )
then 3394 call mpp_error(note,
'test_unstruct_update: for Cubic_grid mosaic, nx_cubic is zero, '//&
3395 'No test is done for Cubic-Grid mosaic. ' )
3398 if( nx_cubic .NE. ny_cubic )
then 3399 call mpp_error(note,
'test_unstruct_update: for Cubic_grid mosaic, nx_cubic does not equal ny_cubic, '//&
3400 'No test is done for Cubic-Grid mosaic. ' )
3408 if( mod(npes, ntiles) == 0 )
then 3409 npes_per_tile = npes/ntiles
3410 write(outunit,*)
'NOTE from test_unstruct_update ==> For Mosaic "', trim(type), &
3411 '", each tile will be distributed over ', npes_per_tile,
' processors.' 3413 call mpp_error(note,
'test_unstruct_update: npes should be multiple of ntiles No test is done for '//trim(type))
3416 if(layout_cubic(1)*layout_cubic(2) == npes_per_tile)
then 3417 layout = layout_cubic
3421 allocate(frac_crit(ntiles))
3422 frac_crit(1) = 0.3; frac_crit(2) = 0.1; frac_crit(3) = 0.6
3423 frac_crit(4) = 0.2; frac_crit(5) = 0.4; frac_crit(6) = 0.5
3426 call mpp_error(fatal,
'test_group_update: no such test: '//type)
3429 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
3431 pe_start(n) = (n-1)*npes_per_tile
3432 pe_end(n) = n*npes_per_tile-1
3436 global_indices(:,n) = (/1,nx,1,ny/)
3437 layout2d(:,n) = layout
3441 if( cubic_grid )
then 3442 call define_cubic_mosaic(
type, SG_domain, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
3443 global_indices, layout2D, pe_start, pe_end )
3450 allocate(lmask(nx,ny,ntiles))
3451 allocate(npts_tile(ntiles))
3453 if(mpp_pe() == mpp_root_pe() )
then 3454 allocate(rmask(nx,ny))
3457 call random_number(rmask)
3460 if(rmask(i,j) > frac_crit(n))
then 3461 lmask(i,j,n) = .true.
3465 npts_tile(n) = count(lmask(:,:,n))
3467 ntotal_land = sum(npts_tile)
3468 allocate(grid_index(ntotal_land))
3470 allocate(isl(0:mpp_npes()-1), iel(0:mpp_npes()-1))
3471 allocate(jsl(0:mpp_npes()-1), jel(0:mpp_npes()-1))
3477 if(lmask(i,j,n))
then 3479 grid_index(l) = (j-1)*nx+i
3484 deallocate(rmask, isl, iel, jsl, jel)
3487 if(mpp_pe() .NE. mpp_root_pe())
then 3488 ntotal_land = sum(npts_tile)
3489 allocate(grid_index(ntotal_land))
3493 allocate(ntiles_grid(ntotal_land))
3496 call mpp_define_unstruct_domain(ug_domain, sg_domain, npts_tile, ntiles_grid, mpp_npes(), 1, grid_index, name=
"LAND unstruct")
3497 call mpp_get_ug_compute_domain(ug_domain, istart, iend)
3502 do l = 1, npts_tile(n)
3504 j = (grid_index(pos)-1)/nx + 1
3505 i = mod((grid_index(pos)-1),nx) + 1
3506 lmask(i,j,n) = .true.
3511 allocate(gdata(nx,ny,ntiles))
3516 if(lmask(i,j,n))
then 3517 gdata(i,j,n) = n*1.e+3 + i + j*1.e-3
3524 allocate( a1(isc:iec, jsc:jec,1), a2(isc:iec,jsc:jec,1 ) )
3526 tile = mpp_pe()/npes_per_tile + 1
3529 a1(i,j,1) = gdata(i,j,tile)
3533 write(mpp_pe()+1000,*)
"npts_tile = " 3534 write(mpp_pe()+1000,*) npts_tile
3535 write(mpp_pe()+1000,*)
"a1 = ", isc, iec, jsc, jec
3537 write(mpp_pe()+1000,*) a1(:,j,1)
3540 allocate(x1(istart:iend,1), x2(istart:iend,1))
3544 tile = mpp_get_ug_domain_tile_id(ug_domain)
3547 pos = pos + npts_tile(n)
3550 i = mod((grid_index(pos+l)-1), nx) + 1
3551 j = (grid_index(pos+l)-1)/nx + 1
3552 x2(l,1) = gdata(i,j,tile)
3559 call compare_checksums(a1(:,:,1:1),a2(:,:,1:1),type//
' UG2SG 2-D compute domain')
3560 deallocate(a1,a2,x1,x2)
3563 allocate( a1(isc:iec, jsc:jec,nz), a2(isc:iec,jsc:jec,nz ) )
3565 tile = mpp_pe()/npes_per_tile + 1
3569 a1(i,j,k) = gdata(i,j,tile)
3570 if(a1(i,j,k) .NE. -999) a1(i,j,k) = a1(i,j,k) + k*1.e-6
3576 allocate(x1(istart:iend,nz), x2(istart:iend,nz))
3580 tile = mpp_get_ug_domain_tile_id(ug_domain)
3583 pos = pos + npts_tile(n)
3586 i = mod((grid_index(pos+l)-1), nx) + 1
3587 j = (grid_index(pos+l)-1)/nx + 1
3589 x2(l,k) = gdata(i,j,tile) + k*1.e-6
3595 write(mpp_pe()+1000,*)
"x1 = ", istart, iend
3599 deallocate(a1,a2,x1,x2)
3602 allocate( a1(isd:ied, jsd:jed,1), a2(isd:ied,jsd:jed,1 ) )
3603 a1 = -999; a2 = -999
3605 tile = mpp_pe()/npes_per_tile + 1
3608 a1(i,j,1) = gdata(i,j,tile)
3612 write(mpp_pe()+1000,*)
"npts_tile = " 3613 write(mpp_pe()+1000,*) npts_tile
3615 allocate(x1(istart:iend,1), x2(istart:iend,1))
3619 tile = mpp_get_ug_domain_tile_id(ug_domain)
3622 pos = pos + npts_tile(n)
3625 i = mod((grid_index(pos+l)-1), nx) + 1
3626 j = (grid_index(pos+l)-1)/nx + 1
3627 x2(l,1) = gdata(i,j,tile)
3632 write(mpp_pe()+1000,*)
"x1 = ", istart, iend
3633 write(mpp_pe()+1000,*) x1
3637 deallocate(a1,a2,x1,x2)
3640 allocate( a1(isd:ied, jsd:jed,nz), a2(isd:ied,jsd:jed,nz ) )
3641 a1 = -999; a2 = -999
3643 tile = mpp_pe()/npes_per_tile + 1
3647 a1(i,j,k) = gdata(i,j,tile)
3648 if(a1(i,j,k) .NE. -999) a1(i,j,k) = a1(i,j,k) + k*1.e-6
3653 write(mpp_pe()+1000,*)
"npts_tile = " 3654 write(mpp_pe()+1000,*) npts_tile
3656 write(mpp_pe()+1000,*) a1(:,j,1)
3659 allocate(x1(istart:iend,nz), x2(istart:iend,nz))
3663 tile = mpp_get_ug_domain_tile_id(ug_domain)
3666 pos = pos + npts_tile(n)
3669 i = mod((grid_index(pos+l)-1), nx) + 1
3670 j = (grid_index(pos+l)-1)/nx + 1
3672 x2(l,k) = gdata(i,j,tile) + k*1.e-6
3678 write(mpp_pe()+1000,*)
"x1 = ", istart, iend
3682 deallocate(a1,a2,x1,x2)
3687 call mpp_get_ug_global_domain(ug_domain, lsg, leg)
3688 tile = mpp_get_ug_domain_tile_id(ug_domain)
3689 allocate(g1(lsg:leg,nz), g2(lsg:leg,nz), x1(istart:iend,nz))
3695 g1(l,k) = tile*1e6 + l + k*1.e-3
3709 deallocate(g1,g2,x1)
3711 end subroutine test_unstruct_update
3717 subroutine fill_halo_zero(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, jsd, jed)
3718 integer,
intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed
3719 integer,
intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift
3720 real,
dimension(isd:,jsd:,:),
intent(inout) :: data
3723 data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0
3724 data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0
3726 data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0
3727 data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0
3731 data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0
3732 data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0
3734 data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0
3735 data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0
3738 end subroutine fill_halo_zero
3742 subroutine fill_regular_mosaic_halo(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne)
3743 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
3744 real,
dimension(:,:,:,:),
intent(in) :: data_all
3745 integer,
intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne
3747 data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te)
3748 data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts)
3749 data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw)
3750 data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn)
3751 data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse)
3752 data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw)
3753 data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw)
3754 data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne)
3758 end subroutine fill_regular_mosaic_halo
3761 subroutine fill_folded_north_halo(data, ioff, joff, ishift, jshift, sign)
3762 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
3763 integer,
intent(in ) :: ioff, joff, ishift, jshift, sign
3764 integer :: nxp, nyp, m1, m2
3769 m2 = 2*ishift - ioff
3771 data(1-whalo:0, 1:nyp,:) =
data(nx-whalo+1:nx, 1:ny+jshift,:)
3772 data(nx+1:nx+ehalo+ishift, 1:nyp,:) =
data(1:ehalo+ishift, 1:ny+jshift,:)
3773 if(m1 .GE. 1-whalo)
data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*
data(whalo+m2:1+ishift:-1, nyp-joff:nyp-nhalo-joff+1:-1,:)
3774 data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = sign*
data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:)
3775 data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*
data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:)
3777 end subroutine fill_folded_north_halo
3780 subroutine fill_folded_south_halo(data, ioff, joff, ishift, jshift, sign)
3781 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
3782 integer,
intent(in ) :: ioff, joff, ishift, jshift, sign
3783 integer :: nxp, nyp, m1, m2
3788 m2 = 2*ishift - ioff
3791 data(1-whalo:0, 1:nyp,:) =
data(nx-whalo+1:nx, 1:nyp,:)
3792 data(nx+1:nx+ehalo+ishift, 1:nyp,:) =
data(1:ehalo+ishift, 1:nyp,:)
3793 if(m1 .GE. 1-whalo)
data(1-whalo:m1, 1-shalo:0,:) = sign*
data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:)
3794 data(m1+1:nx+m2, 1-shalo:0,:) = sign*
data(nxp:1:-1, shalo+jshift:1+jshift:-1,:)
3795 data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*
data(nx:nx-ehalo+m1+1:-1, shalo+jshift:1+jshift:-1,:)
3797 end subroutine fill_folded_south_halo
3800 subroutine fill_folded_west_halo(data, ioff, joff, ishift, jshift, sign)
3801 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
3802 integer,
intent(in ) :: ioff, joff, ishift, jshift, sign
3803 integer :: nxp, nyp, m1, m2
3808 m2 = 2*jshift - joff
3810 data(1:nxp, 1-shalo:0, :) =
data(1:nxp, ny-shalo+1:ny, :)
3811 data(1:nxp, ny+1:nyp+nhalo, :) =
data(1:nxp, 1:nhalo+jshift,:)
3812 if(m1 .GE. 1-shalo)
data(1-whalo:0, 1-shalo:m1, :) = sign*
data(whalo+ishift:1+ishift:-1, shalo+m2:1+jshift:-1,:)
3813 data(1-whalo:0, m1+1:ny+m2, :) = sign*
data(whalo+ishift:1+ishift:-1, nyp:1:-1, :)
3814 data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*
data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:)
3816 end subroutine fill_folded_west_halo
3819 subroutine fill_folded_east_halo(data, ioff, joff, ishift, jshift, sign)
3820 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
3821 integer,
intent(in ) :: ioff, joff, ishift, jshift, sign
3822 integer :: nxp, nyp, m1, m2
3827 m2 = 2*jshift - joff
3829 data(1:nxp, 1-shalo:0, :) =
data(1:nxp, ny-shalo+1:ny, :)
3830 data(1:nxp, ny+1:nyp+nhalo, :) =
data(1:nxp, 1:nhalo+jshift,:)
3831 if(m1 .GE. 1-shalo)
data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*
data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:)
3832 data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*
data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :)
3833 data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*
data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:)
3835 end subroutine fill_folded_east_halo
3838 subroutine fill_four_tile_bound(data_all, is, ie, js, je, ioff, joff, tile, &
3839 ebound, sbound, wbound, nbound )
3840 real,
dimension(:,:,:,:),
intent(in) :: data_all
3841 integer,
intent(in) :: is, ie, js, je
3842 integer,
intent(in) :: tile, ioff, joff
3843 real,
dimension(:,:),
optional,
intent(inout) :: ebound, sbound, wbound, nbound
3844 integer :: tw, te, ts, tn
3846 if(tile == 1 .OR. tile == 3) te = tile + 1
3847 if(tile == 2 .OR. tile == 4) te = tile - 1
3848 if(tile == 1 .OR. tile == 2) ts = tile + 2
3849 if(tile == 3 .OR. tile == 4) ts = tile - 2
3851 if(
present(ebound))
then 3853 ebound(:,:) = data_all(1, js:je+joff, :, te)
3855 ebound(:,:) = data_all(ie+ioff, js:je+joff, :, tile)
3859 if(
present(wbound))
then 3861 wbound(:,:) = data_all(nx+ioff, js:je+joff, :, tw)
3863 wbound(:,:) = data_all(is, js:je+joff, :, tile)
3867 if(
present(sbound))
then 3869 sbound(:,:) = data_all(is:ie+ioff, ny+joff, :, ts)
3871 sbound(:,:) = data_all(is:ie+ioff, js, :, tile)
3875 if(
present(nbound))
then 3877 nbound(:,:) = data_all(is:ie+ioff, 1, :, tn)
3879 nbound(:,:) = data_all(is:ie+ioff, je+joff, :, tile)
3885 end subroutine fill_four_tile_bound
3889 subroutine fill_torus_bound(data_all, is, ie, js, je, ioff, joff, tile, &
3891 real,
dimension(:,:,:),
intent(in) :: data_all
3892 integer,
intent(in) :: is, ie, js, je
3893 integer,
intent(in) :: tile, ioff, joff
3894 real,
dimension(:,:),
optional,
intent(inout) :: sbound, wbound
3895 integer :: tw, te, ts, tn
3896 integer :: js1, js2, is1, is2
3898 if(tile .NE. 1)
call mpp_error(fatal,
"fill_torus_bound: tile must be 1")
3902 if( js == 1 .AND. joff==1 )
then 3908 if( is == 1 .AND. ioff==1 )
then 3913 if(
present(wbound))
then 3914 if(ioff .NE. 1)
call mpp_error(fatal,
"fill_torus_bound: ioff must be 1 when wbound present")
3916 wbound(js1:,:) = data_all(nx+ioff, js2:je+joff, :)
3918 wbound(js1:,:) = data_all(is, js2:je+joff, :)
3922 wbound(1,:) = data_all(nx+1, ny+1, :)
3924 wbound(1,:) = data_all(is, ny+1, :)
3929 if(
present(sbound))
then 3930 if(joff .NE. 1)
call mpp_error(fatal,
"fill_torus_bound: joff must be 1 when sbound present")
3932 sbound(is1:,:) = data_all(is2:ie+ioff, ny+joff, :)
3934 sbound(is1:,:) = data_all(is2:ie+ioff, js, :)
3938 sbound(1,:) = data_all(nx+1, ny+1, :)
3940 sbound(1,:) = data_all(nx+1, js, :)
3947 end subroutine fill_torus_bound
3950 subroutine fill_folded_north_bound(data_all, is, ie, js, je, ioff, joff, tile, &
3952 real,
dimension(:,:,:),
intent(in) :: data_all
3953 integer,
intent(in) :: is, ie, js, je
3954 integer,
intent(in) :: tile, ioff, joff
3955 real,
dimension(:,:),
optional,
intent(inout) :: sbound, wbound
3956 integer :: tw, te, ts, tn
3959 if(tile .NE. 1)
call mpp_error(fatal,
"fill_folded_north_bound: tile must be 1")
3963 if( js == 1 .AND. joff==1 )
then 3968 if(
present(wbound))
then 3970 wbound(js1:,:) = data_all(nx+ioff, js2:je+joff, :)
3972 wbound(js1:,:) = data_all(is, js2:je+joff, :)
3976 if(
present(sbound))
then 3980 if( is == 1 .AND. ioff == 1 )
then 3981 sbound(1,:) = data_all(nx+1, js, :)
3982 sbound(2:,:) = data_all(is+1:ie+ioff, js, :)
3984 sbound(:,:) = data_all(is:ie+ioff, js, :)
3991 end subroutine fill_folded_north_bound
3994 subroutine fill_cubic_grid_bound(data1_all, data2_all, is, ie, js, je, ioff, joff, tile, sign1, sign2, &
3995 ebound, sbound, wbound, nbound )
3996 real,
dimension(:,:,:,:),
intent(in) :: data1_all, data2_all
3997 integer,
intent(in) :: is, ie, js, je
3998 integer,
intent(in) :: tile, ioff, joff, sign1, sign2
3999 real,
dimension(:,:),
optional,
intent(inout) :: ebound, sbound, wbound, nbound
4000 integer :: tw, te, ts, tn
4002 if(mod(tile,2) == 0)
then 4003 tw = tile - 1; te = tile + 2; ts = tile - 2; tn = tile + 1
4004 if(te > 6 ) te = te - 6
4005 if(ts < 1 ) ts = ts + 6
4006 if(tn > 6 ) tn = tn - 6
4008 if(
present(ebound))
then 4010 ebound(:,:) = sign1*data2_all(nx+joff-js+1:nx-je+1:-1,1,:,te)
4012 ebound(:,:) = data1_all(ie+ioff, js:je+joff, :,tile)
4016 if(
present(sbound))
then 4018 sbound(:,:) = sign2*data2_all(nx+joff, ny+ioff-is+1:ny-ie+1:-1,:,ts)
4020 sbound(:,:) = data1_all(is:ie+ioff, js, :,tile)
4025 if(
present(wbound))
then 4027 wbound(:,:) = data1_all(nx+ioff, js:je+joff,:,tw)
4029 wbound(:,:) = data1_all(is, js:je+joff,:,tile)
4034 if(
present(nbound))
then 4036 nbound(:,:) = data1_all(is:ie+ioff, 1,:,tn)
4038 nbound(:,:) = data1_all(is:ie+ioff, je+joff, :,tile)
4042 tw = tile - 2; te = tile + 1; ts = tile - 1; tn = tile + 2
4043 if(tw < 1 ) tw = tw + 6
4044 if(ts < 1 ) ts = ts + 6
4045 if(tn > 6 ) tn = tn - 6
4047 if(
present(ebound))
then 4049 ebound(:,:) = data1_all(1, js:je+joff, :,te)
4051 ebound(:,:) = data1_all(ie+ioff, js:je+joff, :,tile)
4055 if(
present(sbound))
then 4057 sbound(:,:) = data1_all(is:ie+ioff,ny+joff,:,ts)
4059 sbound(:,:) = data1_all(is:ie+ioff, js, :,tile)
4064 if(
present(wbound))
then 4066 wbound(:,:) = sign1*data2_all(nx+joff-js+1:nx-je+1:-1,ny+ioff,:,tw)
4068 wbound(:,:) = data1_all(is, js:je+joff,:,tile)
4073 if(
present(nbound))
then 4075 nbound(:,:) = sign2*data2_all(1, ny+ioff-is+1:ny-ie+1:-1,:,tn)
4077 nbound(:,:) = data1_all(is:ie+ioff, je+joff, :,tile)
4083 end subroutine fill_cubic_grid_bound
4088 subroutine fill_cubic_grid_halo(data, data1_all, data2_all, tile, ioff, joff, sign1, sign2)
4089 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
4090 real,
dimension(:,:,:,:),
intent(in) :: data1_all, data2_all
4091 integer,
intent(in) :: tile, ioff, joff, sign1, sign2
4092 integer :: lw, le, ls, ln
4094 if(mod(tile,2) == 0)
then 4095 lw = tile - 1; le = tile + 2; ls = tile - 2; ln = tile + 1
4096 if(le > 6 ) le = le - 6
4097 if(ls < 1 ) ls = ls + 6
4098 if(ln > 6 ) ln = ln - 6
4099 data(1-whalo:0, 1:ny+joff, :) = data1_all(nx-whalo+1:nx, 1:ny+joff, :, lw)
4101 data(nx+i+ioff, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, i+ioff, :, le)
4104 data(1:nx+ioff, 1-i, :) = sign2*data2_all(nx-i+1, ny+ioff:1:-1, :, ls)
4106 data(1:nx+ioff, ny+1+joff:ny+nhalo+joff, :) = data1_all(1:nx+ioff, 1+joff:nhalo+joff, :, ln)
4108 lw = tile - 2; le = tile + 1; ls = tile - 1; ln = tile + 2
4109 if(lw < 1 ) lw = lw + 6
4110 if(ls < 1 ) ls = ls + 6
4111 if(ln > 6 ) ln = ln - 6
4113 data(1-i, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, ny-i+1, :, lw)
4115 data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:ny+joff, :, le)
4116 data(1:nx+ioff, 1-shalo:0, :) = data1_all(1:nx+ioff, ny-shalo+1:ny, :, ls)
4118 data(1:nx+ioff, ny+i+joff, :) = sign2*data2_all(i+joff, ny+ioff:1:-1, :, ln)
4122 end subroutine fill_cubic_grid_halo
4125 subroutine test_nonuniform_mosaic( type )
4126 character(len=*),
intent(in) :: type
4128 type(domain2D) :: domain
4129 integer :: num_contact, ntiles, ntile_per_pe
4130 integer :: i, j, k, n, nxm, nym, ni, nj, shift
4131 integer :: ism, iem, jsm, jem, isc, iec, jsc, jec
4132 integer :: isd, ied, jsd, jed
4133 integer :: indices(4), msize(2)
4134 character(len=128) :: type2
4136 integer,
allocatable,
dimension(:) :: tile
4137 integer,
allocatable,
dimension(:) :: pe_start, pe_end, tile1, tile2
4138 integer,
allocatable,
dimension(:) :: istart1, iend1, jstart1, jend1
4139 integer,
allocatable,
dimension(:) :: istart2, iend2, jstart2, jend2
4140 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
4141 real,
allocatable,
dimension(:,:,:,:) :: global1_all, global2_all
4142 real,
allocatable,
dimension(:,:,:,:) :: global1, global2, x, y
4150 if(npes .NE. 2)
then 4151 call mpp_error(note,
'TEST_MPP_DOMAINS: Five-Tile mosaic will not be tested because npes is not 2')
4154 nxm = 2*nx; nym = 2*ny
4158 allocate(tile(ntile_per_pe))
4160 indices = (/1,2*nx,1,2*ny/)
4161 ni = 2*nx; nj = 2*ny
4164 allocate(tile(ntile_per_pe))
4165 do n = 1, ntile_per_pe
4168 indices = (/1,nx,1,ny/)
4171 allocate(pe_start(ntiles), pe_end(ntiles) )
4172 pe_start(1) = 0; pe_start(2:) = 1
4175 call mpp_error(fatal,
'TEST_MPP_DOMAINS: no such test: '//type)
4178 allocate(layout2d(2,ntiles), global_indices(4,ntiles) )
4182 global_indices(:,n) = (/1,2*nx,1,2*ny/)
4184 global_indices(:,n) = (/1,nx,1,ny/)
4187 layout2d(:,n) = layout
4190 allocate(tile1(num_contact), tile2(num_contact) )
4191 allocate(istart1(num_contact), iend1(num_contact), jstart1(num_contact), jend1(num_contact) )
4192 allocate(istart2(num_contact), iend2(num_contact), jstart2(num_contact), jend2(num_contact) )
4198 tile1(1) = 1; tile2(1) = 2
4199 istart1(1) = 2*nx; iend1(1) = 2*nx; jstart1(1) = 1; jend1(1) = ny
4200 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny
4202 tile1(2) = 1; tile2(2) = 4
4203 istart1(2) = 2*nx; iend1(2) = 2*nx; jstart1(2) = ny+1; jend1(2) = 2*ny
4204 istart2(2) = 1; iend2(2) = 1; jstart2(2) = 1; jend2(2) = ny
4206 tile1(3) = 1; tile2(3) = 1
4207 istart1(3) = 1; iend1(3) = 2*nx; jstart1(3) = 1; jend1(3) = 1
4208 istart2(3) = 1; iend2(3) = 2*nx; jstart2(3) = 2*ny; jend2(3) = 2*ny
4210 tile1(4) = 1; tile2(4) = 3
4211 istart1(4) = 1; iend1(4) = 1; jstart1(4) = 1; jend1(4) = ny
4212 istart2(4) = nx; iend2(4) = nx; jstart2(4) = 1; jend2(4) = ny
4214 tile1(5) = 1; tile2(5) = 5
4215 istart1(5) = 1; iend1(5) = 1; jstart1(5) = ny+1; jend1(5) = 2*ny
4216 istart2(5) = nx; iend2(5) = nx; jstart2(5) = 1; jend2(5) = ny
4218 tile1(6) = 2; tile2(6) = 3
4219 istart1(6) = nx; iend1(6) = nx; jstart1(6) = 1; jend1(6) = ny
4220 istart2(6) = 1; iend2(6) = 1; jstart2(6) = 1; jend2(6) = ny
4222 tile1(7) = 2; tile2(7) = 4
4223 istart1(7) = 1; iend1(7) = nx; jstart1(7) = 1; jend1(7) = 1
4224 istart2(7) = 1; iend2(7) = nx; jstart2(7) = ny; jend2(7) = ny
4226 tile1(8) = 2; tile2(8) = 4
4227 istart1(8) = 1; iend1(8) = nx; jstart1(8) = ny; jend1(8) = ny
4228 istart2(8) = 1; iend2(8) = nx; jstart2(8) = 1; jend2(8) = 1
4230 tile1(9) = 3; tile2(9) = 5
4231 istart1(9) = 1; iend1(9) = nx; jstart1(9) = 1; jend1(9) = 1
4232 istart2(9) = 1; iend2(9) = nx; jstart2(9) = ny; jend2(9) = ny
4234 tile1(10) = 3; tile2(10) = 5
4235 istart1(10) = 1; iend1(10) = nx; jstart1(10) = ny; jend1(10) = ny
4236 istart2(10) = 1; iend2(10) = nx; jstart2(10) = 1; jend2(10) = 1
4238 tile1(11) = 4; tile2(11) = 5
4239 istart1(11) = nx; iend1(11) = nx; jstart1(11) = 1; jend1(11) = ny
4240 istart2(11) = 1; iend2(11) = 1; jstart2(11) = 1; jend2(11) = ny
4241 msize(1) = 2*nx + whalo + ehalo
4242 msize(2) = 2*ny + shalo + nhalo
4243 call mpp_define_mosaic(global_indices, layout2d, domain, ntiles, num_contact, tile1, tile2, &
4244 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
4245 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
4246 name =
type, memory_size = msize, symmetry = .true. )
4250 allocate(global1_all(1:nxm,1:nym,nz, ntiles) )
4251 allocate(global1(1-whalo:ni+ehalo,1-shalo:nj+nhalo,nz, ntile_per_pe) )
4256 global1_all(i,j,k,n) = n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4262 do n = 1, ntile_per_pe
4263 global1(1:ni,1:nj,:,n) = global1_all(1:ni,1:nj,:,tile(n))
4270 allocate( x(ism:iem,jsm:jem,nz, ntile_per_pe) )
4272 x(isc:iec,jsc:jec,:,:) = global1(isc:iec,jsc:jec,:,:)
4275 do n = 1, ntile_per_pe
4276 call fill_five_tile_halo(global1(:,:,:,n), global1_all, tile(n), 0, 0 )
4280 id = mpp_clock_id(
type, flags=mpp_clock_sync+mpp_clock_detailed )
4281 call mpp_clock_begin(id)
4282 do n = 1, ntile_per_pe
4285 call mpp_clock_end(id)
4287 do n = 1, ntile_per_pe
4288 write(type2, *)
type,
" at tile_count = ",n
4289 call compare_checksums( x(isd:ied,jsd:jed,:,n), global1(isd:ied,jsd:jed,:,n), trim(type2) )
4292 deallocate(global1_all, global1, x)
4298 allocate(global1_all(nxm+shift,nym+shift,nz, ntiles), global2_all(nxm+shift,nym+shift,nz, ntiles) )
4299 allocate(global1(1-whalo:ni+ehalo+shift,1-shalo:nj+nhalo+shift,nz, ntile_per_pe) )
4300 allocate(global2(1-whalo:ni+ehalo+shift,1-shalo:nj+nhalo+shift,nz, ntile_per_pe) )
4305 global1_all(i,j,k,n) = 1.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4306 global2_all(i,j,k,n) = 2.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4317 if(
type ==
'Five-Tile') then
4318 global1_all(nxm+1, 1:ny,:,1) = global1_all(1, 1:ny,:,2)
4319 global1_all(nxm+1,ny+1:nym,:,1) = global1_all(1, 1:ny,:,4)
4320 global1_all(1:nxm+1, nym+1,:,1) = global1_all(1:nxm+1, 1,:,1)
4321 global1_all(nx+1, 1:ny,:,2) = global1_all(1, 1:ny,:,3)
4322 global1_all(1:nx+1, ny+1,:,2) = global1_all(1:nx+1, 1,:,4)
4323 global1_all(nx+1, 1:ny,:,3) = global1_all(1, 1:ny,:,1)
4324 global1_all(1:nx+1, ny+1,:,3) = global1_all(1:nx+1, 1,:,5)
4325 global1_all(nx+1, 1:ny,:,4) = global1_all(1, 1:ny,:,5)
4326 global1_all(1:nx+1, ny+1,:,4) = global1_all(1:nx+1, 1,:,2)
4327 global1_all(nx+1, 1:ny,:,5) = global1_all(1,ny+1:nym,:,1)
4328 global1_all(1:nx+1, ny+1,:,5) = global1_all(1:nx+1, 1,:,3)
4329 global1_all(nx+1, ny+1,:,2) = global1_all(1, 1,:,5)
4330 global1_all(nx+1, ny+1,:,3) = global1_all(1, ny+1,:,1)
4331 global2_all(nxm+1, 1:ny,:,1) = global2_all(1, 1:ny,:,2)
4332 global2_all(nxm+1,ny+1:nym,:,1) = global2_all(1, 1:ny,:,4)
4333 global2_all(1:nxm+1, nym+1,:,1) = global2_all(1:nxm+1, 1,:,1)
4334 global2_all(nx+1, 1:ny,:,2) = global2_all(1, 1:ny,:,3)
4335 global2_all(1:nx+1, ny+1,:,2) = global2_all(1:nx+1, 1,:,4)
4336 global2_all(nx+1, 1:ny,:,3) = global2_all(1, 1:ny,:,1)
4337 global2_all(1:nx+1, ny+1,:,3) = global2_all(1:nx+1, 1,:,5)
4338 global2_all(nx+1, 1:ny,:,4) = global2_all(1, 1:ny,:,5)
4339 global2_all(1:nx+1, ny+1,:,4) = global2_all(1:nx+1, 1,:,2)
4340 global2_all(nx+1, 1:ny,:,5) = global2_all(1,ny+1:nym,:,1)
4341 global2_all(1:nx+1, ny+1,:,5) = global2_all(1:nx+1, 1,:,3)
4342 global2_all(nx+1, ny+1,:,2) = global2_all(1, 1,:,5)
4343 global2_all(nx+1, ny+1,:,3) = global2_all(1, ny+1,:,1)
4346 do n = 1, ntile_per_pe
4347 global1(1:ni+shift,1:nj+shift,:,n) = global1_all(1:ni+shift,1:nj+shift,:,tile(n))
4348 global2(1:ni+shift,1:nj+shift,:,n) = global2_all(1:ni+shift,1:nj+shift,:,tile(n))
4351 allocate( x(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
4352 allocate( y(ism:iem+shift,jsm:jem+shift,nz,ntile_per_pe) )
4355 x(isc:iec+shift,jsc:jec+shift,:,:) = global1(isc:iec+shift,jsc:jec+shift,:,:)
4356 y(isc:iec+shift,jsc:jec+shift,:,:) = global2(isc:iec+shift,jsc:jec+shift,:,:)
4361 do n = 1, ntile_per_pe
4362 call fill_five_tile_halo(global1(:,:,:,n), global1_all, tile(n), shift, shift)
4363 call fill_five_tile_halo(global2(:,:,:,n), global2_all, tile(n), shift, shift)
4366 id = mpp_clock_id( type//
' BGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
4367 call mpp_clock_begin(id)
4368 do n = 1, ntile_per_pe
4369 call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=bgrid_ne, tile_count = n )
4371 call mpp_clock_end(id)
4373 do n = 1, ntile_per_pe
4374 write(type2, *)
type,
" at tile_count = ",n
4375 call compare_checksums( x(isd:ied+shift,jsd:jed+shift,:,n), global1(isd:ied+shift,jsd:jed+shift,:,n), &
4376 trim(type2)//
' BGRID_NE X')
4377 call compare_checksums( y(isd:ied+shift,jsd:jed+shift,:,n), global2(isd:ied+shift,jsd:jed+shift,:,n), &
4378 trim(type2)//
' BGRID_NE Y')
4381 deallocate(global1_all, global2_all, global1, global2, x, y)
4387 allocate(global1_all(nxm+shift,nym,nz, ntiles), global2_all(nxm,nym+shift,nz, ntiles) )
4388 allocate(global1(1-whalo:ni+ehalo+shift, 1-shalo:nj+nhalo, nz, ntile_per_pe) )
4389 allocate(global2(1-whalo:ni+ehalo, 1-shalo:nj+nhalo+shift, nz, ntile_per_pe) )
4394 global1_all(i,j,k,n) = 1.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4399 global2_all(i,j,k,n) = 2.0e3 + n + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4410 if(
type ==
'Five-Tile') then
4411 global1_all(nxm+1, 1:ny,:,1) = global1_all(1, 1:ny,:,2)
4412 global1_all(nxm+1,ny+1:nym,:,1) = global1_all(1, 1:ny,:,4)
4413 global1_all(nx+1, 1:ny,:,2) = global1_all(1, 1:ny,:,3)
4414 global1_all(nx+1, 1:ny,:,3) = global1_all(1, 1:ny,:,1)
4415 global1_all(nx+1, 1:ny,:,4) = global1_all(1, 1:ny,:,5)
4416 global1_all(nx+1, 1:ny,:,5) = global1_all(1,ny+1:nym,:,1)
4417 global2_all(1:nxm, nym+1,:,1) = global2_all(1:nxm, 1,:,1)
4418 global2_all(1:nx, ny+1,:,2) = global2_all(1:nx, 1,:,4)
4419 global2_all(1:nx, ny+1,:,3) = global2_all(1:nx, 1,:,5)
4420 global2_all(1:nx, ny+1,:,4) = global2_all(1:nx, 1,:,2)
4421 global2_all(1:nx, ny+1,:,5) = global2_all(1:nx, 1,:,3)
4424 do n = 1, ntile_per_pe
4425 global1(1:ni+shift, 1:nj,:,n) = global1_all(1:ni+shift, 1:nj,:,tile(n))
4426 global2(1:ni, 1:nj+shift,:,n) = global2_all(1:ni, 1:nj+shift,:,tile(n))
4429 allocate( x(ism:iem+shift, jsm:jem,nz,ntile_per_pe) )
4430 allocate( y(ism:iem, jsm:jem+shift,nz,ntile_per_pe) )
4433 x(isc:iec+shift, jsc:jec,:,:) = global1(isc:iec+shift, jsc:jec,:,:)
4434 y(isc:iec, jsc:jec+shift,:,:) = global2(isc:iec, jsc:jec+shift,:,:)
4439 do n = 1, ntile_per_pe
4440 call fill_five_tile_halo(global1(:,:,:,n), global1_all, tile(n), shift, 0)
4441 call fill_five_tile_halo(global2(:,:,:,n), global2_all, tile(n), 0, shift)
4444 id = mpp_clock_id( type//
' CGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
4445 call mpp_clock_begin(id)
4446 do n = 1, ntile_per_pe
4447 call mpp_update_domains( x(:,:,:,n), y(:,:,:,n), domain, gridtype=cgrid_ne, tile_count = n )
4449 call mpp_clock_end(id)
4451 do n = 1, ntile_per_pe
4452 write(type2, *)
type,
" at tile_count = ",n
4453 call compare_checksums( x(isd:ied+shift,jsd:jed,:,n), global1(isd:ied+shift,jsd:jed,:,n), &
4454 trim(type2)//
' CGRID_NE X')
4455 call compare_checksums( y(isd:ied,jsd:jed+shift,:,n), global2(isd:ied,jsd:jed+shift,:,n), &
4456 trim(type2)//
' CGRID_NE Y')
4459 deallocate(global1_all, global2_all, global1, global2, x, y)
4461 end subroutine test_nonuniform_mosaic
4463 subroutine fill_five_tile_halo(data, data_all, tile, ioff, joff)
4464 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
4465 real,
dimension(:,:,:,:),
intent(in) :: data_all
4466 integer,
intent(in) :: tile, ioff, joff
4469 nxm = 2*nx; nym = 2*ny
4473 data(nxm+1+ioff:nxm+ehalo+ioff, 1:ny,:) = data_all(1+ioff:ehalo+ioff, 1:ny,:,2)
4474 data(nxm+1+ioff:nxm+ehalo+ioff, ny+1:nym+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,4)
4475 data(1-whalo:0, 1:ny,:) = data_all(nx-whalo+1:nx, 1:ny,:,3)
4476 data(1-whalo:0, ny+1:nym+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,5)
4477 data(1:nxm+ioff, 1-shalo:0,:) = data_all(1:nxm+ioff, nym-shalo+1:nym,:,1)
4478 data(1:nxm+ioff, nym+1+joff:nym+nhalo+joff,:) = data_all(1:nxm+ioff, 1+joff:nhalo+joff,:,1)
4479 data(nxm+1+ioff:nxm+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,4)
4480 data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,5)
4481 data(nxm+1+ioff:nxm+ehalo+ioff,nym+1+joff:nym+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,2)
4482 data(1-whalo:0, nym+1+joff:nym+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,3)
4484 data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,3)
4485 data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, 1:ny+joff,:,1)
4486 data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,4)
4487 data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,4)
4488 data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,5)
4489 data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, nym-shalo+1:nym,:,1)
4490 data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,5)
4491 data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, ny+1+joff:ny+nhalo+joff,:,1)
4493 data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,1)
4494 data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,2)
4495 data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,5)
4496 data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,5)
4497 data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, nym-shalo+1:nym,:,1)
4498 data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,4)
4499 data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff,ny+1+joff:ny+nhalo+joff,:,1)
4500 data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,4)
4502 data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,5)
4503 data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, ny+1:2*ny+joff,:,1)
4504 data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,2)
4505 data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,2)
4506 data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,3)
4507 data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, ny-shalo+1:ny,:,1)
4508 data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,3)
4509 data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, 1+joff:nhalo+joff,:,1)
4511 data(nx+1+ioff:nx+ehalo+ioff, 1: ny+joff,:) = data_all(1+ioff:ehalo+ioff, ny+1:2*ny+joff,:,1)
4512 data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,4)
4513 data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,3)
4514 data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,3)
4515 data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,1)
4516 data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,2)
4517 data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,1)
4518 data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,2)
4521 end subroutine fill_five_tile_halo
4524 subroutine test_get_boundary(type)
4525 character(len=*),
intent(in) :: type
4527 type(domain2D) :: domain, domain_nonsym
4528 integer :: ntiles, num_contact, npes_per_tile, ntile_per_pe, layout(2)
4529 integer :: n, l, isc, iec, jsc, jec, ism, iem, jsm, jem
4530 integer,
allocatable,
dimension(:) :: tile, ni, nj, pe_start, pe_end
4531 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
4532 real,
allocatable,
dimension(:,:,:) :: ebuffer, sbuffer, wbuffer, nbuffer
4533 real,
allocatable,
dimension(:,:,:) :: ebuffer1, sbuffer1, wbuffer1, nbuffer1
4534 real,
allocatable,
dimension(:,:,:) :: ebuffer2, sbuffer2, wbuffer2, nbuffer2
4535 real,
allocatable,
dimension(:,:,:) :: ebound, sbound, wbound, nbound
4536 real,
allocatable,
dimension(:,:,:) :: ebufferx, sbufferx, wbufferx, nbufferx
4537 real,
allocatable,
dimension(:,:,:) :: ebufferx1, sbufferx1, wbufferx1, nbufferx1
4538 real,
allocatable,
dimension(:,:,:) :: ebufferx2, sbufferx2, wbufferx2, nbufferx2
4539 real,
allocatable,
dimension(:,:,:) :: eboundx, sboundx, wboundx, nboundx
4540 real,
allocatable,
dimension(:,:,:) :: ebuffery, sbuffery, wbuffery, nbuffery
4541 real,
allocatable,
dimension(:,:,:) :: ebuffery1, sbuffery1, wbuffery1, nbuffery1
4542 real,
allocatable,
dimension(:,:,:) :: ebuffery2, sbuffery2, wbuffery2, nbuffery2
4543 real,
allocatable,
dimension(:,:,:) :: eboundy, sboundy, wboundy, nboundy
4544 real,
allocatable,
dimension(:,:,:,:) :: global_all, global1_all, global2_all
4545 real,
allocatable,
dimension(:,:,:,:) :: global, global1, global2
4546 real,
allocatable,
dimension(:,:,:,:) :: x, x1, x2, y, y1, y2
4547 real,
allocatable,
dimension(:,:) :: u_nonsym, v_nonsym
4548 logical :: folded_north = .false.
4549 logical :: is_torus = .false.
4550 integer :: nx_save, ny_save
4557 case (
'Four-Tile' )
4560 case (
'Cubic-Grid' )
4565 case (
'Folded-north' )
4566 folded_north = .true.
4572 call mpp_error(fatal,
'TEST_MPP_DOMAINS: no such test: '//type)
4575 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
4576 allocate(ni(ntiles), nj(ntiles))
4577 ni(:) = nx; nj(:) = ny
4578 if( mod(npes, ntiles) == 0 )
then 4579 npes_per_tile = npes/ntiles
4580 write(outunit,*)
'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
4581 '", each tile will be distributed over ', npes_per_tile,
' processors.' 4583 allocate(tile(ntile_per_pe))
4584 tile = pe/npes_per_tile+1
4587 pe_start(n) = (n-1)*npes_per_tile
4588 pe_end(n) = n*npes_per_tile-1
4590 else if ( mod(ntiles, npes) == 0 )
then 4591 ntile_per_pe = ntiles/npes
4592 write(outunit,*)
'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
4593 '", there will be ', ntile_per_pe,
' tiles on each processor.' 4594 allocate(tile(ntile_per_pe))
4595 do n = 1, ntile_per_pe
4596 tile(n) = pe*ntile_per_pe + n
4599 pe_start(n) = (n-1)/ntile_per_pe
4600 pe_end(n) = pe_start(n)
4604 call mpp_error(note,
'TEST_MPP_DOMAINS: npes should be multiple of ntiles or ' // &
4605 'ntiles should be multiple of npes. No test is done for '//trim(type) )
4610 global_indices(:,n) = (/1,nx,1,ny/)
4611 layout2d(:,n) = layout
4616 call define_fourtile_mosaic(
type, domain, (/nx,nx,nx,nx/), (/ny,ny,ny,ny/), global_indices, &
4617 layout2D, pe_start, pe_end, .true. )
4619 call define_cubic_mosaic(
type, domain, ni, nj, global_indices, layout2D, pe_start, pe_end )
4620 case(
"Folded-north")
4622 xflags=cyclic_global_domain, yflags=fold_north_edge, &
4623 whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
4624 symmetry=.true., name=
'tripolar' )
4626 xflags=cyclic_global_domain, yflags=fold_north_edge, &
4627 whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
4628 symmetry=.false., name=
'tripolar' )
4631 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, &
4632 yflags=cyclic_global_domain, symmetry=.true., name=type)
4636 allocate(global_all(1:nx+1,1:ny+1,nz, ntiles) )
4637 allocate(global(1:nx+1,1:ny+1,nz, ntile_per_pe) )
4643 global_all(i,j,k,l) = l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4649 do n = 1, ntile_per_pe
4650 global(:,:,:,n) = global_all(:,:,:,tile(n))
4655 allocate( x(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4656 allocate( x1(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4657 allocate( x2(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4659 x(isc:iec+1,jsc:jec+1,:,:) = global(isc:iec+1,jsc:jec+1,:,:)
4663 allocate(ebuffer(jsc:jec+1, nz, ntile_per_pe), wbuffer(jsc:jec+1, nz, ntile_per_pe))
4664 allocate(sbuffer(isc:iec+1, nz, ntile_per_pe), nbuffer(isc:iec+1, nz, ntile_per_pe))
4665 allocate(ebuffer1(jsc:jec+1, nz, ntile_per_pe), wbuffer1(jsc:jec+1, nz, ntile_per_pe))
4666 allocate(sbuffer1(isc:iec+1, nz, ntile_per_pe), nbuffer1(isc:iec+1, nz, ntile_per_pe))
4667 allocate(ebuffer2(jsc:jec+1, nz, ntile_per_pe), wbuffer2(jsc:jec+1, nz, ntile_per_pe))
4668 allocate(sbuffer2(isc:iec+1, nz, ntile_per_pe), nbuffer2(isc:iec+1, nz, ntile_per_pe))
4669 allocate(ebound(jsc:jec+1, nz, ntile_per_pe), wbound(jsc:jec+1, nz, ntile_per_pe))
4670 allocate(sbound(isc:iec+1, nz, ntile_per_pe), nbound(isc:iec+1, nz, ntile_per_pe))
4671 ebound = 0; ebuffer = 0; ebuffer1 = 0; ebuffer2 = 0
4672 sbound = 0; sbuffer = 0; sbuffer1 = 0; sbuffer2 = 0
4673 wbound = 0; wbuffer = 0; wbuffer1 = 0; wbuffer2 = 0
4674 nbound = 0; nbuffer = 0; nbuffer1 = 0; nbuffer2 = 0
4676 do n = 1, ntile_per_pe
4677 if(folded_north .or. is_torus )
then 4678 call mpp_get_boundary(x(:,:,:,n), domain, sbuffer=sbuffer(:,:,n), wbuffer=wbuffer(:,:,n), &
4679 position=corner, tile_count=n )
4681 call mpp_get_boundary(x(:,:,:,n), domain, ebuffer=ebuffer(:,:,n), sbuffer=sbuffer(:,:,n), wbuffer=wbuffer(:,:,n), &
4682 nbuffer=nbuffer(:,:,n), position=corner, tile_count=n )
4687 do n = 1, ntile_per_pe
4688 if(folded_north .or. is_torus)
then 4689 call mpp_get_boundary(x1(:,:,:,n), domain, sbuffer=sbuffer1(:,:,n), wbuffer=wbuffer1(:,:,n), &
4690 position=corner, tile_count=n, complete = .false. )
4691 call mpp_get_boundary(x2(:,:,:,n), domain, sbuffer=sbuffer2(:,:,n), wbuffer=wbuffer2(:,:,n), &
4692 position=corner, tile_count=n, complete = .true. )
4694 call mpp_get_boundary(x1(:,:,:,n), domain, ebuffer=ebuffer1(:,:,n), sbuffer=sbuffer1(:,:,n), wbuffer=wbuffer1(:,:,n), &
4695 nbuffer=nbuffer1(:,:,n), position=corner, tile_count=n, complete = .false. )
4696 call mpp_get_boundary(x2(:,:,:,n), domain, ebuffer=ebuffer2(:,:,n), sbuffer=sbuffer2(:,:,n), wbuffer=wbuffer2(:,:,n), &
4697 nbuffer=nbuffer2(:,:,n), position=corner, tile_count=n, complete = .true. )
4704 do n = 1, ntile_per_pe
4705 call fill_four_tile_bound(global_all, isc, iec, jsc, jec, 1, 1, &
4706 tile(n), ebound(:,:,n), sbound(:,:,n), wbound(:,:,n), nbound(:,:,n) )
4709 do n = 1, ntile_per_pe
4710 call fill_cubic_grid_bound(global_all, global_all, isc, iec, jsc, jec, 1, 1, &
4711 tile(n), 1, 1, ebound(:,:,n), sbound(:,:,n), wbound(:,:,n), nbound(:,:,n) )
4713 case(
"Folded-north")
4715 global_all(nx/2+2:nx, ny+1,:,1) = global_all(nx/2:2:-1, ny+1,:,1)
4716 do n = 1, ntile_per_pe
4717 call fill_folded_north_bound(global_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
4718 tile(n), sbound(:,:,n), wbound(:,:,n) )
4721 do n = 1, ntile_per_pe
4722 call fill_torus_bound(global_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
4723 tile(n), sbound(:,:,n), wbound(:,:,n) )
4727 if(.not. folded_north .AND. .not. is_torus)
then 4730 call compare_checksums( ebound, ebuffer1(:,:,:),
"east bound of "//trim(type)//
" X1" )
4731 call compare_checksums( nbound, nbuffer1(:,:,:),
"north bound of "//trim(type)//
" X1" )
4732 call compare_checksums( ebound*10, ebuffer2(:,:,:),
"east bound of "//trim(type)//
" X2" )
4733 call compare_checksums( nbound*10, nbuffer2(:,:,:),
"north bound of "//trim(type)//
" X2" )
4737 call compare_checksums( sbound, sbuffer1(:,:,:),
"south bound of "//trim(type)//
" X1" )
4738 call compare_checksums( wbound, wbuffer1(:,:,:),
"west bound of "//trim(type)//
" X1" )
4739 call compare_checksums( sbound*10, sbuffer2(:,:,:),
"south bound of "//trim(type)//
" X2" )
4740 call compare_checksums( wbound*10, wbuffer2(:,:,:),
"west bound of "//trim(type)//
" X2" )
4743 deallocate(global, global_all, x, x1, x2)
4744 deallocate(ebuffer, sbuffer, wbuffer, nbuffer)
4745 deallocate(ebuffer1, sbuffer1, wbuffer1, nbuffer1)
4746 deallocate(ebuffer2, sbuffer2, wbuffer2, nbuffer2)
4747 deallocate(ebound, sbound, wbound, nbound )
4754 allocate(global1_all(1:nx+1,1:ny+1,nz, ntiles) )
4755 allocate(global2_all(1:nx+1,1:ny+1,nz, ntiles) )
4756 allocate(global1(1:nx+1,1:ny+1,nz, ntile_per_pe) )
4757 allocate(global2(1:nx+1,1:ny+1,nz, ntile_per_pe) )
4762 global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4763 global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4769 do n = 1, ntile_per_pe
4770 global1(:,:,:,n) = global1_all(:,:,:,tile(n))
4771 global2(:,:,:,n) = global2_all(:,:,:,tile(n))
4773 allocate( x(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4774 allocate( x1(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4775 allocate( x2(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4776 allocate( y(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4777 allocate( y1(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4778 allocate( y2(ism:iem+1,jsm:jem+1,nz, ntile_per_pe) )
4780 if( trim(type) ==
"Folded-north" )
then 4781 x(isc+1:iec+1,jsc+1:jec+1,:,:) = global1(isc+1:iec+1,jsc+1:jec+1,:,:)
4782 y(isc+1:iec+1,jsc+1:jec+1,:,:) = global2(isc+1:iec+1,jsc+1:jec+1,:,:)
4784 x(isc:iec+1,jsc:jec+1,:,:) = global1(isc:iec+1,jsc:jec+1,:,:)
4785 y(isc:iec+1,jsc:jec+1,:,:) = global2(isc:iec+1,jsc:jec+1,:,:)
4791 allocate(ebufferx(jsc:jec+1, nz, ntile_per_pe), wbufferx(jsc:jec+1, nz, ntile_per_pe))
4792 allocate(sbufferx(isc:iec+1, nz, ntile_per_pe), nbufferx(isc:iec+1, nz, ntile_per_pe))
4793 allocate(ebufferx1(jsc:jec+1, nz, ntile_per_pe), wbufferx1(jsc:jec+1, nz, ntile_per_pe))
4794 allocate(sbufferx1(isc:iec+1, nz, ntile_per_pe), nbufferx1(isc:iec+1, nz, ntile_per_pe))
4795 allocate(ebufferx2(jsc:jec+1, nz, ntile_per_pe), wbufferx2(jsc:jec+1, nz, ntile_per_pe))
4796 allocate(sbufferx2(isc:iec+1, nz, ntile_per_pe), nbufferx2(isc:iec+1, nz, ntile_per_pe))
4797 allocate(eboundx(jsc:jec+1, nz, ntile_per_pe), wboundx(jsc:jec+1, nz, ntile_per_pe))
4798 allocate(sboundx(isc:iec+1, nz, ntile_per_pe), nboundx(isc:iec+1, nz, ntile_per_pe))
4799 allocate(ebuffery(jsc:jec+1, nz, ntile_per_pe), wbuffery(jsc:jec+1, nz, ntile_per_pe))
4800 allocate(sbuffery(isc:iec+1, nz, ntile_per_pe), nbuffery(isc:iec+1, nz, ntile_per_pe))
4801 allocate(ebuffery1(jsc:jec+1, nz, ntile_per_pe), wbuffery1(jsc:jec+1, nz, ntile_per_pe))
4802 allocate(sbuffery1(isc:iec+1, nz, ntile_per_pe), nbuffery1(isc:iec+1, nz, ntile_per_pe))
4803 allocate(ebuffery2(jsc:jec+1, nz, ntile_per_pe), wbuffery2(jsc:jec+1, nz, ntile_per_pe))
4804 allocate(sbuffery2(isc:iec+1, nz, ntile_per_pe), nbuffery2(isc:iec+1, nz, ntile_per_pe))
4805 allocate(eboundy(jsc:jec+1, nz, ntile_per_pe), wboundy(jsc:jec+1, nz, ntile_per_pe))
4806 allocate(sboundy(isc:iec+1, nz, ntile_per_pe), nboundy(isc:iec+1, nz, ntile_per_pe))
4807 eboundx = 0; ebufferx = 0; ebufferx1 = 0; ebufferx2 = 0
4808 sboundx = 0; sbufferx = 0; sbufferx1 = 0; sbufferx2 = 0
4809 wboundx = 0; wbufferx = 0; wbufferx1 = 0; wbufferx2 = 0
4810 nboundx = 0; nbufferx = 0; nbufferx1 = 0; nbufferx2 = 0
4811 eboundy = 0; ebuffery = 0; ebuffery1 = 0; ebuffery2 = 0
4812 sboundy = 0; sbuffery = 0; sbuffery1 = 0; sbuffery2 = 0
4813 wboundy = 0; wbuffery = 0; wbuffery1 = 0; wbuffery2 = 0
4814 nboundy = 0; nbuffery = 0; nbuffery1 = 0; nbuffery2 = 0
4817 do n = 1, ntile_per_pe
4818 if(folded_north .or. is_torus)
then 4819 call mpp_get_boundary(x(:,:,:,n), y(:,:,:,n), domain, sbufferx=sbufferx(:,:,n), wbufferx=wbufferx(:,:,n), &
4820 sbuffery=sbuffery(:,:,n), wbuffery=wbuffery(:,:,n), gridtype=bgrid_ne, tile_count=n, flags = scalar_pair )
4822 call mpp_get_boundary(x(:,:,:,n), y(:,:,:,n), domain, ebufferx=ebufferx(:,:,n), sbufferx=sbufferx(:,:,n), &
4823 wbufferx=wbufferx(:,:,n), nbufferx=nbufferx(:,:,n), ebuffery=ebuffery(:,:,n), &
4824 sbuffery=sbuffery(:,:,n), wbuffery=wbuffery(:,:,n), nbuffery=nbuffery(:,:,n), &
4825 gridtype=bgrid_ne, tile_count=n, flags = scalar_pair )
4829 do n = 1, ntile_per_pe
4830 if(folded_north .or. is_torus)
then 4831 call mpp_get_boundary(x1(:,:,:,n), y1(:,:,:,n), domain, sbufferx=sbufferx1(:,:,n), wbufferx=wbufferx1(:,:,n), &
4832 sbuffery=sbuffery1(:,:,n), wbuffery=wbuffery1(:,:,n), &
4833 gridtype=bgrid_ne, tile_count=n, flags = scalar_pair, complete = .false. )
4834 call mpp_get_boundary(x2(:,:,:,n), y2(:,:,:,n), domain, sbufferx=sbufferx2(:,:,n), wbufferx=wbufferx2(:,:,n), &
4835 sbuffery=sbuffery2(:,:,n), wbuffery=wbuffery2(:,:,n), &
4836 gridtype=bgrid_ne, tile_count=n, flags = scalar_pair, complete = .true. )
4838 call mpp_get_boundary(x1(:,:,:,n), y1(:,:,:,n), domain, ebufferx=ebufferx1(:,:,n), sbufferx=sbufferx1(:,:,n), &
4839 wbufferx=wbufferx1(:,:,n), nbufferx=nbufferx1(:,:,n), ebuffery=ebuffery1(:,:,n), &
4840 sbuffery=sbuffery1(:,:,n), wbuffery=wbuffery1(:,:,n), nbuffery=nbuffery1(:,:,n), &
4841 gridtype=bgrid_ne, tile_count=n, flags = scalar_pair, complete = .false. )
4842 call mpp_get_boundary(x2(:,:,:,n), y2(:,:,:,n), domain, ebufferx=ebufferx2(:,:,n), sbufferx=sbufferx2(:,:,n), &
4843 wbufferx=wbufferx2(:,:,n), nbufferx=nbufferx2(:,:,n), ebuffery=ebuffery2(:,:,n), &
4844 sbuffery=sbuffery2(:,:,n), wbuffery=wbuffery2(:,:,n), nbuffery=nbuffery2(:,:,n), &
4845 gridtype=bgrid_ne, tile_count=n, flags = scalar_pair, complete = .true. )
4852 do n = 1, ntile_per_pe
4853 call fill_four_tile_bound(global1_all, isc, iec, jsc, jec, 1, 1, &
4854 tile(n), eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )
4855 call fill_four_tile_bound(global2_all, isc, iec, jsc, jec, 1, 1, &
4856 tile(n), eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )
4859 do n = 1, ntile_per_pe
4860 call fill_cubic_grid_bound(global1_all, global2_all, isc, iec, jsc, jec, 1, 1, &
4861 tile(n), 1, 1, eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )
4862 call fill_cubic_grid_bound(global2_all, global1_all, isc, iec, jsc, jec, 1, 1, &
4863 tile(n), 1, 1, eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )
4865 case(
"Folded-north")
4866 global1_all(nx/2+2:nx, ny+1,:,1) = global1_all(nx/2:2:-1, ny+1,:,1)
4867 global2_all(nx/2+2:nx, ny+1,:,1) = global2_all(nx/2:2:-1, ny+1,:,1)
4868 do n = 1, ntile_per_pe
4869 call fill_folded_north_bound(global1_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
4870 tile(n), sboundx(:,:,n), wboundx(:,:,n) )
4871 call fill_folded_north_bound(global2_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
4872 tile(n), sboundy(:,:,n), wboundy(:,:,n) )
4875 do n = 1, ntile_per_pe
4876 call fill_torus_bound(global1_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
4877 tile(n), sboundx(:,:,n), wboundx(:,:,n) )
4878 call fill_torus_bound(global2_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
4879 tile(n), sboundy(:,:,n), wboundy(:,:,n) )
4883 if(.not. folded_north .AND. .not. is_torus )
then 4884 call compare_checksums( eboundx, ebufferx(:,:,:),
"east bound of SCALAR_PAIR BGRID " //trim(type)//
" X" )
4885 call compare_checksums( nboundx, nbufferx(:,:,:),
"north bound of SCALAR_PAIR BGRID "//trim(type)//
" X" )
4886 call compare_checksums( eboundy, ebuffery(:,:,:),
"east bound of SCALAR_PAIR BGRID " //trim(type)//
" Y" )
4887 call compare_checksums( nboundy, nbuffery(:,:,:),
"north bound of SCALAR_PAIR BGRID "//trim(type)//
" Y" )
4888 call compare_checksums( eboundx, ebufferx1(:,:,:),
"east bound of SCALAR_PAIR BGRID " //trim(type)//
" X1" )
4889 call compare_checksums( nboundx, nbufferx1(:,:,:),
"north bound of SCALAR_PAIR BGRID "//trim(type)//
" X1" )
4890 call compare_checksums( eboundy, ebuffery1(:,:,:),
"east bound of SCALAR_PAIR BGRID " //trim(type)//
" Y1" )
4891 call compare_checksums( nboundy, nbuffery1(:,:,:),
"north bound of SCALAR_PAIR BGRID "//trim(type)//
" Y1" )
4894 call compare_checksums( sboundx, sbufferx(:,:,:),
"south bound of SCALAR_PAIR BGRID "//trim(type)//
" X" )
4895 call compare_checksums( wboundx, wbufferx(:,:,:),
"west bound of SCALAR_PAIR BGRID " //trim(type)//
" X" )
4896 call compare_checksums( sboundy, sbuffery(:,:,:),
"south bound of SCALAR_PAIR BGRID "//trim(type)//
" Y" )
4897 call compare_checksums( wboundy, wbuffery(:,:,:),
"west bound of SCALAR_PAIR BGRID " //trim(type)//
" Y" )
4898 call compare_checksums( sboundx, sbufferx1(:,:,:),
"south bound of SCALAR_PAIR BGRID "//trim(type)//
" X1" )
4899 call compare_checksums( wboundx, wbufferx1(:,:,:),
"west bound of SCALAR_PAIR BGRID " //trim(type)//
" X1" )
4900 call compare_checksums( sboundy, sbuffery1(:,:,:),
"south bound of SCALAR_PAIR BGRID "//trim(type)//
" Y1" )
4901 call compare_checksums( wboundy, wbuffery1(:,:,:),
"west bound of SCALAR_PAIR BGRID " //trim(type)//
" Y1" )
4905 do n = 1, ntile_per_pe
4906 call fill_four_tile_bound(global1_all*10, isc, iec, jsc, jec, 1, 1, &
4907 tile(n), eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )
4908 call fill_four_tile_bound(global2_all*10, isc, iec, jsc, jec, 1, 1, &
4909 tile(n), eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )
4912 do n = 1, ntile_per_pe
4913 call fill_cubic_grid_bound(global1_all*10, global2_all*10, isc, iec, jsc, jec, 1, 1, &
4914 tile(n), 1, 1, eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )
4915 call fill_cubic_grid_bound(global2_all*10, global1_all*10, isc, iec, jsc, jec, 1, 1, &
4916 tile(n), 1, 1, eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )
4918 case(
"Folded-north")
4919 do n = 1, ntile_per_pe
4920 call fill_folded_north_bound(global1_all(:,:,:,1)*10, isc, iec, jsc, jec, 1, 1, &
4921 tile(n), sboundx(:,:,n), wboundx(:,:,n) )
4922 call fill_folded_north_bound(global2_all(:,:,:,1)*10, isc, iec, jsc, jec, 1, 1, &
4923 tile(n), sboundy(:,:,n), wboundy(:,:,n) )
4926 do n = 1, ntile_per_pe
4927 call fill_torus_bound(global1_all(:,:,:,1)*10, isc, iec, jsc, jec, 1, 1, &
4928 tile(n), sboundx(:,:,n), wboundx(:,:,n) )
4929 call fill_torus_bound(global2_all(:,:,:,1)*10, isc, iec, jsc, jec, 1, 1, &
4930 tile(n), sboundy(:,:,n), wboundy(:,:,n) )
4934 if(.not. folded_north .AND. .not. is_torus )
then 4935 call compare_checksums( eboundx, ebufferx2(:,:,:),
"east bound of SCALAR_PAIR BGRID " //trim(type)//
" X2" )
4936 call compare_checksums( nboundx, nbufferx2(:,:,:),
"north bound of SCALAR_PAIR BGRID "//trim(type)//
" X2" )
4937 call compare_checksums( eboundy, ebuffery2(:,:,:),
"east bound of SCALAR_PAIR BGRID " //trim(type)//
" Y2" )
4938 call compare_checksums( nboundy, nbuffery2(:,:,:),
"north bound of SCALAR_PAIR BGRID "//trim(type)//
" Y2" )
4940 call compare_checksums( sboundx, sbufferx2(:,:,:),
"south bound of SCALAR_PAIR BGRID "//trim(type)//
" X2" )
4941 call compare_checksums( wboundx, wbufferx2(:,:,:),
"west bound of SCALAR_PAIR BGRID " //trim(type)//
" X2" )
4942 call compare_checksums( sboundy, sbuffery2(:,:,:),
"south bound of SCALAR_PAIR BGRID "//trim(type)//
" Y2" )
4943 call compare_checksums( wboundy, wbuffery2(:,:,:),
"west bound of SCALAR_PAIR BGRID " //trim(type)//
" Y2" )
4954 global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4955 global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
4962 eboundx = 0; ebufferx = 0; ebufferx1 = 0; ebufferx2 = 0
4963 sboundx = 0; sbufferx = 0; sbufferx1 = 0; sbufferx2 = 0
4964 wboundx = 0; wbufferx = 0; wbufferx1 = 0; wbufferx2 = 0
4965 nboundx = 0; nbufferx = 0; nbufferx1 = 0; nbufferx2 = 0
4966 eboundy = 0; ebuffery = 0; ebuffery1 = 0; ebuffery2 = 0
4967 sboundy = 0; sbuffery = 0; sbuffery1 = 0; sbuffery2 = 0
4968 wboundy = 0; wbuffery = 0; wbuffery1 = 0; wbuffery2 = 0
4969 nboundy = 0; nbuffery = 0; nbuffery1 = 0; nbuffery2 = 0
4971 x(isc:iec+1,jsc:jec+1,1,:) = global1(isc:iec+1,jsc:jec+1,1,:)
4972 y(isc:iec+1,jsc:jec+1,1,:) = global2(isc:iec+1,jsc:jec+1,1,:)
4974 do n = 1, ntile_per_pe
4975 if(folded_north .or. is_torus )
then 4976 call mpp_get_boundary(x(:,:,1,n), y(:,:,1,n), domain, sbufferx=sbufferx(:,1,n), wbufferx=wbufferx(:,1,n), &
4977 sbuffery=sbuffery(:,1,n), wbuffery=wbuffery(:,1,n), gridtype=bgrid_ne, tile_count=n)
4980 call mpp_get_boundary(x(:,:,1,n), y(:,:,1,n), domain, ebufferx=ebufferx(:,1,n), sbufferx=sbufferx(:,1,n), &
4981 wbufferx=wbufferx(:,1,n), nbufferx=nbufferx(:,1,n), ebuffery=ebuffery(:,1,n), &
4982 sbuffery=sbuffery(:,1,n), wbuffery=wbuffery(:,1,n), nbuffery=nbuffery(:,1,n), &
4983 gridtype=bgrid_ne, tile_count=n)
4987 if(folded_north)
then 4988 allocate(u_nonsym(ism:iem,jsm:jem), v_nonsym(ism:iem,jsm:jem))
4989 u_nonsym = 0.0; v_nonsym = 0.0
4990 u_nonsym(isc:iec,jsc:jec) = global1(isc+1:iec+1,jsc+1:jec+1,1,1)
4991 v_nonsym(isc:iec,jsc:jec) = global2(isc+1:iec+1,jsc+1:jec+1,1,1)
4996 if(sbufferx(i,1,1) .NE. u_nonsym(i-1,jsc-1))
then 4997 print*,
"pe ", mpp_pe(), i, jsc-1, sbufferx(i,1,1), u_nonsym(i-1,jsc-1)
4998 call mpp_error(fatal,
"test_get_boundary: mismatch of sbufferx")
5001 call mpp_error(note,
"test_get_boundary: reproduce non-symmetric halo update for sbufferx")
5005 if(sbuffery(i,1,1) .NE. v_nonsym(i-1,jsc-1))
then 5006 print*,
"pe ", mpp_pe(), i, jsc-1, sbufferx(i,1,1), v_nonsym(i-1,jsc-1)
5007 call mpp_error(fatal,
"test_get_boundary: mismatch of sbuffery")
5010 call mpp_error(note,
"test_get_boundary: reproduce non-symmetric halo update for sbuffery")
5014 if(wbufferx(j,1,1) .NE. u_nonsym(isc-1,j-1))
then 5015 print*,
"pe ", mpp_pe(), isc-1, j, wbufferx(j,1,1), u_nonsym(isc-1,j-1)
5016 call mpp_error(fatal,
"test_get_boundary: mismatch of wbufferx")
5019 call mpp_error(note,
"test_get_boundary: reproduce non-symmetric halo update for wbufferx")
5023 if(wbuffery(j,1,1) .NE. v_nonsym(isc-1,j-1))
then 5024 print*,
"pe ", mpp_pe(), isc-1, j, wbuffery(j,1,1), v_nonsym(isc-1,j-1)
5025 call mpp_error(fatal,
"test_get_boundary: mismatch of wbuffery")
5028 call mpp_error(note,
"test_get_boundary: reproduce non-symmetric halo update for wbuffery")
5030 deallocate(u_nonsym, v_nonsym)
5037 do n = 1, ntile_per_pe
5038 call fill_four_tile_bound(global1_all, isc, iec, jsc, jec, 1, 1, &
5039 tile(n), eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )
5040 call fill_four_tile_bound(global2_all, isc, iec, jsc, jec, 1, 1, &
5041 tile(n), eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )
5044 do n = 1, ntile_per_pe
5045 call fill_cubic_grid_bound(global1_all, global2_all, isc, iec, jsc, jec, 1, 1, &
5046 tile(n), 1, -1, eboundx(:,:,n), sboundx(:,:,n), wboundx(:,:,n), nboundx(:,:,n) )
5047 call fill_cubic_grid_bound(global2_all, global1_all, isc, iec, jsc, jec, 1, 1, &
5048 tile(n), -1, 1, eboundy(:,:,n), sboundy(:,:,n), wboundy(:,:,n), nboundy(:,:,n) )
5050 case(
"Folded-north")
5051 global1_all(nx/2+2:nx, ny+1,:,1) = -global1_all(nx/2:2:-1, ny+1,:,1)
5052 global2_all(nx/2+2:nx, ny+1,:,1) = -global2_all(nx/2:2:-1, ny+1,:,1)
5053 global1_all(1, ny+1,:,1) = 0
5054 global2_all(1, ny+1,:,1) = 0
5055 global1_all(nx/2+1, ny+1,:,1) = 0
5056 global2_all(nx/2+1, ny+1,:,1) = 0
5057 global1_all(nx+1, ny+1,:,1) = 0
5058 global2_all(nx+1, ny+1,:,1) = 0
5061 do n = 1, ntile_per_pe
5062 call fill_folded_north_bound(global1_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
5063 tile(n), sboundx(:,:,n), wboundx(:,:,n) )
5064 call fill_folded_north_bound(global2_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
5065 tile(n), sboundy(:,:,n), wboundy(:,:,n) )
5075 do n = 1, ntile_per_pe
5076 call fill_torus_bound(global1_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
5077 tile(n), sboundx(:,:,n), wboundx(:,:,n) )
5078 call fill_torus_bound(global2_all(:,:,:,1), isc, iec, jsc, jec, 1, 1, &
5079 tile(n), sboundy(:,:,n), wboundy(:,:,n) )
5083 if(.not. folded_north .AND. .not. is_torus )
then 5084 call compare_checksums( eboundx(:,1:1,:), ebufferx(:,1:1,:),
"east bound of 2-D BGRID " //trim(type)//
" X" )
5085 call compare_checksums( nboundx(:,1:1,:), nbufferx(:,1:1,:),
"north bound of 2-D BGRID "//trim(type)//
" X" )
5086 call compare_checksums( eboundy(:,1:1,:), ebuffery(:,1:1,:),
"east bound of 2-D BGRID " //trim(type)//
" Y" )
5087 call compare_checksums( nboundy(:,1:1,:), nbuffery(:,1:1,:),
"north bound of 2-D BGRID "//trim(type)//
" Y" )
5090 call compare_checksums( sboundx(:,1:1,:), sbufferx(:,1:1,:),
"south bound of 2-D BGRID "//trim(type)//
" X" )
5091 call compare_checksums( wboundx(:,1:1,:), wbufferx(:,1:1,:),
"west bound of 2-D BGRID " //trim(type)//
" X" )
5092 call compare_checksums( sboundy(:,1:1,:), sbuffery(:,1:1,:),
"south bound of 2-D BGRID "//trim(type)//
" Y" )
5093 call compare_checksums( wboundy(:,1:1,:), wbuffery(:,1:1,:),
"west bound of 2-D BGRID " //trim(type)//
" Y" )
5097 deallocate(global1, global1_all, global2, global2_all)
5098 deallocate(x, y, x1, y1, x2, y2)
5099 deallocate(ebufferx, sbufferx, wbufferx, nbufferx)
5100 deallocate(ebufferx1, sbufferx1, wbufferx1, nbufferx1)
5101 deallocate(ebufferx2, sbufferx2, wbufferx2, nbufferx2)
5102 deallocate(ebuffery, sbuffery, wbuffery, nbuffery)
5103 deallocate(ebuffery1, sbuffery1, wbuffery1, nbuffery1)
5104 deallocate(ebuffery2, sbuffery2, wbuffery2, nbuffery2)
5105 deallocate(eboundx, sboundx, wboundx, nboundx )
5106 deallocate(eboundy, sboundy, wboundy, nboundy )
5113 allocate(global1_all(1:nx+1,1:ny, nz, ntiles) )
5114 allocate(global2_all(1:nx, 1:ny+1,nz, ntiles) )
5115 allocate(global1(1:nx+1,1:ny, nz, ntile_per_pe) )
5116 allocate(global2(1:nx, 1:ny+1,nz, ntile_per_pe) )
5121 global1_all(i,j,k,l) = 1.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
5126 global2_all(i,j,k,l) = 2.0e3 + l + i*1.0e-3 + j*1.0e-6 + k*1.0e-9
5132 do n = 1, ntile_per_pe
5133 global1(:,:,:,n) = global1_all(:,:,:,tile(n))
5134 global2(:,:,:,n) = global2_all(:,:,:,tile(n))
5136 allocate( x(ism:iem+1,jsm:jem, nz, ntile_per_pe) )
5137 allocate( x1(ism:iem+1,jsm:jem, nz, ntile_per_pe) )
5138 allocate( x2(ism:iem+1,jsm:jem, nz, ntile_per_pe) )
5139 allocate( y(ism:iem, jsm:jem+1,nz, ntile_per_pe) )
5140 allocate( y1(ism:iem, jsm:jem+1,nz, ntile_per_pe) )
5141 allocate( y2(ism:iem, jsm:jem+1,nz, ntile_per_pe) )
5143 x(isc:iec+1,jsc:jec, :,:) = global1(isc:iec+1,jsc:jec, :,:)
5144 y(isc:iec, jsc:jec+1,:,:) = global2(isc:iec, jsc:jec+1,:,:)
5149 allocate(ebufferx(jec-jsc+1, nz, ntile_per_pe), wbufferx(jec-jsc+1, nz, ntile_per_pe))
5150 allocate(sbufferx(iec-isc+2, nz, ntile_per_pe), nbufferx(iec-isc+2, nz, ntile_per_pe))
5151 allocate(ebufferx1(jec-jsc+1, nz, ntile_per_pe), wbufferx1(jec-jsc+1, nz, ntile_per_pe))
5152 allocate(sbufferx1(iec-isc+2, nz, ntile_per_pe), nbufferx1(iec-isc+2, nz, ntile_per_pe))
5153 allocate(ebufferx2(jec-jsc+1, nz, ntile_per_pe), wbufferx2(jec-jsc+1, nz, ntile_per_pe))
5154 allocate(sbufferx2(iec-isc+2, nz, ntile_per_pe), nbufferx2(iec-isc+2, nz, ntile_per_pe))
5155 allocate(ebuffery(jec-jsc+2, nz, ntile_per_pe), wbuffery(jec-jsc+2, nz, ntile_per_pe))
5156 allocate(sbuffery(iec-isc+1, nz, ntile_per_pe), nbuffery(iec-isc+1, nz, ntile_per_pe))
5157 allocate(ebuffery1(jec-jsc+2, nz, ntile_per_pe), wbuffery1(jec-jsc+2, nz, ntile_per_pe))
5158 allocate(sbuffery1(iec-isc+1, nz, ntile_per_pe), nbuffery1(iec-isc+1, nz, ntile_per_pe))
5159 allocate(ebuffery2(jec-jsc+2, nz, ntile_per_pe), wbuffery2(jec-jsc+2, nz, ntile_per_pe))
5160 allocate(sbuffery2(iec-isc+1, nz, ntile_per_pe), nbuffery2(iec-isc+1, nz, ntile_per_pe))
5161 allocate(eboundx(jec-jsc+1, nz, ntile_per_pe), wboundx(jec-jsc+1, nz, ntile_per_pe))
5162 allocate(sboundy(iec-isc+1, nz, ntile_per_pe), nboundy(iec-isc+1, nz, ntile_per_pe))
5163 eboundx = 0; ebufferx = 0; ebufferx1 = 0; ebufferx2 = 0
5164 wboundx = 0; wbufferx = 0; wbufferx1 = 0; wbufferx2 = 0
5165 sboundy = 0; sbuffery = 0; sbuffery1 = 0; sbuffery2 = 0
5166 nboundy = 0; nbuffery = 0; nbuffery1 = 0; nbuffery2 = 0
5169 do n = 1, ntile_per_pe
5170 if(folded_north .or. is_torus)
then 5171 call mpp_get_boundary(x(:,:,:,n), y(:,:,:,n), domain, wbufferx=wbufferx(:,:,n), &
5172 sbuffery=sbuffery(:,:,n), gridtype=cgrid_ne, tile_count=n )
5174 call mpp_get_boundary(x(:,:,:,n), y(:,:,:,n), domain, ebufferx=ebufferx(:,:,n), wbufferx=wbufferx(:,:,n), &
5175 sbuffery=sbuffery(:,:,n), nbuffery=nbuffery(:,:,n), gridtype=cgrid_ne, tile_count=n )
5179 do n = 1, ntile_per_pe
5180 if( folded_north .or. is_torus )
then 5181 call mpp_get_boundary(x1(:,:,:,n), y1(:,:,:,n), domain, wbufferx=wbufferx1(:,:,n), &
5182 sbuffery=sbuffery1(:,:,n), gridtype=cgrid_ne, tile_count=n, &
5183 complete = .false. )
5184 call mpp_get_boundary(x2(:,:,:,n), y2(:,:,:,n), domain, wbufferx=wbufferx2(:,:,n), &
5185 sbuffery=sbuffery2(:,:,n), gridtype=cgrid_ne, tile_count=n, &
5188 call mpp_get_boundary(x1(:,:,:,n), y1(:,:,:,n), domain, ebufferx=ebufferx1(:,:,n), wbufferx=wbufferx1(:,:,n), &
5189 sbuffery=sbuffery1(:,:,n), nbuffery=nbuffery1(:,:,n), gridtype=cgrid_ne, tile_count=n, &
5190 complete = .false. )
5191 call mpp_get_boundary(x2(:,:,:,n), y2(:,:,:,n), domain, ebufferx=ebufferx2(:,:,n), wbufferx=wbufferx2(:,:,n), &
5192 sbuffery=sbuffery2(:,:,n), nbuffery=nbuffery2(:,:,n), gridtype=cgrid_ne, tile_count=n, &
5200 do n = 1, ntile_per_pe
5201 call fill_four_tile_bound(global1_all, isc, iec, jsc, jec, 1, 0, &
5202 tile(n), ebound=eboundx(:,:,n), wbound=wboundx(:,:,n) )
5203 call fill_four_tile_bound(global2_all, isc, iec, jsc, jec, 0, 1, &
5204 tile(n), sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )
5207 do n = 1, ntile_per_pe
5208 call fill_cubic_grid_bound(global1_all, global2_all, isc, iec, jsc, jec, 1, 0, &
5209 tile(n), 1, -1, ebound=eboundx(:,:,n), wbound=wboundx(:,:,n) )
5210 call fill_cubic_grid_bound(global2_all, global1_all, isc, iec, jsc, jec, 0, 1, &
5211 tile(n), -1, 1, sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )
5213 case(
"Folded-north")
5214 do n = 1, ntile_per_pe
5215 call fill_folded_north_bound(global1_all(:,:,:,1), isc, iec, jsc, jec, 1, 0, &
5216 tile(n), wbound=wboundx(:,:,n) )
5217 call fill_folded_north_bound(global2_all(:,:,:,1), isc, iec, jsc, jec, 0, 1, &
5218 tile(n), sbound=sboundy(:,:,n) )
5221 do n = 1, ntile_per_pe
5222 call fill_torus_bound(global1_all(:,:,:,1), isc, iec, jsc, jec, 1, 0, &
5223 tile(n), wbound=wboundx(:,:,n) )
5224 call fill_torus_bound(global2_all(:,:,:,1), isc, iec, jsc, jec, 0, 1, &
5225 tile(n), sbound=sboundy(:,:,n) )
5229 if(.not. folded_north .and. .not. is_torus )
then 5230 call compare_checksums( eboundx, ebufferx(:,:,:),
"east bound of CGRID " //trim(type)//
" X" )
5231 call compare_checksums( nboundy, nbuffery(:,:,:),
"north bound of CGRID "//trim(type)//
" Y" )
5232 call compare_checksums( eboundx, ebufferx1(:,:,:),
"east bound of CGRID " //trim(type)//
" X1" )
5233 call compare_checksums( nboundy, nbuffery1(:,:,:),
"north bound of CGRID "//trim(type)//
" Y1" )
5235 call compare_checksums( wboundx, wbufferx(:,:,:),
"west bound of CGRID " //trim(type)//
" X" )
5236 call compare_checksums( sboundy, sbuffery(:,:,:),
"south bound of CGRID "//trim(type)//
" Y" )
5237 call compare_checksums( wboundx, wbufferx1(:,:,:),
"west bound of CGRID " //trim(type)//
" X1" )
5238 call compare_checksums( sboundy, sbuffery1(:,:,:),
"south bound of CGRID "//trim(type)//
" Y1" )
5242 do n = 1, ntile_per_pe
5243 call fill_four_tile_bound(global1_all*10, isc, iec, jsc, jec, 1, 0, &
5244 tile(n), ebound=eboundx(:,:,n), wbound=wboundx(:,:,n) )
5245 call fill_four_tile_bound(global2_all*10, isc, iec, jsc, jec, 0, 1, &
5246 tile(n), sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )
5249 do n = 1, ntile_per_pe
5250 call fill_cubic_grid_bound(global1_all*10, global2_all*10, isc, iec, jsc, jec, 1, 0, &
5251 tile(n), 1, -1, ebound=eboundx(:,:,n), wbound=wboundx(:,:,n) )
5252 call fill_cubic_grid_bound(global2_all*10, global1_all*10, isc, iec, jsc, jec, 0, 1, &
5253 tile(n), -1, 1, sbound=sboundy(:,:,n), nbound=nboundy(:,:,n) )
5255 case(
"Folded-north")
5256 do n = 1, ntile_per_pe
5257 call fill_folded_north_bound(global1_all(:,:,:,1)*10, isc, iec, jsc, jec, 1, 0, &
5258 tile(n), wbound=wboundx(:,:,n) )
5259 call fill_folded_north_bound(global2_all(:,:,:,1)*10, isc, iec, jsc, jec, 0, 1, &
5260 tile(n), sbound=sboundy(:,:,n) )
5263 do n = 1, ntile_per_pe
5264 call fill_torus_bound(global1_all(:,:,:,1)*10, isc, iec, jsc, jec, 1, 0, &
5265 tile(n), wbound=wboundx(:,:,n) )
5266 call fill_torus_bound(global2_all(:,:,:,1)*10, isc, iec, jsc, jec, 0, 1, &
5267 tile(n), sbound=sboundy(:,:,n) )
5271 if(.not. folded_north .and. .not. is_torus )
then 5272 call compare_checksums( eboundx, ebufferx2(:,:,:),
"east bound of CGRID " //trim(type)//
" X2" )
5273 call compare_checksums( nboundy, nbuffery2(:,:,:),
"north bound of CGRID "//trim(type)//
" Y2" )
5275 call compare_checksums( wboundx, wbufferx2(:,:,:),
"west bound of CGRID " //trim(type)//
" X2" )
5276 call compare_checksums( sboundy, sbuffery2(:,:,:),
"south bound of CGRID "//trim(type)//
" Y2" )
5279 deallocate(global1, global1_all, global2, global2_all)
5280 deallocate(x, y, x1, y1, x2, y2)
5281 deallocate(ebufferx, sbufferx, wbufferx, nbufferx)
5282 deallocate(ebufferx1, sbufferx1, wbufferx1, nbufferx1)
5283 deallocate(ebufferx2, sbufferx2, wbufferx2, nbufferx2)
5284 deallocate(ebuffery, sbuffery, wbuffery, nbuffery)
5285 deallocate(ebuffery1, sbuffery1, wbuffery1, nbuffery1)
5286 deallocate(ebuffery2, sbuffery2, wbuffery2, nbuffery2)
5287 deallocate(eboundx, sboundy, wboundx, nboundy )
5292 end subroutine test_get_boundary
5295 subroutine define_fourtile_mosaic(type, domain, ni, nj, global_indices, layout, pe_start, pe_end, symmetry )
5296 character(len=*),
intent(in) :: type
5297 type(domain2d),
intent(inout) :: domain
5298 integer,
intent(in) :: global_indices(:,:), layout(:,:)
5299 integer,
intent(in) :: ni(:), nj(:)
5300 integer,
intent(in) :: pe_start(:), pe_end(:)
5301 logical,
intent(in) :: symmetry
5302 integer,
dimension(8) :: istart1, iend1, jstart1, jend1, tile1
5303 integer,
dimension(8) :: istart2, iend2, jstart2, jend2, tile2
5304 integer :: ntiles, num_contact, msize(2)
5308 if(
size(pe_start(:)) .NE. 4 .OR.
size(pe_end(:)) .NE. 4 )
call mpp_error(fatal, &
5309 "define_fourtile_mosaic: size of pe_start and pe_end should be 4")
5310 if(
size(global_indices,1) .NE. 4)
call mpp_error(fatal, &
5311 "define_fourtile_mosaic: size of first dimension of global_indices should be 4")
5312 if(
size(global_indices,2) .NE. 4)
call mpp_error(fatal, &
5313 "define_fourtile_mosaic: size of second dimension of global_indices should be 4")
5314 if(
size(layout,1) .NE. 2)
call mpp_error(fatal, &
5315 "define_fourtile_mosaic: size of first dimension of layout should be 2")
5316 if(
size(layout,2) .NE. 4)
call mpp_error(fatal, &
5317 "define_fourtile_mosaic: size of second dimension of layout should be 4")
5318 if(
size(ni(:)) .NE. 4 .OR.
size(nj(:)) .NE. 4)
call mpp_error(fatal, &
5319 "define_fourtile_mosaic: size of ni and nj should be 4")
5322 tile1(1) = 1; tile2(1) = 2
5323 istart1(1) = ni(1); iend1(1) = ni(1); jstart1(1) = 1; jend1(1) = nj(1)
5324 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = nj(2)
5326 tile1(2) = 1; tile2(2) = 3
5327 istart1(2) = 1; iend1(2) = ni(1); jstart1(2) = 1; jend1(2) = 1
5328 istart2(2) = 1; iend2(2) = ni(3); jstart2(2) = nj(3); jend2(2) = nj(3)
5330 tile1(3) = 1; tile2(3) = 2
5331 istart1(3) = 1; iend1(3) = 1; jstart1(3) = 1; jend1(3) = nj(1)
5332 istart2(3) = ni(2); iend2(3) = ni(2); jstart2(3) = 1; jend2(3) = nj(2)
5334 tile1(4) = 1; tile2(4) = 3
5335 istart1(4) = 1; iend1(4) = ni(1); jstart1(4) = nj(1); jend1(4) = nj(1)
5336 istart2(4) = 1; iend2(4) = ni(3); jstart2(4) = 1; jend2(4) = 1
5338 tile1(5) = 2; tile2(5) = 4
5339 istart1(5) = 1; iend1(5) = ni(2); jstart1(5) = 1; jend1(5) = 1
5340 istart2(5) = 1; iend2(5) = ni(4); jstart2(5) = nj(4); jend2(5) = nj(4)
5342 tile1(6) = 2; tile2(6) = 4
5343 istart1(6) = 1; iend1(6) = ni(2); jstart1(6) = nj(2); jend1(6) = nj(2)
5344 istart2(6) = 1; iend2(6) = ni(4); jstart2(6) = 1; jend2(6) = 1
5346 tile1(7) = 3; tile2(7) = 4
5347 istart1(7) = ni(3); iend1(7) = ni(3); jstart1(7) = 1; jend1(7) = nj(3)
5348 istart2(7) = 1; iend2(7) = 1; jstart2(7) = 1; jend2(7) = nj(4)
5350 tile1(8) = 3; tile2(8) = 4
5351 istart1(8) = 1; iend1(8) = 1; jstart1(8) = 1; jend1(8) = nj(3)
5352 istart2(8) = ni(4); iend2(8) = ni(4); jstart2(8) = 1; jend2(8) = nj(4)
5353 msize(1) = maxval(ni(:)/layout(1,:)) + whalo + ehalo + 1
5354 msize(2) = maxval(nj(:)/layout(2,:)) + shalo + nhalo + 1
5355 call mpp_define_mosaic(global_indices, layout, domain, ntiles, num_contact, tile1, tile2, &
5356 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
5357 pe_start, pe_end, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
5358 name =
type, memory_size = msize, symmetry = symmetry )
5362 end subroutine define_fourtile_mosaic
5366 subroutine define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_start, pe_end, use_memsize)
5367 character(len=*),
intent(in) :: type
5368 type(domain2d),
intent(inout) :: domain
5369 integer,
intent(in) :: global_indices(:,:), layout(:,:)
5370 integer,
intent(in) :: ni(:), nj(:)
5371 integer,
intent(in) :: pe_start(:), pe_end(:)
5372 logical,
optional,
intent(in) :: use_memsize
5373 integer,
dimension(12) :: istart1, iend1, jstart1, jend1, tile1
5374 integer,
dimension(12) :: istart2, iend2, jstart2, jend2, tile2
5375 integer :: ntiles, num_contact, msize(2)
5376 logical :: use_memsize_local
5378 use_memsize_local = .true.
5379 if(
present(use_memsize)) use_memsize_local = use_memsize
5383 if(
size(pe_start(:)) .NE. 6 .OR.
size(pe_end(:)) .NE. 6 )
call mpp_error(fatal, &
5384 "define_cubic_mosaic: size of pe_start and pe_end should be 6")
5385 if(
size(global_indices,1) .NE. 4)
call mpp_error(fatal, &
5386 "define_cubic_mosaic: size of first dimension of global_indices should be 4")
5387 if(
size(global_indices,2) .NE. 6)
call mpp_error(fatal, &
5388 "define_cubic_mosaic: size of second dimension of global_indices should be 6")
5389 if(
size(layout,1) .NE. 2)
call mpp_error(fatal, &
5390 "define_cubic_mosaic: size of first dimension of layout should be 2")
5391 if(
size(layout,2) .NE. 6)
call mpp_error(fatal, &
5392 "define_cubic_mosaic: size of second dimension of layout should be 6")
5393 if(
size(ni(:)) .NE. 6 .OR.
size(nj(:)) .NE. 6)
call mpp_error(fatal, &
5394 "define_cubic_mosaic: size of ni and nj should be 6")
5397 tile1(1) = 1; tile2(1) = 2
5398 istart1(1) = ni(1); iend1(1) = ni(1); jstart1(1) = 1; jend1(1) = nj(1)
5399 istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = nj(2)
5401 tile1(2) = 1; tile2(2) = 3
5402 istart1(2) = 1; iend1(2) = ni(1); jstart1(2) = nj(1); jend1(2) = nj(1)
5403 istart2(2) = 1; iend2(2) = 1; jstart2(2) = nj(3); jend2(2) = 1
5405 tile1(3) = 1; tile2(3) = 5
5406 istart1(3) = 1; iend1(3) = 1; jstart1(3) = 1; jend1(3) = nj(1)
5407 istart2(3) = ni(5); iend2(3) = 1; jstart2(3) = nj(5); jend2(3) = nj(5)
5409 tile1(4) = 1; tile2(4) = 6
5410 istart1(4) = 1; iend1(4) = ni(1); jstart1(4) = 1; jend1(4) = 1
5411 istart2(4) = 1; iend2(4) = ni(6); jstart2(4) = nj(6); jend2(4) = nj(6)
5413 tile1(5) = 2; tile2(5) = 3
5414 istart1(5) = 1; iend1(5) = ni(2); jstart1(5) = nj(2); jend1(5) = nj(2)
5415 istart2(5) = 1; iend2(5) = ni(3); jstart2(5) = 1; jend2(5) = 1
5417 tile1(6) = 2; tile2(6) = 4
5418 istart1(6) = ni(2); iend1(6) = ni(2); jstart1(6) = 1; jend1(6) = nj(2)
5419 istart2(6) = ni(4); iend2(6) = 1; jstart2(6) = 1; jend2(6) = 1
5421 tile1(7) = 2; tile2(7) = 6
5422 istart1(7) = 1; iend1(7) = ni(2); jstart1(7) = 1; jend1(7) = 1
5423 istart2(7) = ni(6); iend2(7) = ni(6); jstart2(7) = nj(6); jend2(7) = 1
5425 tile1(8) = 3; tile2(8) = 4
5426 istart1(8) = ni(3); iend1(8) = ni(3); jstart1(8) = 1; jend1(8) = nj(3)
5427 istart2(8) = 1; iend2(8) = 1; jstart2(8) = 1; jend2(8) = nj(4)
5429 tile1(9) = 3; tile2(9) = 5
5430 istart1(9) = 1; iend1(9) = ni(3); jstart1(9) = nj(3); jend1(9) = nj(3)
5431 istart2(9) = 1; iend2(9) = 1; jstart2(9) = nj(5); jend2(9) = 1
5433 tile1(10) = 4; tile2(10) = 5
5434 istart1(10) = 1; iend1(10) = ni(4); jstart1(10) = nj(4); jend1(10) = nj(4)
5435 istart2(10) = 1; iend2(10) = ni(5); jstart2(10) = 1; jend2(10) = 1
5437 tile1(11) = 4; tile2(11) = 6
5438 istart1(11) = ni(4); iend1(11) = ni(4); jstart1(11) = 1; jend1(11) = nj(4)
5439 istart2(11) = ni(6); iend2(11) = 1; jstart2(11) = 1; jend2(11) = 1
5441 tile1(12) = 5; tile2(12) = 6
5442 istart1(12) = ni(5); iend1(12) = ni(5); jstart1(12) = 1; jend1(12) = nj(5)
5443 istart2(12) = 1; iend2(12) = 1; jstart2(12) = 1; jend2(12) = nj(6)
5444 msize(1) = maxval(ni(:)/layout(1,:)) + whalo + ehalo + 1
5445 msize(2) = maxval(nj(:)/layout(2,:)) + shalo + nhalo + 1
5447 if(use_memsize_local)
then 5448 call mpp_define_mosaic(global_indices, layout, domain, ntiles, num_contact, tile1, tile2, &
5449 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
5450 pe_start, pe_end, symmetry = .true., whalo=whalo, ehalo=ehalo, &
5451 shalo=shalo, nhalo=nhalo, name = trim(type), memory_size = msize )
5453 call mpp_define_mosaic(global_indices, layout, domain, ntiles, num_contact, tile1, tile2, &
5454 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
5455 pe_start, pe_end, symmetry = .true., whalo=whalo, ehalo=ehalo, &
5456 shalo=shalo, nhalo=nhalo, name = trim(type) )
5464 subroutine fill_regular_refinement_halo( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, ioff, joff )
5465 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
5466 real,
dimension(:,:,:,:),
intent(in) :: data_all
5467 integer,
dimension(:),
intent(in) :: ni, nj
5468 integer,
intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne
5469 integer,
intent(in) :: ioff, joff
5472 if(te>0)
data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = &
5473 data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te)
5474 if(ts>0)
data (1:ni(tm)+ioff, 1-shalo:0, :) = &
5475 data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts)
5476 if(tw>0)
data (1-whalo:0, 1:nj(tm)+joff, :) = &
5477 data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw)
5478 if(tn>0)
data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = &
5479 data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn)
5480 if(tse>0)
data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = &
5481 data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse)
5482 if(tsw>0)
data (1-whalo:0, 1-shalo:0, :) = &
5483 data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw)
5484 if(tne>0)
data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = &
5485 data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw)
5486 if(tnw>0)
data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = &
5487 data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne)
5489 end subroutine fill_regular_refinement_halo
5494 subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, ioff, joff, sign1, sign2)
5495 real,
dimension(1-whalo:,1-shalo:,:),
intent(inout) :: data
5496 real,
dimension(:,:,:,:),
intent(in) :: data1_all, data2_all
5497 integer,
dimension(:),
intent(in) :: ni, nj
5498 integer,
intent(in) :: tile, ioff, joff, sign1, sign2
5499 integer :: lw, le, ls, ln
5501 if(mod(tile,2) == 0)
then 5502 lw = tile - 1; le = tile + 2; ls = tile - 2; ln = tile + 1
5503 if(le > 6 ) le = le - 6
5504 if(ls < 1 ) ls = ls + 6
5505 if(ln > 6 ) ln = ln - 6
5506 if( nj(tile) == nj(lw) )
then 5507 data(1-whalo:0, 1:nj(tile)+joff, :) = data1_all(ni(lw)-whalo+1:ni(lw), 1:nj(lw)+joff, :, lw)
5509 if( nj(tile) == ni(le) )
then 5511 data(ni(tile)+i+ioff, 1:nj(tile)+joff, :) = sign1*data2_all(ni(le)+joff:1:-1, i+ioff, :, le)
5514 if(ni(tile) == nj(ls) )
then 5516 data(1:ni(tile)+ioff, 1-i, :) = sign2*data2_all(ni(ls)-i+1, nj(ls)+ioff:1:-1, :, ls)
5519 if(ni(tile) == ni(ln) )
then 5520 data(1:ni(tile)+ioff, nj(tile)+1+joff:nj(tile)+nhalo+joff, :) = data1_all(1:ni(ln)+ioff, 1+joff:nhalo+joff, :, ln)
5523 lw = tile - 2; le = tile + 1; ls = tile - 1; ln = tile + 2
5524 if(lw < 1 ) lw = lw + 6
5525 if(ls < 1 ) ls = ls + 6
5526 if(ln > 6 ) ln = ln - 6
5527 if(nj(tile) == ni(lw) )
then 5529 data(1-i, 1:nj(tile)+joff, :) = sign1*data2_all(ni(lw)+joff:1:-1, nj(lw)-i+1, :, lw)
5532 if(nj(tile) == nj(le) )
then 5533 data(ni(tile)+1+ioff:ni(tile)+ehalo+ioff, 1:nj(tile)+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:nj(le)+joff, :, le)
5535 if(ni(tile) == ni(ls) )
then 5536 data(1:ni(tile)+ioff, 1-shalo:0, :) = data1_all(1:ni(ls)+ioff, nj(ls)-shalo+1:nj(ls), :, ls)
5538 if(ni(tile) == nj(ln) )
then 5540 data(1:ni(tile)+ioff, nj(tile)+i+joff, :) = sign2*data2_all(i+joff, nj(ln)+ioff:1:-1, :, ln)
5545 end subroutine fill_cubicgrid_refined_halo
5548 subroutine test_subset_update( )
5549 real,
allocatable,
dimension(:,:,:) :: x
5550 type(domain2D) :: domain
5551 real,
allocatable :: global(:,:,:)
5552 integer :: i, xhalo, yhalo
5553 integer :: is, ie, js, je, isd, ied, jsd, jed
5555 integer :: pes9(9)=(/0,2,4,10,12,14,20,22,24/)
5558 if(mpp_npes() < 25)
then 5559 call mpp_error(note,
"test_mpp_domains: test_subset_update will& 5560 & not be done when npes < 25")
5564 call mpp_declare_pelist(pes9)
5565 if(any(mpp_pe()==pes9))
then 5566 call mpp_set_current_pelist(pes9)
5570 &, yhalo=1, xflags=cyclic_global_domain, yflags&
5571 &=cyclic_global_domain, name=
'subset domain')
5573 print*,
"pe=", mpp_pe(), is, ie, js, je
5575 allocate(global(0:ni+1,0:nj+1,nz) )
5581 global(i,j,k) = k + i*1e-3 + j*1e-6
5586 global(0, 1:nj,:) = global(ni, 1:nj,:)
5587 global(ni+1, 1:nj,:) = global(1, 1:nj,:)
5588 global(0:ni+1, 0, :) = global(0:ni+1, nj, :)
5589 global(0:ni+1, nj+1,:) = global(0:ni+1, 1, :)
5594 allocate( x(isd:ied,jsd:jed,nz) )
5597 x(is:ie,js:je,:) = global(is:ie,js:je,:)
5603 deallocate(x, global)
5607 call mpp_set_current_pelist()
5609 end subroutine test_subset_update
5612 subroutine test_halo_update( type )
5613 character(len=*),
intent(in) :: type
5614 real,
allocatable,
dimension(:,:,:) :: x, x1, x2, x3, x4
5615 real,
allocatable,
dimension(:,:,:) :: y, y1, y2, y3, y4
5616 type(domain2D) :: domain
5617 real,
allocatable :: global1(:,:,:), global2(:,:,:), global(:,:,:)
5618 logical,
allocatable :: maskmap(:,:)
5619 integer :: shift, i, xhalo, yhalo
5620 logical :: is_symmetry, folded_south, folded_west, folded_east
5621 integer :: is, ie, js, je, isd, ied, jsd, jed
5624 if(
type ==
'Masked' .or. type ==
'Masked symmetry')
then 5625 if(mod(nx*ny, npes) .NE. 0 .OR. mod(nx*ny, npes+1) .NE. 0 )
then 5626 call mpp_error(note,
'TEST_MPP_DOMAINS: nx*ny can not be divided by both npes and npes+1, '//&
5627 'Masked test_halo_update will not be tested')
5632 if(
type ==
'Folded xy_halo' ) then
5633 xhalo =
max(whalo, ehalo); yhalo =
max(shalo, nhalo)
5634 allocate(global(1-xhalo:nx+xhalo,1-yhalo:ny+yhalo,nz) )
5636 allocate(global(1-whalo:nx+ehalo,1-shalo:ny+nhalo,nz) )
5643 global(i,j,k) = k + i*1e-3 + j*1e-6
5648 if(index(
type,
'symmetry') == 0) then
5649 is_symmetry = .false.
5651 is_symmetry = .true.
5654 case(
'Simple',
'Simple symmetry' )
5657 shalo=shalo, nhalo=nhalo, name=
type, symmetry = is_symmetry )
5658 case(
'Cyclic',
'Cyclic symmetry' )
5661 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=cyclic_global_domain, &
5662 name=
type, symmetry = is_symmetry )
5663 global(1-whalo:0, 1:ny,:) = global(nx-whalo+1:nx, 1:ny,:)
5664 global(nx+1:nx+ehalo, 1:ny,:) = global(1:ehalo, 1:ny,:)
5665 global(1-whalo:nx+ehalo, 1-shalo:0,:) = global(1-whalo:nx+ehalo, ny-shalo+1:ny,:)
5666 global(1-whalo:nx+ehalo, ny+1:ny+nhalo,:) = global(1-whalo:nx+ehalo, 1:nhalo,:)
5667 case(
'Folded-north',
'Folded-north symmetry' )
5670 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=fold_north_edge, &
5671 name=
type, symmetry = is_symmetry )
5672 call fill_folded_north_halo(global, 0, 0, 0, 0, 1)
5673 case(
'Folded-south symmetry' )
5676 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=fold_south_edge, &
5677 name=
type, symmetry = is_symmetry )
5678 call fill_folded_south_halo(global, 0, 0, 0, 0, 1)
5679 case(
'Folded-west symmetry' )
5682 shalo=shalo, nhalo=nhalo, xflags=fold_west_edge, yflags=cyclic_global_domain, &
5683 name=
type, symmetry = is_symmetry )
5684 call fill_folded_west_halo(global, 0, 0, 0, 0, 1)
5685 case(
'Folded-east symmetry' )
5688 shalo=shalo, nhalo=nhalo, xflags=fold_east_edge, yflags=cyclic_global_domain, &
5689 name=
type, symmetry = is_symmetry )
5690 call fill_folded_east_halo(global, 0, 0, 0, 0, 1)
5691 case(
'Folded xy_halo' )
5694 xflags=cyclic_global_domain, yflags=fold_north_edge, name=
type, symmetry = is_symmetry )
5695 global(1-xhalo:0, 1:ny,:) = global(nx-xhalo+1:nx, 1:ny,:)
5696 global(nx+1:nx+xhalo, 1:ny,:) = global(1:xhalo, 1:ny,:)
5697 global(1-xhalo:nx+xhalo,ny+1:ny+yhalo,:) = global(nx+xhalo:1-xhalo:-1, ny:ny-yhalo+1:-1,:)
5698 case(
'Masked',
'Masked symmetry' )
5701 allocate( maskmap(layout(1),layout(2)) )
5702 maskmap(:,:) = .true.; maskmap(layout(1),layout(2)) = .false.
5704 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=fold_north_edge, &
5705 maskmap=maskmap, name=
type, symmetry = is_symmetry )
5709 if( mod(nx,layout(1)).NE.0 .OR. mod(ny,layout(2)).NE.0 )
call mpp_error( fatal, &
5710 'TEST_MPP_DOMAINS: test for masked domains needs (nx,ny) to divide evenly on npes+1 PEs.' )
5711 global(nx-nx/layout(1)+1:nx,ny-ny/layout(2)+1:ny,:) = 0
5712 call fill_folded_north_halo(global, 0, 0, 0, 0, 1)
5714 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
5720 allocate( x(isd:ied,jsd:jed,nz) )
5721 allocate( x1(isd:ied,jsd:jed,nz) )
5722 allocate( x2(isd:ied,jsd:jed,nz) )
5723 allocate( x3(isd:ied,jsd:jed,nz) )
5724 allocate( x4(isd:ied,jsd:jed,nz) )
5726 x(is:ie,js:je,:) = global(is:ie,js:je,:)
5727 x1 = x; x2 = x; x3 = x; x4 = x
5730 id = mpp_clock_id(
type, flags=mpp_clock_sync+mpp_clock_detailed )
5731 call mpp_clock_begin(id)
5733 call mpp_clock_end (id)
5737 id = mpp_clock_id( type//
' partial', flags=mpp_clock_sync+mpp_clock_detailed )
5738 call mpp_clock_begin(id)
5743 call mpp_clock_end (id)
5744 call compare_checksums( x1(is:ied,js:jed,:), global(is:ied,js:jed,:), type//
' partial x1' )
5745 call compare_checksums( x2(is:ied,js:jed,:), global(is:ied,js:jed,:), type//
' partial x2' )
5746 call compare_checksums( x3(is:ied,js:jed,:), global(is:ied,js:jed,:), type//
' partial x3' )
5747 call compare_checksums( x4(is:ied,js:jed,:), global(is:ied,js:jed,:), type//
' partial x4' )
5750 if(
type ==
'Simple' .or. type ==
'Simple symmetry' .or.
type ==
'Cyclic' .or. type ==
'Cyclic symmetry')
then 5751 deallocate(x,x1,x2,x3,x4)
5759 if(is_symmetry)
then 5762 allocate(global(1-whalo:nx+ehalo+shift,1-shalo:ny+nhalo+shift,nz) )
5767 global(i,j,k) = k + i*1e-3 + j*1e-6
5771 if(
type ==
'Masked symmetry') then
5772 global(nx-nx/layout(1)+1:nx+1,ny-ny/layout(2)+1:ny+1,:) = 0
5774 deallocate(x, x1, x2, x3, x4)
5775 allocate( x(isd:ied+1,jsd:jed+1,nz) )
5776 allocate( x1(isd:ied+1,jsd:jed+1,nz) )
5777 allocate( x2(isd:ied+1,jsd:jed+1,nz) )
5778 allocate( x3(isd:ied+1,jsd:jed+1,nz) )
5779 allocate( x4(isd:ied+1,jsd:jed+1,nz) )
5782 folded_south = .false.
5783 folded_west = .false.
5784 folded_east = .false.
5786 case (
'Folded-north',
'Masked')
5788 call fill_folded_north_halo(global, 1, 1, 0, 0, -1)
5789 case (
'Folded xy_halo')
5791 global(1-xhalo:0, 1:ny,:) = global(nx-xhalo+1:nx, 1:ny,:)
5792 global(nx+1:nx+xhalo, 1:ny,:) = global(1:xhalo, 1:ny,:)
5793 global(1-xhalo:nx+xhalo-1,ny+1:ny+yhalo,:) = -global(nx+xhalo-1:1-xhalo:-1,ny-1:ny-yhalo:-1,:)
5794 global(nx+xhalo, ny+1:ny+yhalo,:) = -global(nx-xhalo, ny-1:ny-yhalo:-1,:)
5795 case (
'Folded-north symmetry',
'Masked symmetry' )
5796 call fill_folded_north_halo(global, 1, 1, 1, 1, -1)
5797 case (
'Folded-south symmetry' )
5798 folded_south = .true.
5799 call fill_folded_south_halo(global, 1, 1, 1, 1, -1)
5800 case (
'Folded-west symmetry' )
5801 folded_west = .true.
5802 call fill_folded_west_halo(global, 1, 1, 1, 1, -1)
5803 case (
'Folded-east symmetry' )
5804 folded_east = .true.
5805 call fill_folded_east_halo(global, 1, 1, 1, 1, -1)
5807 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
5811 x(is:ie+shift,js:je+shift,:) = global(is:ie+shift,js:je+shift,:)
5813 allocate( y(isd:ied+shift,jsd:jed+shift,nz) )
5814 allocate( y1(isd:ied+shift,jsd:jed+shift,nz) )
5815 allocate( y2(isd:ied+shift,jsd:jed+shift,nz) )
5816 allocate( y3(isd:ied+shift,jsd:jed+shift,nz) )
5817 allocate( y4(isd:ied+shift,jsd:jed+shift,nz) )
5818 y = x; x1 = x; x2 = x; x3 = x; x4 = x
5819 y = x; y1 = x; y2 = x; y3 = x; y4 = x
5821 id = mpp_clock_id( type//
' vector BGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
5822 call mpp_clock_begin(id)
5828 call mpp_clock_end (id)
5832 if(folded_south)
then 5833 global(nx/2+shift, 1,:) = 0.
5834 global(nx+shift , 1,:) = 0.
5835 global(nx/2+1+shift:nx-1+shift, 1,:) = -global(nx/2-1+shift:1+shift:-1, 1,:)
5836 global(1-whalo:shift, 1,:) = -global(nx-whalo+1:nx+shift, 1,:)
5837 global(nx+1+shift:nx+ehalo+shift, 1,:) = -global(1+shift:ehalo+shift, 1,:)
5839 if(shalo >0) global(shift,1,:) = 0.
5840 else if(folded_west)
then 5841 global(1, ny/2+shift, :) = 0.
5842 global(1, ny+shift, :) = 0.
5843 global(1, ny/2+1+shift:ny-1+shift, :) = -global(1, ny/2-1+shift:1+shift:-1, :)
5844 global(1, 1-shalo:shift, :) = -global(1, ny-shalo+1:ny+shift, :)
5845 global(1, ny+1+shift:ny+nhalo+shift, :) = -global(1, 1+shift:nhalo+shift, :)
5847 if(whalo>0) global(1, shift, :) = 0.
5848 else if(folded_east)
then 5849 global(nx+shift, ny/2+shift, :) = 0.
5850 global(nx+shift, ny+shift, :) = 0.
5851 global(nx+shift, ny/2+1+shift:ny-1+shift, :) = -global(nx+shift, ny/2-1+shift:1+shift:-1, :)
5852 global(nx+shift, 1-shalo:shift, :) = -global(nx+shift, ny-shalo+1:ny+shift, :)
5853 global(nx+shift, ny+1+shift:ny+nhalo+shift, :) = -global(nx+shift, 1+shift:nhalo+shift, :)
5854 if(ehalo >0) global(nx+shift, shift, :) = 0.
5856 global(nx/2+shift, ny+shift,:) = 0.
5857 global(nx+shift , ny+shift,:) = 0.
5858 global(nx/2+1+shift:nx-1+shift, ny+shift,:) = -global(nx/2-1+shift:1+shift:-1, ny+shift,:)
5859 if(
type ==
'Folded xy_halo') then
5860 global(1-xhalo:shift, ny+shift,:) = -global(nx-xhalo+1:nx+shift, ny+shift,:)
5861 global(nx+1+shift:nx+xhalo+shift, ny+shift,:) = -global(1+shift:xhalo+shift, ny+shift,:)
5863 global(1-whalo:shift, ny+shift,:) = -global(nx-whalo+1:nx+shift, ny+shift,:)
5864 global(nx+1+shift:nx+ehalo+shift, ny+shift,:) = -global(1+shift:ehalo+shift, ny+shift,:)
5867 if(nhalo >0) global(shift,ny+shift,:) = 0.
5870 call compare_checksums( x, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE X' )
5871 call compare_checksums( y, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE Y' )
5872 call compare_checksums( x1, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE X1' )
5873 call compare_checksums( x2, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE X2' )
5874 call compare_checksums( x3, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE X3' )
5875 call compare_checksums( x4, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE X4' )
5876 call compare_checksums( y1, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE Y1' )
5877 call compare_checksums( y2, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE Y2' )
5878 call compare_checksums( y3, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE Y3' )
5879 call compare_checksums( y4, global(isd:ied+shift,jsd:jed+shift,:), type//
' BGRID_NE Y4' )
5881 deallocate(global, x, x1, x2, x3, x4, y, y1, y2, y3, y4)
5887 if(
type ==
'Folded xy_halo') then
5888 allocate(global1(1-xhalo:nx+xhalo, 1-yhalo:ny+yhalo, nz))
5889 allocate(global2(1-xhalo:nx+xhalo, 1-yhalo:ny+yhalo, nz))
5891 allocate(global1(1-whalo:nx+ehalo+shift, 1-shalo:ny+nhalo, nz))
5892 allocate(global2(1-whalo:nx+ehalo, 1-shalo:ny+nhalo+shift, nz))
5894 allocate(x(isd:ied+shift,jsd:jed,nz), y(isd:ied,jsd:jed+shift,nz) )
5895 allocate(x1(isd:ied+shift,jsd:jed,nz), y1(isd:ied,jsd:jed+shift,nz) )
5896 allocate(x2(isd:ied+shift,jsd:jed,nz), y2(isd:ied,jsd:jed+shift,nz) )
5897 allocate(x3(isd:ied+shift,jsd:jed,nz), y3(isd:ied,jsd:jed+shift,nz) )
5898 allocate(x4(isd:ied+shift,jsd:jed,nz), y4(isd:ied,jsd:jed+shift,nz) )
5905 global1(i,j,k) = k + i*1e-3 + j*1e-6
5910 global2(i,j,k) = k + i*1e-3 + j*1e-6
5915 if(
type ==
'Masked' .or. type ==
'Masked symmetry')
then 5916 global1(nx-nx/layout(1)+1:nx+shift,ny-ny/layout(2)+1:ny,:) = 0
5917 global2(nx-nx/layout(1)+1:nx,ny-ny/layout(2)+1:ny+shift,:) = 0
5921 case (
'Folded-north',
'Masked')
5923 call fill_folded_north_halo(global1, 1, 0, 0, 0, -1)
5924 call fill_folded_north_halo(global2, 0, 1, 0, 0, -1)
5925 case (
'Folded xy_halo')
5926 global1(1-xhalo:0, 1:ny,:) = global1(nx-xhalo+1:nx, 1:ny,:)
5927 global1(nx+1:nx+xhalo, 1:ny,:) = global1(1:xhalo, 1:ny,:)
5928 global2(1-xhalo:0, 1:ny,:) = global2(nx-xhalo+1:nx, 1:ny,:)
5929 global2(nx+1:nx+xhalo, 1:ny,:) = global2(1:xhalo, 1:ny,:)
5930 global1(1-xhalo:nx+xhalo-1, ny+1:ny+yhalo,:) = -global1(nx+xhalo-1:1-xhalo:-1, ny:ny-yhalo+1:-1,:)
5931 global1(nx+xhalo, ny+1:ny+yhalo,:) = -global1(nx-xhalo, ny:ny-yhalo+1:-1,:)
5932 global2(1-xhalo:nx+xhalo, ny+1:ny+yhalo,:) = -global2(nx+xhalo:1-xhalo:-1, ny-1:ny-yhalo:-1,:)
5933 case (
'Folded-north symmetry')
5934 call fill_folded_north_halo(global1, 1, 0, 1, 0, -1)
5935 call fill_folded_north_halo(global2, 0, 1, 0, 1, -1)
5936 case (
'Folded-south symmetry')
5937 call fill_folded_south_halo(global1, 1, 0, 1, 0, -1)
5938 call fill_folded_south_halo(global2, 0, 1, 0, 1, -1)
5939 case (
'Folded-west symmetry')
5940 call fill_folded_west_halo(global1, 1, 0, 1, 0, -1)
5941 call fill_folded_west_halo(global2, 0, 1, 0, 1, -1)
5942 case (
'Folded-east symmetry')
5943 call fill_folded_east_halo(global1, 1, 0, 1, 0, -1)
5944 call fill_folded_east_halo(global2, 0, 1, 0, 1, -1)
5946 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
5950 x(is:ie+shift,js:je, :) = global1(is:ie+shift,js:je, :)
5951 y(is:ie ,js:je+shift,:) = global2(is:ie, js:je+shift,:)
5952 x1 = x; x2 = x; x3 = x; x4 = x
5953 y1 = y; y2 = y; y3 = y; y4 = y
5955 id = mpp_clock_id( type//
' vector CGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
5956 call mpp_clock_begin(id)
5962 call mpp_clock_end (id)
5965 if(folded_south)
then 5966 global2(nx/2+1:nx, 1,:) = -global2(nx/2:1:-1, 1,:)
5967 global2(1-whalo:0, 1,:) = -global2(nx-whalo+1:nx, 1, :)
5968 global2(nx+1:nx+ehalo, 1,:) = -global2(1:ehalo, 1, :)
5969 else if(folded_west)
then 5970 global1(1, ny/2+1:ny, :) = -global1(1, ny/2:1:-1, :)
5971 global1(1, 1-shalo:0, :) = -global1(1, ny-shalo+1:ny, :)
5972 global1(1, ny+1:ny+nhalo, :) = -global1(1, 1:nhalo, :)
5973 else if(folded_east)
then 5974 global1(nx+shift, ny/2+1:ny, :) = -global1(nx+shift, ny/2:1:-1, :)
5975 global1(nx+shift, 1-shalo:0, :) = -global1(nx+shift, ny-shalo+1:ny, :)
5976 global1(nx+shift, ny+1:ny+nhalo, :) = -global1(nx+shift, 1:nhalo, :)
5978 global2(nx/2+1:nx, ny+shift,:) = -global2(nx/2:1:-1, ny+shift,:)
5979 if(
type ==
'Folded xy_halo') then
5980 global2(1-xhalo:0, ny+shift,:) = -global2(nx-xhalo+1:nx, ny+shift,:)
5981 global2(nx+1:nx+xhalo, ny+shift,:) = -global2(1:xhalo, ny+shift,:)
5983 global2(1-whalo:0, ny+shift,:) = -global2(nx-whalo+1:nx, ny+shift,:)
5984 global2(nx+1:nx+ehalo, ny+shift,:) = -global2(1:ehalo, ny+shift,:)
5988 call compare_checksums( x, global1(isd:ied+shift,jsd:jed, :), type//
' CGRID_NE X' )
5989 call compare_checksums( y, global2(isd:ied, jsd:jed+shift,:), type//
' CGRID_NE Y' )
5990 call compare_checksums( x1, global1(isd:ied+shift,jsd:jed, :), type//
' CGRID_NE X1' )
5991 call compare_checksums( x2, global1(isd:ied+shift,jsd:jed, :), type//
' CGRID_NE X2' )
5992 call compare_checksums( x3, global1(isd:ied+shift,jsd:jed, :), type//
' CGRID_NE X3' )
5993 call compare_checksums( x4, global1(isd:ied+shift,jsd:jed, :), type//
' CGRID_NE X4' )
5994 call compare_checksums( y1, global2(isd:ied, jsd:jed+shift,:), type//
' CGRID_NE Y1' )
5995 call compare_checksums( y2, global2(isd:ied, jsd:jed+shift,:), type//
' CGRID_NE Y2' )
5996 call compare_checksums( y3, global2(isd:ied, jsd:jed+shift,:), type//
' CGRID_NE Y3' )
5997 call compare_checksums( y4, global2(isd:ied, jsd:jed+shift,:), type//
' CGRID_NE Y4' )
5999 deallocate(global1, global2, x, x1, x2, x3, x4, y, y1, y2, y3, y4)
6002 end subroutine test_halo_update
6004 subroutine set_corner_zero( data, isd, ied, jsd, jed, isc, iec, jsc, jec )
6005 integer,
intent(in) :: isd, ied, jsd, jed
6006 integer,
intent(in) :: isc, iec, jsc, jec
6007 real,
dimension(isd:,jsd:,:),
intent(inout) :: data
6009 data (isd :isc-1, jsd :jsc-1,:) = 0
6010 data (isd :isc-1, jec+1:jed, :) = 0
6011 data (iec+1:ied , jsd :jsc-1,:) = 0
6012 data (iec+1:ied , jec+1:jed, :) = 0
6015 end subroutine set_corner_zero
6018 subroutine test_update_edge( type )
6019 character(len=*),
intent(in) :: type
6020 real,
allocatable,
dimension(:,:,:) :: x, x2, a
6021 real,
allocatable,
dimension(:,:,:) :: y, y2, b
6022 type(domain2D) :: domain
6023 real,
allocatable :: global1(:,:,:), global2(:,:,:), global(:,:,:)
6024 logical,
allocatable :: maskmap(:,:)
6025 integer :: shift, i, xhalo, yhalo
6026 logical :: is_symmetry, folded_south, folded_west, folded_east
6027 integer :: is, ie, js, je, isd, ied, jsd, jed
6028 integer :: id_update
6030 allocate(global(1-whalo:nx+ehalo,1-shalo:ny+nhalo,nz) )
6036 global(i,j,k) = k + i*1e-3 + j*1e-6
6041 if(index(
type,
'symmetry') == 0) then
6042 is_symmetry = .false.
6044 is_symmetry = .true.
6050 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=cyclic_global_domain, &
6051 name=
type, symmetry = is_symmetry )
6052 global(1-whalo:0, 1:ny,:) = global(nx-whalo+1:nx, 1:ny,:)
6053 global(nx+1:nx+ehalo, 1:ny,:) = global(1:ehalo, 1:ny,:)
6054 global(1:nx, 1-shalo:0,:) = global(1:nx, ny-shalo+1:ny,:)
6055 global(1:nx, ny+1:ny+nhalo,:) = global(1:nx, 1:nhalo, :)
6056 case(
'Folded-north',
'Folded-north symmetry' )
6059 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=fold_north_edge, &
6060 name=
type, symmetry = is_symmetry )
6061 call fill_folded_north_halo(global, 0, 0, 0, 0, 1)
6063 call set_corner_zero(global, 1-whalo, nx+ehalo, 1-shalo, ny+ehalo, 1, nx, 1, ny)
6065 call mpp_error( fatal,
'test_update_edge: no such test: '//
type )
6071 allocate( x(isd:ied,jsd:jed,nz) )
6072 allocate( a(isd:ied,jsd:jed,nz) )
6073 allocate( x2(isd:ied,jsd:jed,nz) )
6074 x2(isd:ied,jsd:jed,:) = global(isd:ied,jsd:jed,:)
6075 call set_corner_zero(x2, isd, ied, jsd, jed, is, ie, js, je)
6078 x(is:ie,js:je,:) = global(is:ie,js:je,:)
6081 id = mpp_clock_id(
type, flags=mpp_clock_sync+mpp_clock_detailed )
6082 call mpp_clock_begin(id)
6084 call mpp_clock_end (id)
6089 a(is:ie,js:je,:) = global(is:ie,js:je,:)
6095 if(
type ==
'Cyclic' ) then
6096 deallocate(global, x, a)
6104 if(is_symmetry)
then 6107 allocate(global(1-whalo:nx+ehalo+shift,1-shalo:ny+nhalo+shift,nz) )
6112 global(i,j,k) = k + i*1e-3 + j*1e-6
6117 allocate( x(isd:ied+1,jsd:jed+1,nz) )
6118 allocate( a(isd:ied+1,jsd:jed+1,nz) )
6122 case (
'Folded-north')
6124 call fill_folded_north_halo(global, 1, 1, 0, 0, -1)
6125 case (
'Folded-north symmetry')
6126 call fill_folded_north_halo(global, 1, 1, 1, 1, -1)
6128 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
6133 x(is:ie+shift,js:je+shift,:) = global(is:ie+shift,js:je+shift,:)
6134 a(is:ie+shift,js:je+shift,:) = global(is:ie+shift,js:je+shift,:)
6136 allocate( y(isd:ied+shift,jsd:jed+shift,nz) )
6137 allocate( b(isd:ied+shift,jsd:jed+shift,nz) )
6140 id = mpp_clock_id( type//
' vector BGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
6141 call mpp_clock_begin(id)
6143 call mpp_clock_end (id)
6152 global(nx/2+shift, ny+shift,:) = 0.
6153 global(nx+shift , ny+shift,:) = 0.
6154 global(nx/2+1+shift:nx-1+shift, ny+shift,:) = -global(nx/2-1+shift:1+shift:-1, ny+shift,:)
6156 global(1-whalo:shift, ny+shift,:) = -global(nx-whalo+1:nx+shift, ny+shift,:)
6157 global(nx+1+shift:nx+ehalo+shift, ny+shift,:) = -global(1+shift:ehalo+shift, ny+shift,:)
6159 if(nhalo >0) global(shift,ny+shift,:) = 0.
6161 allocate( x2(isd:ied+shift,jsd:jed+shift,nz) )
6162 x2(isd:ied+shift,jsd:jed+shift,:) = global(isd:ied+shift,jsd:jed+shift,:)
6163 call set_corner_zero(x2, isd, ied+shift, jsd, jed+shift, is, ie+shift, js, je+shift)
6170 deallocate(global, x, y, x2, a, b)
6176 allocate(global1(1-whalo:nx+ehalo+shift, 1-shalo:ny+nhalo, nz))
6177 allocate(global2(1-whalo:nx+ehalo, 1-shalo:ny+nhalo+shift, nz))
6178 allocate(x(isd:ied+shift,jsd:jed,nz), y(isd:ied,jsd:jed+shift,nz) )
6179 allocate(x2(isd:ied+shift,jsd:jed,nz), y2(isd:ied,jsd:jed+shift,nz) )
6180 allocate(a(isd:ied+shift,jsd:jed,nz), b(isd:ied,jsd:jed+shift,nz) )
6187 global1(i,j,k) = k + i*1e-3 + j*1e-6
6192 global2(i,j,k) = k + i*1e-3 + j*1e-6
6198 case (
'Folded-north')
6200 call fill_folded_north_halo(global1, 1, 0, 0, 0, -1)
6201 call fill_folded_north_halo(global2, 0, 1, 0, 0, -1)
6203 global1(1-whalo:0, 1-shalo:0, :) = 0
6204 global1(1-whalo:0, ny+1:ny+nhalo, :) = 0
6205 global1(nx+1:nx+ehalo, 1-shalo:0, :) = 0
6206 global1(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = 0
6207 global2(1-whalo:0, 1-shalo:0, :) = 0
6208 global2(1-whalo:0, ny+1:ny+nhalo, :) = 0
6209 global2(nx+1:nx+ehalo, 1-shalo:0, :) = 0
6210 global2(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = 0
6211 case (
'Folded-north symmetry')
6212 call fill_folded_north_halo(global1, 1, 0, 1, 0, -1)
6213 call fill_folded_north_halo(global2, 0, 1, 0, 1, -1)
6215 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
6219 x(is:ie+shift,js:je, :) = global1(is:ie+shift,js:je, :)
6220 y(is:ie ,js:je+shift,:) = global2(is:ie, js:je+shift,:)
6222 a(is:ie+shift,js:je, :) = global1(is:ie+shift,js:je, :)
6223 b(is:ie ,js:je+shift,:) = global2(is:ie, js:je+shift,:)
6225 id = mpp_clock_id( type//
' vector CGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
6226 call mpp_clock_begin(id)
6228 call mpp_clock_end (id)
6235 global2(nx/2+1:nx, ny+shift,:) = -global2(nx/2:1:-1, ny+shift,:)
6236 global2(1-whalo:0, ny+shift,:) = -global2(nx-whalo+1:nx, ny+shift,:)
6237 global2(nx+1:nx+ehalo, ny+shift,:) = -global2(1:ehalo, ny+shift,:)
6239 x2(isd:ied+shift,jsd:jed,:) = global1(isd:ied+shift,jsd:jed,:)
6240 y2(isd:ied,jsd:jed+shift,:) = global2(isd:ied,jsd:jed+shift,:)
6241 call set_corner_zero(x2, isd, ied+shift, jsd, jed, is, ie+shift, js, je)
6242 call set_corner_zero(y2, isd, ied, jsd, jed+shift, is, ie, js, je+shift)
6249 deallocate(global1, global2, x, y, x2, y2, a, b)
6252 end subroutine test_update_edge
6256 subroutine test_update_nonsym_edge( type )
6257 character(len=*),
intent(in) :: type
6258 real,
allocatable,
dimension(:,:,:) :: x, x2
6259 real,
allocatable,
dimension(:,:,:) :: y, y2
6260 type(domain2D) :: domain
6261 real,
allocatable :: global1(:,:,:), global2(:,:,:)
6262 integer :: shift, i, xhalo, yhalo
6263 logical :: is_symmetry
6264 integer :: is, ie, js, je, isd, ied, jsd, jed
6265 type(mpp_group_update_type) :: group_update
6267 if(index(
type,
'symmetry') == 0) then
6269 is_symmetry = .false.
6272 is_symmetry = .true.
6275 case(
'Folded-north',
'Folded-north symmetry' )
6278 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=fold_north_edge, &
6279 name=
type, symmetry = is_symmetry )
6281 call mpp_error( fatal,
'test_update_edge: no such test: '//
type )
6291 allocate(global1(1-whalo:nx+ehalo+shift, 1-shalo:ny+nhalo, nz))
6292 allocate(global2(1-whalo:nx+ehalo, 1-shalo:ny+nhalo+shift, nz))
6293 allocate(x(isd:ied+shift,jsd:jed,nz), y(isd:ied,jsd:jed+shift,nz) )
6294 allocate(x2(isd:ied+shift,jsd:jed,nz), y2(isd:ied,jsd:jed+shift,nz) )
6301 global1(i,j,k) = k + i*1e-3 + j*1e-6
6306 global2(i,j,k) = k + i*1e-3 + j*1e-6
6312 case (
'Folded-north')
6314 call fill_folded_north_halo(global1, 1, 0, 0, 0, -1)
6315 call fill_folded_north_halo(global2, 0, 1, 0, 0, -1)
6317 global1(1-whalo:0, 1-shalo:0, :) = 0
6318 global1(1-whalo:0, ny+1:ny+nhalo, :) = 0
6319 global1(nx+1:nx+ehalo, 1-shalo:0, :) = 0
6320 global1(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = 0
6321 global2(1-whalo:0, 1-shalo:0, :) = 0
6322 global2(1-whalo:0, ny+1:ny+nhalo, :) = 0
6323 global2(nx+1:nx+ehalo, 1-shalo:0, :) = 0
6324 global2(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = 0
6325 case (
'Folded-north symmetry')
6326 call fill_folded_north_halo(global1, 1, 0, 1, 0, -1)
6327 call fill_folded_north_halo(global2, 0, 1, 0, 1, -1)
6329 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
6333 global2(nx/2+1:nx, ny+shift,:) = -global2(nx/2:1:-1, ny+shift,:)
6334 global2(1-whalo:0, ny+shift,:) = -global2(nx-whalo+1:nx, ny+shift,:)
6338 if(is_symmetry)
then 6339 x2(isd:ie+shift,jsd:je,:) = global1(isd:ie+shift,jsd:je,:)
6340 y2(isd:ie,jsd:je+shift,:) = global2(isd:ie,jsd:je+shift,:)
6342 x2(isd:ie+shift,js:je,:) = global1(isd:ie+shift,js:je,:)
6343 y2(is:ie,jsd:je+shift,:) = global2(is:ie,jsd:je+shift,:)
6347 x(is:ie+shift,js:je, :) = global1(is:ie+shift,js:je, :)
6348 y(is:ie ,js:je+shift,:) = global2(is:ie, js:je+shift,:)
6351 flags=wupdate+supdate+nonsymedgeupdate, whalo=1, ehalo=1, shalo=1, nhalo=1)
6360 x(is:ie+shift,js:je, :) = global1(is:ie+shift,js:je, :)
6361 y(is:ie ,js:je+shift,:) = global2(is:ie, js:je+shift,:)
6368 deallocate(global1, global2, x, y, x2, y2)
6369 call mpp_clear_group_update(group_update)
6371 end subroutine test_update_nonsym_edge
6375 subroutine test_cyclic_offset( type )
6376 character(len=*),
intent(in) :: type
6377 real,
allocatable,
dimension(:,:,:) :: x, x1, x2, x3, x4
6378 real,
allocatable,
dimension(:,:,:) :: y, y1, y2, y3, y4
6379 type(domain2D) :: domain
6380 real,
allocatable :: global1(:,:,:), global2(:,:,:), global(:,:,:)
6381 integer :: i, j, k, jj, ii
6382 integer :: is, ie, js, je, isd, ied, jsd, jed
6383 character(len=128) :: type2
6385 allocate(global(1-whalo:nx+ehalo,1-shalo:ny+nhalo,nz))
6391 global(i,j,k) = k + i*1e-3 + j*1e-6
6398 case(
'x_cyclic_offset' )
6399 write(type2, *)
type,
' x_cyclic=', x_cyclic_offset
6401 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, &
6402 name=
type, x_cyclic_offset = x_cyclic_offset)
6404 jj = mod(j + x_cyclic_offset + ny, ny)
6406 global(1-whalo:0,j,:) = global(nx-whalo+1:nx, jj,:)
6407 jj = mod(j - x_cyclic_offset + ny, ny)
6409 global(nx+1:nx+ehalo,j,:) = global(1:ehalo,jj,:)
6411 case(
'y_cyclic_offset' )
6412 write(type2, *)
type,
' y_cyclic = ', y_cyclic_offset
6414 shalo=shalo, nhalo=nhalo, yflags=cyclic_global_domain, &
6415 name=
type, y_cyclic_offset = y_cyclic_offset)
6417 ii = mod(i + y_cyclic_offset + nx, nx)
6419 global(i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:)
6420 ii = mod(i - y_cyclic_offset + nx, nx)
6422 global(i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)
6424 case(
'torus_x_offset' )
6425 write(type2, *)
type,
' x_cyclic = ', x_cyclic_offset
6427 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, &
6428 yflags=cyclic_global_domain, name=
type, &
6429 x_cyclic_offset = x_cyclic_offset)
6431 jj = mod(j + x_cyclic_offset + ny, ny)
6433 global(1-whalo:0,j,:) = global(nx-whalo+1:nx, jj,:)
6434 jj = mod(j - x_cyclic_offset + ny, ny)
6436 global(nx+1:nx+ehalo,j,:) = global(1:ehalo,jj,:)
6438 global(1:nx,1-shalo:0,:) = global(1:nx, ny-shalo+1:ny,:)
6439 global(1:nx,ny+1:ny+nhalo,:) = global(1:nx, 1:nhalo, :)
6442 jj = mod(ny-j+1 + x_cyclic_offset + ny, ny)
6444 global(1-whalo:0, 1-j,:) = global(nx-whalo+1:nx, jj, :)
6445 jj = mod(ny-j+1-x_cyclic_offset+ny,ny)
6447 global(nx+1:nx+ehalo, 1-j,:) = global(1:ehalo, jj, :)
6450 jj = mod(j + x_cyclic_offset + ny, ny)
6452 global(1-whalo:0, ny+j,:) = global(nx-whalo+1:nx, jj, :)
6453 jj = mod(j - x_cyclic_offset+ny,ny)
6455 global(nx+1:nx+ehalo, ny+j,:) = global(1:ehalo, jj, :)
6458 case(
'torus_y_offset' )
6459 write(type2, *)
type,
' y_cyclic = ', y_cyclic_offset
6461 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, &
6462 yflags=cyclic_global_domain, name=
type, &
6463 y_cyclic_offset = y_cyclic_offset)
6465 ii = mod(i + y_cyclic_offset + nx, nx)
6467 global(i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:)
6468 ii = mod(i - y_cyclic_offset + nx, nx)
6470 global(i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)
6472 global(1-whalo:0,1:ny,:) = global(nx-whalo+1:nx, 1:ny,:)
6473 global(nx+1:nx+ehalo,1:ny,:) = global(1:ehalo, 1:ny, :)
6475 ii = mod(nx-i+1 + y_cyclic_offset + nx, nx)
6477 global(1-i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:)
6478 ii = mod(nx-i+1 - y_cyclic_offset + nx, nx)
6480 global(1-i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)
6483 ii = mod(i + y_cyclic_offset + nx, nx)
6485 global(nx+i, 1-shalo:0,:) = global(ii, ny-shalo+1:ny,:)
6486 ii = mod(i - y_cyclic_offset + nx, nx)
6488 global(nx+i,ny+1:ny+nhalo,:) = global(ii,1:nhalo,:)
6491 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
6497 allocate( x(isd:ied,jsd:jed,nz) )
6498 allocate( x1(isd:ied,jsd:jed,nz) )
6499 allocate( x2(isd:ied,jsd:jed,nz) )
6500 allocate( x3(isd:ied,jsd:jed,nz) )
6501 allocate( x4(isd:ied,jsd:jed,nz) )
6503 x(is:ie,js:je,:) = global(is:ie,js:je,:)
6504 x1 = x; x2 = x; x3 = x; x4 = x
6507 id = mpp_clock_id(
type, flags=mpp_clock_sync+mpp_clock_detailed )
6508 call mpp_clock_begin(id)
6510 call mpp_clock_end (id)
6514 id = mpp_clock_id( type//
' partial', flags=mpp_clock_sync+mpp_clock_detailed )
6515 call mpp_clock_begin(id)
6520 call mpp_clock_end (id)
6521 call compare_checksums( x1(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//
' partial x1' )
6522 call compare_checksums( x2(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//
' partial x2' )
6523 call compare_checksums( x3(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//
' partial x3' )
6524 call compare_checksums( x4(is:ied,js:jed,:), global(is:ied,js:jed,:), trim(type2)//
' partial x4' )
6527 deallocate(x,x1,x2,x3,x4)
6534 allocate(global1(1-whalo:nx+ehalo, 1-shalo:ny+nhalo, nz))
6535 allocate(global2(1-whalo:nx+ehalo, 1-shalo:ny+nhalo, nz))
6536 allocate(x(isd:ied,jsd:jed,nz), y(isd:ied,jsd:jed,nz) )
6537 allocate(x1(isd:ied,jsd:jed,nz), y1(isd:ied,jsd:jed,nz) )
6538 allocate(x2(isd:ied,jsd:jed,nz), y2(isd:ied,jsd:jed,nz) )
6539 allocate(x3(isd:ied,jsd:jed,nz), y3(isd:ied,jsd:jed,nz) )
6540 allocate(x4(isd:ied,jsd:jed,nz), y4(isd:ied,jsd:jed,nz) )
6542 global1 = 1000 + global
6543 global2 = 2000 + global
6549 x(is:ie,js:je,:) = global1(is:ie,js:je,:)
6550 y(is:ie,js:je,:) = global2(is:ie,js:je,:)
6551 x1 = x; x2 = x; x3 = x; x4 = x
6552 y1 = y; y2 = y; y3 = y; y4 = y
6554 id = mpp_clock_id( type//
' vector BGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
6555 call mpp_clock_begin(id)
6561 call mpp_clock_end (id)
6565 call compare_checksums( x, global1(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE X' )
6566 call compare_checksums( y, global2(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE Y' )
6567 call compare_checksums( x1, global1(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE X1' )
6568 call compare_checksums( x2, global1(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE X2' )
6569 call compare_checksums( x3, global1(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE X3' )
6570 call compare_checksums( x4, global1(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE X4' )
6571 call compare_checksums( y1, global2(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE Y1' )
6572 call compare_checksums( y2, global2(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE Y2' )
6573 call compare_checksums( y3, global2(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE Y3' )
6574 call compare_checksums( y4, global2(isd:ied,jsd:jed,:), trim(type2)//
' BGRID_NE Y4' )
6581 x(is:ie,js:je,:) = global1(is:ie,js:je,:)
6582 y(is:ie,js:je,:) = global2(is:ie,js:je,:)
6583 x1 = x; x2 = x; x3 = x; x4 = x
6584 y1 = y; y2 = y; y3 = y; y4 = y
6586 id = mpp_clock_id( type//
' vector CGRID_NE', flags=mpp_clock_sync+mpp_clock_detailed )
6587 call mpp_clock_begin(id)
6593 call mpp_clock_end (id)
6595 call compare_checksums( x, global1(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE X' )
6596 call compare_checksums( y, global2(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE Y' )
6597 call compare_checksums( x1, global1(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE X1' )
6598 call compare_checksums( x2, global1(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE X2' )
6599 call compare_checksums( x3, global1(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE X3' )
6600 call compare_checksums( x4, global1(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE X4' )
6601 call compare_checksums( y1, global2(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE Y1' )
6602 call compare_checksums( y2, global2(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE Y2' )
6603 call compare_checksums( y3, global2(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE Y3' )
6604 call compare_checksums( y4, global2(isd:ied,jsd:jed,:), trim(type2)//
' CGRID_NE Y4' )
6606 deallocate(global1, global2, x, x1, x2, x3, x4, y, y1, y2, y3, y4)
6609 end subroutine test_cyclic_offset
6612 subroutine test_global_field( type )
6613 character(len=*),
intent(in) :: type
6614 real,
allocatable,
dimension(:,:,:) :: x, gcheck
6615 type(domain2D) :: domain
6616 real,
allocatable :: global1(:,:,:)
6617 integer :: ishift, jshift, ni, nj, i, j, position
6618 integer,
allocatable :: pelist(:)
6619 integer :: is, ie, js, je, isd, ied, jsd, jed
6624 case(
'Non-symmetry' )
6626 shalo=shalo, nhalo=nhalo, name=
type )
6627 case(
'Symmetry center',
'Symmetry corner',
'Symmetry east',
'Symmetry north' )
6629 shalo=shalo, nhalo=nhalo, name=
type, symmetry = .true. )
6631 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//type//
' in test_global_field' )
6637 ishift = 0; jshift = 0
6640 case (
'Symmetry corner')
6641 ishift = 1; jshift = 1; position=corner
6642 case (
'Symmetry east')
6643 ishift = 1; jshift = 0; position=east
6644 case (
'Symmetry north')
6645 ishift = 0; jshift = 1; position=north
6648 ie = ie+ishift; je = je+jshift
6649 ied = ied+ishift; jed = jed+jshift
6650 ni = nx+ishift; nj = ny+jshift
6651 allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz))
6656 global1(i,j,k) = k + i*1e-3 + j*1e-6
6661 allocate( gcheck(ni, nj, nz) )
6662 allocate( x(isd:ied,jsd:jed,nz) )
6664 x(:,:,:) = global1(isd:ied,jsd:jed,:)
6668 id = mpp_clock_id( type//
' global field on data domain', flags=mpp_clock_sync+mpp_clock_detailed )
6669 call mpp_clock_begin(id)
6671 call mpp_clock_end (id)
6673 call compare_checksums( global1(1:ni,1:nj,:), gcheck, type//
' mpp_global_field on data domain' )
6683 allocate(pelist(0:layout(1)-1))
6684 do j = 0, layout(2)-1
6685 do i = 0, layout(1)-1
6686 pelist(i) = j*layout(1) + i
6688 call mpp_declare_pelist(pelist)
6694 call mpp_clock_begin(id)
6695 call mpp_global_field( domain, x, gcheck, flags = xupdate, position=position )
6696 call mpp_clock_end (id)
6699 type//
' mpp_global_field xupdate only on data domain' )
6703 call mpp_clock_begin(id)
6704 call mpp_global_field( domain, x, gcheck, flags = yupdate, position=position )
6705 call mpp_clock_end (id)
6708 type//
' mpp_global_field yupdate only on data domain' )
6710 call mpp_clock_begin(id)
6713 call mpp_clock_end (id)
6716 type//
' mpp_global_field on data domain' )
6720 id = mpp_clock_id( type//
' global field on compute domain', flags=mpp_clock_sync+mpp_clock_detailed )
6721 call mpp_clock_begin(id)
6722 call mpp_global_field( domain, x(is:ie, js:je, :), gcheck, position=position )
6723 call mpp_clock_end (id)
6725 call compare_checksums( global1(1:ni,1:nj,:), gcheck, type//
' mpp_global_field on compute domain' )
6729 call mpp_clock_begin(id)
6730 call mpp_global_field( domain, x(is:ie, js:je,:), gcheck, flags = xupdate, position=position )
6731 call mpp_clock_end (id)
6734 type//
' mpp_global_field xupdate only on compute domain' )
6738 call mpp_clock_begin(id)
6739 call mpp_global_field( domain, x(is:ie, js:je,:), gcheck, flags = yupdate, position=position )
6740 call mpp_clock_end (id)
6743 type//
' mpp_global_field yupdate only on compute domain' )
6746 deallocate(global1, gcheck, x)
6748 end subroutine test_global_field
6751 subroutine test_global_reduce (type)
6752 character(len=*),
intent(in) :: type
6753 real :: lsum, gsum, lmax, gmax, lmin, gmin
6754 integer :: ni, nj, ishift, jshift, position
6755 integer :: is, ie, js, je, isd, ied, jsd, jed
6757 type(domain2D) :: domain
6758 real,
allocatable,
dimension(:,:,:) :: global1, x
6759 real,
allocatable,
dimension(:,:) :: global2D
6765 shalo=shalo, nhalo=nhalo, name=
type )
6766 case(
'Simple symmetry center',
'Simple symmetry corner',
'Simple symmetry east',
'Simple symmetry north' )
6768 shalo=shalo, nhalo=nhalo, name=
type, symmetry = .true. )
6769 case(
'Cyclic symmetry center',
'Cyclic symmetry corner',
'Cyclic symmetry east',
'Cyclic symmetry north' )
6770 call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
6771 name=
type, symmetry = .true., xflags=cyclic_global_domain, yflags=cyclic_global_domain )
6773 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//type//
' in test_global_field' )
6779 ishift = 0; jshift = 0; position = center
6781 case (
'Simple symmetry corner',
'Cyclic symmetry corner')
6782 ishift = 1; jshift = 1; position = corner
6783 case (
'Simple symmetry east',
'Cyclic symmetry east' )
6784 ishift = 1; jshift = 0; position = east
6785 case (
'Simple symmetry north',
'Cyclic symmetry north')
6786 ishift = 0; jshift = 1; position = north
6789 ie = ie+ishift; je = je+jshift
6790 ied = ied+ishift; jed = jed+jshift
6791 ni = nx+ishift; nj = ny+jshift
6792 allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz))
6797 global1(i,j,k) = k + i*1e-3 + j*1e-6
6804 allocate( x(isd:ied,jsd:jed,nz) )
6805 allocate( global2d(ni,nj))
6807 x(:,:,:) = global1(isd:ied,jsd:jed,:)
6810 global2d(i,j) = sum(global1(i,j,:))
6815 if(
type(1:6) ==
'Simple') then
6816 gsum = sum( global2d(1:ni,1:nj) )
6818 gsum = sum( global2d(1:nx, 1:ny) )
6820 id = mpp_clock_id( type//
' sum', flags=mpp_clock_sync+mpp_clock_detailed )
6821 call mpp_clock_begin(id)
6823 call mpp_clock_end (id)
6824 if( pe.EQ.mpp_root_pe() )print
'(a,2es15.8,a,es12.4)', type//
' Fast sum=', lsum, gsum
6827 id = mpp_clock_id( type//
' exact sum', flags=mpp_clock_sync+mpp_clock_detailed )
6828 call mpp_clock_begin(id)
6829 lsum =
mpp_global_sum( domain, x, bitwise_exact_sum, position = position )
6830 call mpp_clock_end (id)
6833 call compare_data_scalar(lsum, gsum, fatal, type//
' mpp_global_exact_sum')
6836 gmin = minval(global1(1:ni, 1:nj, :))
6837 id = mpp_clock_id( type//
' min', flags=mpp_clock_sync+mpp_clock_detailed )
6838 call mpp_clock_begin(id)
6840 call mpp_clock_end (id)
6841 call compare_data_scalar(lmin, gmin, fatal, type//
' mpp_global_min')
6844 gmax = maxval(global1(1:ni, 1:nj, :))
6845 id = mpp_clock_id( type//
' max', flags=mpp_clock_sync+mpp_clock_detailed )
6846 call mpp_clock_begin(id)
6848 call mpp_clock_end (id)
6849 call compare_data_scalar(lmax, gmax, fatal, type//
' mpp_global_max' )
6851 deallocate(global1, x)
6853 end subroutine test_global_reduce
6856 subroutine test_parallel ( )
6858 integer :: npes, layout(2), i, j, k,is, ie, js, je, isd, ied, jsd, jed
6859 real,
dimension(:,:),
allocatable :: field, lfield
6860 real,
dimension(:,:,:),
allocatable :: field3d, lfield3d
6861 type(domain2d) :: domain
6862 integer,
dimension(:),
allocatable :: pelist1 , pelist2
6863 logical :: group1, group2
6864 character(len=128) :: mesg
6867 allocate(pelist1(npes-mpes), pelist2(mpes))
6868 pelist1 = (/(i, i = 0, npes-mpes -1)/)
6869 pelist2 = (/(i, i = npes-mpes, npes - 1)/)
6870 call mpp_declare_pelist(pelist1)
6871 call mpp_declare_pelist(pelist2)
6872 group1 = .false. ; group2 = .false.
6873 if(any(pelist1==pe)) group1 = .true.
6874 if(any(pelist2==pe)) group2 = .true.
6875 mesg =
'parallel checking' 6878 call mpp_set_current_pelist(pelist1)
6880 else if(group2)
then 6881 call mpp_set_current_pelist(pelist2)
6884 call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
6886 call mpp_set_current_pelist()
6890 allocate(lfield(is:ie,js:je),field(isd:ied,jsd:jed))
6891 allocate(lfield3d(is:ie,js:je,nz),field3d(isd:ied,jsd:jed,nz))
6895 lfield(i,j) =
real(i)+
real(j)*0.001
6901 lfield3d(i,j,k) =
real(i)+
real(j)*0.001+
real(k)*0.00001
6907 field(is:ie,js:je)= lfield(is:ie,js:je)
6908 field3d(is:ie,js:je,:) = lfield3d(is:ie,js:je,:)
6912 call mpp_check_field(field, pelist1, pelist2,domain,
'2D '//mesg, w_halo = whalo, &
6913 s_halo = shalo, e_halo = ehalo, n_halo = nhalo)
6914 call mpp_check_field(field3d, pelist1, pelist2,domain,
'3D '//mesg, w_halo = whalo, &
6915 s_halo = shalo, e_halo = ehalo, n_halo = nhalo)
6917 end subroutine test_parallel
6919 subroutine test_modify_domain( )
6921 type(domain2D) :: domain2d_no_halo, domain2d_with_halo
6922 integer :: is1, ie1, js1, je1, isd1, ied1, jsd1, jed1
6923 integer :: is2, ie2, js2, je2, isd2, ied2, jsd2, jed2
6927 yflags=cyclic_global_domain, xhalo=0, yhalo=0)
6931 call mpp_modify_domain(domain2d_no_halo, domain2d_with_halo, whalo=whalo,ehalo=ehalo,shalo=shalo,nhalo=nhalo)
6934 if( is1 .NE. is2 .OR. ie1 .NE. ie2 .OR. js1 .NE. js2 .OR. je1 .NE. je2 )
then 6935 print*,
"at pe ", pe,
" compute domain without halo: ", is1, ie1, js1, je1, &
6936 " is not equal to the domain with halo ", is2, ie2, js2, je2
6937 call mpp_error(fatal,
"compute domain mismatch between domain without halo and domain with halo")
6940 if( isd1-whalo .NE. isd2 .OR. ied1+ehalo .NE. ied2 .OR. jsd1-shalo .NE. jsd2 .OR. jed1+nhalo .NE. jed2 )
then 6941 print*,
"at pe ", pe,
"halo is w=",whalo,
",e=",ehalo,
",s=",shalo,
"n=",nhalo, &
6942 ",data domain without halo is ",isd1, ied1, jsd1, jed1, &
6943 ", data domain with halo is ", isd2, ied2, jsd2, jed2
6945 if( pe.EQ.mpp_root_pe() )
call mpp_error( note,
'test_modify_domain: OK.' )
6950 end subroutine test_modify_domain
6953 real,
intent(in),
dimension(:,:,:) :: a, b
6954 character(len=*),
intent(in) :: string
6955 integer(LONG_KIND) :: sum1, sum2
6960 call mpp_sync_self()
6962 if(
size(a,1) .ne.
size(b,1) .or.
size(a,2) .ne.
size(b,2) .or.
size(a,3) .ne.
size(b,3) ) &
6963 call mpp_error(fatal,
'compare_chksum: size of a and b does not match')
6968 if(a(i,j,k) .ne. b(i,j,k))
then 6969 write(stdunit,
'(a,i3,a,i3,a,i3,a,i3,a,f20.9,a,f20.9)')
" at pe ", mpp_pe(), &
6970 ", at point (",i,
", ", j,
", ", k,
"), a = ", a(i,j,k),
", b = ", b(i,j,k)
6971 call mpp_error(fatal, trim(
string)//
': point by point comparison are not OK.')
6980 if( sum1.EQ.sum2 )
then 6981 if( pe.EQ.mpp_root_pe() )
call mpp_error( note, trim(
string)//
': OK.' )
6992 real,
intent(in),
dimension(:,:) :: a, b
6993 character(len=*),
intent(in) :: string
6994 integer(LONG_KIND) :: sum1, sum2
6999 call mpp_sync_self()
7001 if(
size(a,1) .ne.
size(b,1) .or.
size(a,2) .ne.
size(b,2) ) &
7002 call mpp_error(fatal,
'compare_chksum_2D: size of a and b does not match')
7006 if(a(i,j) .ne. b(i,j))
then 7007 print*,
"a =", a(i,j)
7008 print*,
"b =", b(i,j)
7009 write(stdunit,
'(a,i3,a,i3,a,i3,a,f20.9,a,f20.9)')
"at pe ", mpp_pe(), &
7010 ", at point (",i,
", ", j,
"),a=", a(i,j),
",b=", b(i,j)
7011 call mpp_error(fatal, trim(
string)//
': point by point comparison are not OK.')
7019 if( sum1.EQ.sum2 )
then 7020 if( pe.EQ.mpp_root_pe() )
call mpp_error( note, trim(
string)//
': OK.' )
7032 subroutine compare_data_scalar( a, b, action, string )
7033 real,
intent(in) :: a, b
7034 integer,
intent(in) :: action
7035 character(len=*),
intent(in) :: string
7037 if( pe.EQ.mpp_root_pe() )
call mpp_error( note, trim(
string)//
': data comparison are OK.' )
7039 write(stdunit,
'(a,i3,a,es12.4,a,es12.4,a,es12.4)')
' on pe ', mpp_pe(),
' a = ', a,
', b = ', b,
', a - b =', a-b
7040 call mpp_error( action, trim(
string)//
': data comparison are not OK.' )
7043 end subroutine compare_data_scalar
7045 subroutine test_get_neighbor_1d
7046 type(domain1d) :: dmn1d
7047 integer npes, peN, peS
7052 print
'(a,i2,a,2i3)',
'PE: ', mpp_pe(),
' R/L pes: ', pen, pes
7053 end subroutine test_get_neighbor_1d
7055 subroutine test_get_neighbor_non_cyclic
7056 type(domain2d) :: domain
7057 integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
7062 if( npes .NE. 8 )
then 7063 call mpp_error(note,
'test_mpp_domains: test_get_neighbor_non_cyclic '// &
7064 ' will be performed only when npes = 8')
7077 print
'(a,i2,a,2i2,a,8i3)',
'PE: ', mpp_pe(),
' layout (non-cyclic): ', layout, &
7078 &
' N/S/E/W/NE/SE/SW/NW pes: ', pen, pes, pee, pew, pene, pese, pesw, penw
7079 end subroutine test_get_neighbor_non_cyclic
7081 subroutine test_get_neighbor_cyclic
7082 type(domain2d) :: domain
7083 integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
7088 if( npes .NE. 8 )
then 7089 call mpp_error(note,
'test_mpp_domains: test_get_neighbor_cyclic '// &
7090 ' will be performed only when npes = 8')
7095 xflags=cyclic_global_domain, yflags=cyclic_global_domain)
7104 print
'(a,i2,a,2i2,a,8i3)',
'PE: ', mpp_pe(),
' layout (cyclic) : ', layout, &
7105 &
' N/S/E/W/NE/SE/SW/NW pes: ', pen, pes, pee, pew, pene, pese, pesw, penw
7106 end subroutine test_get_neighbor_cyclic
7108 subroutine test_get_neighbor_folded_north
7109 type(domain2d) :: domain
7110 integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
7115 if( npes .NE. 8 )
then 7116 call mpp_error(note,
'test_mpp_domains: test_get_neighbor_folded_north '// &
7117 ' will be performed only when npes = 8')
7122 xflags=cyclic_global_domain, yflags=fold_north_edge)
7131 print
'(a,i2,a,2i2,a,8i3)',
'PE: ', mpp_pe(),
' layout (folded N) : ', layout, &
7132 &
' N/S/E/W/NE/SE/SW/NW pes: ', pen, pes, pee, pew, pene, pese, pesw, penw
7133 end subroutine test_get_neighbor_folded_north
7135 subroutine test_get_neighbor_mask
7136 logical,
allocatable :: mask(:,:)
7137 integer :: im, jm, n_remove
7138 type(domain2d) :: domain
7139 integer nx, ny,layout(2), halo, peN, peS, peE, peW, peNE, peNW, peSE, peSW, npes
7146 if( npes .NE. 8 )
then 7147 call mpp_error(note,
'test_mpp_domains: test_get_neighbor_mask '// &
7148 ' will be performed only when npes = 8')
7152 allocate(mask(layout(1), layout(2)))
7154 im =
min(layout(1), ceiling(layout(1)/2.0))
7155 jm =
min(layout(2), ceiling(layout(2)/2.0))
7156 mask(im ,jm ) = .false.
7157 mask(im ,jm-1) = .false.
7158 print
'(a,2i3,a,2i3)',
'Masked out domains ', im, jm,
' and ', im,jm-1
7169 print
'(a,i3,a,2i3,a,8i3)',
'PE: ', mpp_pe(),
' layout (mask ) : ', layout, &
7170 &
' N/S/E/W/NE/SE/SW/NW pes: ', pen, pes, pee, pew, pene, pese, pesw, penw
7171 end subroutine test_get_neighbor_mask
7173 subroutine test_define_mosaic_pelist(type, ntile)
7174 character(len=*),
intent(in) :: type
7175 integer,
intent(in) :: ntile
7176 integer :: npes, root_pe, start_pe, n, ntile_per_pe
7177 integer,
dimension(:),
allocatable :: pe1_start, pe1_end, pe2_start, pe2_end
7178 integer,
dimension(:),
allocatable :: sizes, costpertile
7180 root_pe = mpp_root_pe()
7183 allocate(sizes(ntile), pe1_start(ntile), pe1_end(ntile), pe2_start(ntile), pe2_end(ntile),costpertile(ntile) )
7187 pe1_start = root_pe; pe1_end = root_pe
7191 pe1_start = root_pe; pe1_end = npes+root_pe-1
7192 case(
'Two uniform tile')
7193 if(mod(npes,2) .NE. 0 .AND. npes .NE. 1)
then 7194 call mpp_error(note,
'test_define_mosaic_pelist: npes can not be divided by 2, no test for '//
type )
7197 if(npes .NE. 1)
then 7198 pe1_start(1) = root_pe; pe1_end(1) = npes/2+root_pe-1
7199 pe1_start(2) = npes/2+root_pe; pe1_end(2) = npes+root_pe-1
7201 case(
'Two nonuniform tile')
7202 if(mod(npes,3) .NE. 0 .AND. npes .NE. 1)
then 7203 call mpp_error(note,
'test_define_mosaic_pelist: npes can not be divided by 3, no test for '//
type )
7207 if(npes .NE. 1)
then 7208 pe1_start(1) = root_pe; pe1_end(1) = npes/3*2+root_pe-1
7209 pe1_start(2) = npes/3*2+root_pe; pe1_end(2) = npes+root_pe-1
7212 if(mod(npes,10) .NE. 0 .AND. npes .NE. 1 .AND. mod(10,npes) .NE. 0)
then 7213 call mpp_error(note,
'test_define_mosaic_pelist: npes can not be divided by 10(or reverse), no test for '//
type )
7216 if(mod(10, npes)==0)
then 7217 ntile_per_pe = ntile/npes
7219 pe1_start(n) = root_pe+(n-1)/ntile_per_pe; pe1_end(n) = pe1_start(n)
7221 else if(mod(npes,10) == 0)
then 7223 pe1_start(n) = npes/10*(n-1)+root_pe; pe1_end(n) = npes/10*n+root_pe-1
7226 case(
'Ten tile with nonuniform cost')
7227 if(mod(npes,15) .NE. 0 .AND. npes .NE. 1)
then 7228 call mpp_error(note,
'test_define_mosaic_pelist: npes can not be divided by 15, no test for '//
type )
7231 costpertile(1:5) = 2; costpertile(6:ntile) = 1
7232 if(npes .NE. 1)
then 7235 pe1_start(n) = start_pe
7236 pe1_end(n) = start_pe + npes/15*costpertile(n)-1
7237 start_pe = pe1_end(n) + 1
7241 call mpp_error(fatal,
"test_define_mosaic_pelist: "//type//
" is an invalid type")
7244 call mpp_define_mosaic_pelist( sizes, pe2_start, pe2_end, costpertile=costpertile)
7245 if( any(pe1_start .NE. pe2_start) .OR. any(pe1_end .NE. pe2_end) )
then 7246 call mpp_error(fatal,
"test_define_mosaic_pelist: test failed for "//trim(type) )
7248 call mpp_error(note,
"test_define_mosaic_pelist: test successful for "//trim(type) )
7251 end subroutine test_define_mosaic_pelist
7254 subroutine test_update_nest_domain( type )
7255 character(len=*),
intent(in) :: type
7256 logical :: cubic_grid, concurrent
7257 logical :: is_fine_pe, is_coarse_pe
7258 integer :: n, i, j, k, l
7259 integer :: ntiles, num_contact, npes_per_tile
7260 integer :: isc_coarse, iec_coarse, jsc_coarse, jec_coarse
7261 integer :: isd_coarse, ied_coarse, jsd_coarse, jed_coarse
7262 integer :: isd_fine, ied_fine, jsd_fine, jed_fine
7263 integer :: isc_fine, iec_fine, jsc_fine, jec_fine
7264 integer :: x_refine, y_refine, nx_coarse, ny_coarse
7265 integer :: nxc_fine, nyc_fine, nxc_coarse, nyc_coarse
7266 integer :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c
7267 integer :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c
7268 integer :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c
7269 integer :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c
7270 integer :: isw_f2, iew_f2, jsw_f2, jew_f2, isw_c2, iew_c2, jsw_c2, jew_c2, tile_w2
7271 integer :: ise_f2, iee_f2, jse_f2, jee_f2, ise_c2, iee_c2, jse_c2, jee_c2, tile_e2
7272 integer :: iss_f2, ies_f2, jss_f2, jes_f2, iss_c2, ies_c2, jss_c2, jes_c2, tile_s2
7273 integer :: isn_f2, ien_f2, jsn_f2, jen_f2, isn_c2, ien_c2, jsn_c2, jen_c2, tile_n2
7274 integer :: is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f
7275 integer :: is_c2, ie_c2, js_c2, je_c2, is_f2, ie_f2, js_f2, je_f2
7276 integer :: nx_fine, ny_fine, tile, position, ishift, jshift
7277 integer :: layout_fine(2)
7278 integer,
allocatable :: pelist(:)
7279 integer,
allocatable :: pelist_coarse(:)
7280 integer,
allocatable :: pelist_fine(:)
7281 integer,
allocatable :: pe_start(:), pe_end(:)
7282 integer,
allocatable :: layout2D(:,:), global_indices(:,:)
7283 real,
allocatable :: x(:,:,:)
7284 real,
allocatable :: wbuffer(:,:,:), wbuffer2(:,:,:)
7285 real,
allocatable :: ebuffer(:,:,:), ebuffer2(:,:,:)
7286 real,
allocatable :: sbuffer(:,:,:), sbuffer2(:,:,:)
7287 real,
allocatable :: nbuffer(:,:,:), nbuffer2(:,:,:)
7288 real,
allocatable :: buffer(:,:,:), buffer2(:,:,:)
7289 character(len=32) :: position_name
7290 type(domain2d) :: domain_coarse, domain_fine
7291 type(nest_domain_type) :: nest_domain
7294 case (
'Cubic-Grid' )
7295 if( nx_cubic == 0 )
then 7296 call mpp_error(note,
'test_update_nest_domain: for Cubic_grid mosaic, nx_cubic is zero, '//&
7297 'No test is done for Cubic-Grid mosaic. ' )
7300 if( nx_cubic .NE. ny_cubic )
then 7301 call mpp_error(note,
'test_update_nest_domain: for Cubic_grid mosaic, nx_cubic does not equal ny_cubic, '//&
7302 'No test is done for Cubic-Grid mosaic. ' )
7311 call mpp_error(fatal,
'test_update_nest_domain: no such test: '//type)
7315 if(mod(npes_coarse,ntiles) .NE. 0)
call mpp_error(fatal,
"test_mpp_domains: npes_coarse should be divided by ntiles")
7319 allocate(pelist(npes))
7320 call mpp_get_current_pelist(pelist)
7321 allocate(pelist_coarse(npes_coarse))
7322 allocate(pelist_fine(npes_fine))
7323 if( npes_coarse + npes_fine == mpp_npes() )
then 7325 pelist_coarse(1:npes_coarse) = pelist(1:npes_coarse)
7326 pelist_fine(1:npes_fine) = pelist(npes_coarse+1:npes_coarse+npes_fine)
7327 else if(npes_coarse == npes_fine .AND. npes_coarse == npes)
then 7328 concurrent = .false.
7329 pelist_fine = pelist
7330 pelist_coarse = pelist
7332 call mpp_error(fatal,
'test_update_nest_domain: either npes_fine+npes_coarse=npes or npes_fine=npes_coarse=npes')
7335 call mpp_declare_pelist(pelist_fine,
"fine grid")
7336 call mpp_declare_pelist(pelist_coarse,
"coarse grid")
7338 is_fine_pe = any(pelist_fine(:) == mpp_pe())
7339 is_coarse_pe = any(pelist_coarse(:) == mpp_pe())
7342 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
7343 if(is_coarse_pe)
then 7344 npes_per_tile = npes_coarse/ntiles
7346 call mpp_set_current_pelist(pelist_coarse)
7349 global_indices(:,n) = (/1,nx,1,ny/)
7350 layout2d(:,n) = layout
7353 pe_start(n) = (n-1)*npes_per_tile
7354 pe_end(n) = n*npes_per_tile-1
7357 if( cubic_grid )
then 7358 call define_cubic_mosaic(
type, domain_coarse, (/nx,nx,nx,nx,nx,nx/), (/ny,ny,ny,ny,ny,ny/), &
7359 global_indices, layout2D, pe_start, pe_end )
7366 nx_fine = iend_fine - istart_fine + 1
7367 ny_fine = jend_fine - jstart_fine + 1
7369 call mpp_set_current_pelist(pelist_fine)
7372 whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
7373 symmetry=.true., name=
"fine grid domain")
7379 call mpp_set_current_pelist()
7382 if( concurrent )
then 7388 nx_coarse = iend_coarse - istart_coarse + 1
7389 ny_coarse = jend_coarse - jstart_coarse + 1
7390 if( mod(nx_fine,nx_coarse) .NE. 0 )
call mpp_error(fatal, &
7391 "test_mpp_domains: The refinement in x-direction is not integer for type="//trim(type) )
7392 x_refine = nx_fine/nx_coarse
7393 if( mod(ny_fine,ny_coarse) .NE. 0 )
call mpp_error(fatal, &
7394 "test_mpp_domains: The refinement in y-direction is not integer for type="//trim(type) )
7395 y_refine = ny_fine/ny_coarse
7398 call mpp_define_nest_domains(nest_domain, domain_fine, domain_coarse, tile_fine, tile_coarse, &
7399 istart_fine, iend_fine, jstart_fine, jend_fine, &
7400 istart_coarse, iend_coarse, jstart_coarse, jend_coarse, &
7401 pelist, extra_halo, name=
"nest_domain")
7412 position_name =
"CENTER" 7415 position_name =
"EAST" 7418 position_name =
"CORNER" 7421 position_name =
"NORTH" 7424 call mpp_get_domain_shift(domain_coarse, ishift, jshift, position)
7429 call mpp_get_data_domain(domain_fine, isd_fine, ied_fine, jsd_fine, jed_fine, position=position)
7430 call mpp_get_c2f_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, west, position=position)
7431 call mpp_get_c2f_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, east, position=position)
7432 call mpp_get_c2f_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, south, position=position)
7433 call mpp_get_c2f_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, north, position=position)
7436 isw_f2 = 0; iew_f2 = -1; jsw_f2 = 0; jew_f2 = -1
7437 isw_c2 = 0; iew_c2 = -1; jsw_c2 = 0; jew_c2 = -1
7438 ise_f2 = 0; iee_f2 = -1; jse_f2 = 0; jee_f2 = -1
7439 ise_c2 = 0; iee_c2 = -1; jse_c2 = 0; jee_c2 = -1
7440 iss_f2 = 0; ies_f2 = -1; jss_f2 = 0; jes_f2 = -1
7441 iss_c2 = 0; ies_c2 = -1; jss_c2 = 0; jes_c2 = -1
7442 isn_f2 = 0; ien_f2 = -1; jsn_f2 = 0; jen_f2 = -1
7443 isn_c2 = 0; ien_c2 = -1; jsn_c2 = 0; jen_c2 = -1
7446 if( isc_fine == 1 )
then 7447 isw_f2 = isd_fine; iew_f2 = isc_fine - 1
7448 jsw_f2 = jsd_fine; jew_f2 = jed_fine
7449 isw_c2 = istart_coarse-whalo
7450 iew_c2 = istart_coarse
7451 jsw_c2 = jstart_coarse + (jsc_fine - jstart_fine)/y_refine - shalo
7452 jew_c2 = jstart_coarse + (jec_fine - jstart_fine)/y_refine + nhalo
7455 if( iec_fine == nx_fine+ishift )
then 7456 ise_f2 = iec_fine+1; iee_f2 = ied_fine
7457 jse_f2 = jsd_fine; jee_f2 = jed_fine
7458 ise_c2 = iend_coarse+ishift
7459 iee_c2 = iend_coarse+ehalo+ishift
7460 jse_c2 = jstart_coarse + (jsc_fine - jstart_fine)/y_refine - shalo
7461 jee_c2 = jstart_coarse + (jec_fine - jstart_fine)/y_refine + nhalo
7464 if( jsc_fine == 1 )
then 7465 iss_f2 = isd_fine; ies_f2 = ied_fine
7466 jss_f2 = jsd_fine; jes_f2 = jsc_fine - 1
7467 iss_c2 = istart_coarse + (isc_fine - istart_fine)/x_refine - whalo
7468 ies_c2 = istart_coarse + (iec_fine - istart_fine)/x_refine + ehalo
7469 jss_c2 = jstart_coarse-shalo
7470 jes_c2 = jstart_coarse
7473 if( jec_fine == ny_fine+jshift )
then 7474 isn_f2 = isd_fine; ien_f2 = ied_fine
7475 jsn_f2 = jec_fine+1; jen_f2 = jed_fine
7476 isn_c2 = istart_coarse + (isc_fine - istart_fine)/x_refine - whalo
7477 ien_c2 = istart_coarse + (iec_fine - istart_fine)/x_refine + ehalo
7478 jsn_c2 = jend_coarse+jshift
7479 jen_c2 = jend_coarse+nhalo+jshift
7482 if( isw_f .NE. isw_f2 .OR. iew_f .NE. iew_f2 .OR. jsw_f .NE. jsw_f2 .OR. jew_f .NE. jew_f2 .OR. &
7483 isw_c .NE. isw_c2 .OR. iew_c .NE. iew_c2 .OR. jsw_c .NE. jsw_c2 .OR. jew_c .NE. jew_c2 )
then 7484 call mpp_error(fatal,
"test_mpp_domains: west buffer index mismatch for "//trim(position_name))
7486 if( ise_f .NE. ise_f2 .OR. iee_f .NE. iee_f2 .OR. jse_f .NE. jse_f2 .OR. jee_f .NE. jee_f2 .OR. &
7487 ise_c .NE. ise_c2 .OR. iee_c .NE. iee_c2 .OR. jse_c .NE. jse_c2 .OR. jee_c .NE. jee_c2 )
then 7488 call mpp_error(fatal,
"test_mpp_domains: east buffer index mismatch for "//trim(position_name))
7490 if( iss_f .NE. iss_f2 .OR. ies_f .NE. ies_f2 .OR. jss_f .NE. jss_f2 .OR. jes_f .NE. jes_f2 .OR. &
7491 iss_c .NE. iss_c2 .OR. ies_c .NE. ies_c2 .OR. jss_c .NE. jss_c2 .OR. jes_c .NE. jes_c2 )
then 7492 call mpp_error(fatal,
"test_mpp_domains: south buffer index mismatch for "//trim(position_name))
7494 if( isn_f .NE. isn_f2 .OR. ien_f .NE. ien_f2 .OR. jsn_f .NE. jsn_f2 .OR. jen_f .NE. jen_f2 .OR. &
7495 isn_c .NE. isn_c2 .OR. ien_c .NE. ien_c2 .OR. jsn_c .NE. jsn_c2 .OR. jen_c .NE. jen_c2 )
then 7496 call mpp_error(fatal,
"test_mpp_domains: north buffer index mismatch for "//trim(position_name))
7500 if(is_coarse_pe)
then 7501 call mpp_get_compute_domain(domain_coarse, isc_coarse, iec_coarse, jsc_coarse, jec_coarse, position=position)
7502 call mpp_get_data_domain(domain_coarse, isd_coarse, ied_coarse, jsd_coarse, jed_coarse, position=position)
7503 allocate(x(isd_coarse:ied_coarse, jsd_coarse:jed_coarse, nz))
7505 npes_per_tile = npes_coarse/ntiles
7506 tile = mpp_pe()/npes_per_tile + 1
7508 do j = jsc_coarse, jec_coarse
7509 do i = isc_coarse, iec_coarse
7510 x(i,j,k) = tile + i*1.e-3 + j*1.e-6 + k*1.e-9
7515 allocate(x(isd_fine:ied_fine, jsd_fine:jed_fine, nz))
7518 do j = jsc_fine, jec_fine
7519 do i = isc_fine, iec_fine
7520 x(i,j,k) = i*1.e+6 + j*1.e+3 + k
7527 if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c )
then 7528 allocate(wbuffer(isw_c:iew_c, jsw_c:jew_c,nz))
7529 allocate(wbuffer2(isw_c:iew_c, jsw_c:jew_c,nz))
7531 allocate(wbuffer(1,1,1))
7532 allocate(wbuffer2(1,1,1))
7534 wbuffer = 0; wbuffer2 = 0
7536 if( iee_c .GE. ise_c .AND. jee_c .GE. jse_c )
then 7537 allocate(ebuffer(ise_c:iee_c, jse_c:jee_c,nz))
7538 allocate(ebuffer2(ise_c:iee_c, jse_c:jee_c,nz))
7540 allocate(ebuffer(1,1,1))
7541 allocate(ebuffer2(1,1,1))
7543 ebuffer = 0; ebuffer2 = 0
7545 if( ies_c .GE. iss_c .AND. jes_c .GE. jss_c )
then 7546 allocate(sbuffer(iss_c:ies_c, jss_c:jes_c,nz))
7547 allocate(sbuffer2(iss_c:ies_c, jss_c:jes_c,nz))
7549 allocate(sbuffer(1,1,1))
7550 allocate(sbuffer2(1,1,1))
7552 sbuffer = 0; sbuffer2 = 0
7554 if( ien_c .GE. isn_c .AND. jen_c .GE. jsn_c )
then 7555 allocate(nbuffer(isn_c:ien_c, jsn_c:jen_c,nz))
7556 allocate(nbuffer2(isn_c:ien_c, jsn_c:jen_c,nz))
7558 allocate(nbuffer(1,1,1))
7559 allocate(nbuffer2(1,1,1))
7561 nbuffer = 0; nbuffer2 = 0
7565 call mpp_update_nest_fine(x, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position)
7568 if( is_fine_pe )
then 7569 if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c )
then 7573 wbuffer2(i,j,k) = tile_coarse + i*1.e-3 + j*1.e-6 + k*1.e-9
7578 call compare_checksums(wbuffer, wbuffer2, trim(type)//
' west buffer '//trim(position_name))
7580 if( ies_c .GE. iss_c .AND. jes_c .GE. jss_c )
then 7584 sbuffer2(i,j,k) = tile_coarse + i*1.e-3 + j*1.e-6 + k*1.e-9
7589 call compare_checksums(sbuffer, sbuffer2, trim(type)//
' south buffer '//trim(position_name))
7591 if( iee_c .GE. ise_c .AND. jee_c .GE. jse_c )
then 7595 ebuffer2(i,j,k) = tile_coarse + i*1.e-3 + j*1.e-6 + k*1.e-9
7600 call compare_checksums(ebuffer, ebuffer2, trim(type)//
' east buffer '//trim(position_name))
7602 if( ien_c .GE. isn_c .AND. jen_c .GE. jsn_c )
then 7606 nbuffer2(i,j,k) = tile_coarse + i*1.e-3 + j*1.e-6 + k*1.e-9
7611 call compare_checksums(nbuffer, nbuffer2, trim(type)//
' north buffer '//trim(position_name))
7615 deallocate(wbuffer, ebuffer, sbuffer, nbuffer)
7616 deallocate(wbuffer2, ebuffer2, sbuffer2, nbuffer2)
7628 if(is_coarse_pe)
then 7637 position_name =
"CENTER" 7640 position_name =
"EAST" 7643 position_name =
"CORNER" 7646 position_name =
"NORTH" 7649 call mpp_get_domain_shift(domain_coarse, ishift, jshift, position)
7653 call mpp_get_data_domain(domain_fine, isd_fine, ied_fine, jsd_fine, jed_fine,position=position)
7654 allocate(x(isd_fine:ied_fine, jsd_fine:jed_fine, nz))
7657 do j = jsc_fine, jec_fine+jshift
7658 do i = isc_fine, iec_fine+ishift
7659 x(i,j,k) = i*1.e+6 + j*1.e+3 + k
7664 allocate(x(isd_coarse:ied_coarse+ishift, jsd_coarse:jed_coarse+jshift, nz))
7666 npes_per_tile = npes_coarse/ntiles
7667 tile = mpp_pe()/npes_per_tile + 1
7669 do j = jsc_coarse, jec_coarse+jshift
7670 do i = isc_coarse, iec_coarse+ishift
7671 x(i,j,k) = tile + i*1.e-3 + j*1.e-6 + k*1.e-9
7678 if(is_coarse_pe)
then 7680 call mpp_get_f2c_index(nest_domain, is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f,position=position)
7681 npes_per_tile = npes_coarse/ntiles
7682 tile = mpp_pe()/npes_per_tile + 1
7684 is_c2 =
max(istart_coarse, isc_coarse)
7685 ie_c2 =
min(iend_coarse, iec_coarse)
7686 js_c2 =
max(jstart_coarse, jsc_coarse)
7687 je_c2 =
min(jend_coarse, jec_coarse)
7688 if( tile == tile_coarse .AND. ie_c .GE. is_c .AND. je_c .GE. js_c )
then 7689 is_f2 = istart_fine + (is_c2 - istart_coarse)*x_refine
7690 ie_f2 = istart_fine + (ie_c2 - istart_coarse + 1)*x_refine - 1
7691 js_f2 = jstart_fine + (js_c2 - jstart_coarse)*y_refine
7692 je_f2 = jstart_fine + (je_c2 - jstart_coarse + 1)*y_refine - 1
7693 ie_f2 = ie_f2 + ishift; je_f2 = je_f2 + jshift
7694 ie_c2 = ie_c2 + ishift; je_c2 = je_c2 + jshift
7696 is_f2 = 0; ie_f2 = -1; js_f2 = 0; je_f2 = -1
7697 is_c2 = 0; ie_c2 = -1; js_c2 = 0; je_c2 = -1
7700 if( is_f .NE. is_f2 .OR. ie_f .NE. ie_f2 .OR. js_f .NE. js_f2 .OR. je_f .NE. je_f2 .OR. &
7701 is_c .NE. is_c2 .OR. ie_c .NE. ie_c2 .OR. js_c .NE. js_c2 .OR. je_c .NE. je_c2 )
then 7702 call mpp_error(fatal,
"test_mpp_domains: fine to coarse buffer index mismatch")
7706 if(is_coarse_pe)
then 7707 if( ie_f .GE. is_f .AND. je_f .GE. js_f )
then 7708 allocate(buffer(is_f:ie_f, js_f:je_f,nz))
7709 allocate(buffer2(is_f:ie_f, js_f:je_f,nz))
7713 buffer2(i,j,k) = i*1.e+6 + j*1.e+3 + k
7718 allocate(buffer(1,1,1))
7719 allocate(buffer2(1,1,1))
7728 if( is_coarse_pe)
then 7729 call compare_checksums(buffer, buffer2, trim(type)//
' fine to coarse buffer '//trim(position_name))
7731 if(
allocated(buffer))
deallocate(buffer)
7732 if(
allocated(buffer2))
deallocate(buffer2)
7733 if(
allocated(x))
deallocate(x)
7736 deallocate(pelist, pelist_fine, pelist_coarse)
7737 deallocate(layout2d, global_indices, pe_start, pe_end )
7739 end subroutine test_update_nest_domain
7740 subroutine test_get_boundary_ad(type)
7746 character(len=*),
intent(in) :: type
7748 type(domain2D) :: domain
7749 integer :: ntiles, num_contact, npes_per_tile, ntile_per_pe, layout(2)
7750 integer :: n, l, isc, iec, jsc, jec, ism, iem, jsm, jem
7751 integer,
allocatable,
dimension(:) :: tile, ni, nj, pe_start, pe_end
7752 integer,
allocatable,
dimension(:,:) :: layout2D, global_indices
7754 real*8,
allocatable,
dimension(:,:,:) :: x_ad, y_ad, x_fd, y_fd, x_save, y_save
7755 real*8,
allocatable,
dimension(:,:) :: ebufferx2_ad, wbufferx2_ad
7756 real*8,
allocatable,
dimension(:,:) :: sbuffery2_ad, nbuffery2_ad
7757 real*8 :: ad_sum, fd_sum
7758 integer :: shift,i,j,k,pe
7764 allocate(layout2d(2,ntiles), global_indices(4,ntiles), pe_start(ntiles), pe_end(ntiles) )
7765 allocate(ni(ntiles), nj(ntiles))
7766 ni(:) = nx; nj(:) = ny
7767 if( mod(npes, ntiles) == 0 )
then 7768 npes_per_tile = npes/ntiles
7769 write(outunit,*)
'NOTE from test_uniform_mosaic ==> For Mosaic "', trim(type), &
7770 '", each tile will be distributed over ', npes_per_tile,
' processors.' 7772 allocate(tile(ntile_per_pe))
7773 tile = pe/npes_per_tile+1
7776 pe_start(n) = (n-1)*npes_per_tile
7777 pe_end(n) = n*npes_per_tile-1
7780 call mpp_error(note,
'TEST_MPP_DOMAINS: npes should be multiple of ntiles or ' // &
7781 'ntiles should be multiple of npes. No test is done for '//trim(type) )
7786 global_indices(:,n) = (/1,nx,1,ny/)
7787 layout2d(:,n) = layout
7790 call define_fourtile_mosaic(
type, domain, (/nx,nx,nx,nx/), (/ny,ny,ny,ny/), global_indices, &
7791 layout2D, pe_start, pe_end, .true. )
7796 deallocate(layout2d, global_indices, pe_start, pe_end )
7800 allocate( x_ad(ism:iem+shift,jsm:jem ,nz) )
7801 allocate( x_fd(ism:iem+shift,jsm:jem ,nz) )
7802 allocate( x_save(ism:iem+shift,jsm:jem ,nz) )
7803 allocate( y_ad(ism:iem ,jsm:jem+shift,nz) )
7804 allocate( y_fd(ism:iem ,jsm:jem+shift,nz) )
7805 allocate( y_save(ism:iem ,jsm:jem+shift,nz) )
7806 allocate(ebufferx2_ad(jec-jsc+1, nz), wbufferx2_ad(jec-jsc+1, nz))
7807 allocate(sbuffery2_ad(iec-isc+1, nz), nbuffery2_ad(iec-isc+1, nz))
7829 call mpp_get_boundary(x_fd, y_fd, domain, ebufferx=ebufferx2_ad(:,:), wbufferx=wbufferx2_ad(:,:), &
7830 sbuffery=sbuffery2_ad(:,:), nbuffery=nbuffery2_ad(:,:), gridtype=cgrid_ne, &
7836 fd_sum = fd_sum + x_fd(i,j,k)*x_fd(i,j,k)
7843 fd_sum = fd_sum + y_fd(i,j,k)*y_fd(i,j,k)
7849 fd_sum = fd_sum + ebufferx2_ad(i,k)*ebufferx2_ad(i,k)
7854 fd_sum = fd_sum + wbufferx2_ad(i,k)*wbufferx2_ad(i,k)
7859 fd_sum = fd_sum + sbuffery2_ad(i,k)*sbuffery2_ad(i,k)
7864 fd_sum = fd_sum + nbuffery2_ad(i,k)*nbuffery2_ad(i,k)
7872 call mpp_get_boundary_ad(x_ad, y_ad, domain, ebufferx=ebufferx2_ad(:,:), wbufferx=wbufferx2_ad(:,:), &
7873 sbuffery=sbuffery2_ad(:,:), nbuffery=nbuffery2_ad(:,:), gridtype=cgrid_ne, &
7880 ad_sum = ad_sum + x_ad(i,j,k)*x_save(i,j,k)
7887 ad_sum = ad_sum + y_ad(i,j,k)*y_save(i,j,k)
7893 if( pe.EQ.mpp_root_pe() )
then 7894 if (abs(ad_sum-fd_sum)/fd_sum.lt.1e-7)
then 7895 print*,
"Passed Adjoint Dot Test: mpp_get_boundary_ad" 7899 deallocate (x_ad, y_ad, x_fd, y_fd, x_save, y_save)
7900 deallocate (ebufferx2_ad, wbufferx2_ad)
7901 deallocate (sbuffery2_ad, nbuffery2_ad)
7903 end subroutine test_get_boundary_ad
7905 subroutine test_halo_update_ad( type )
7910 character(len=*),
intent(in) :: type
7911 type(domain2D) :: domain
7913 integer :: shift, i, j, k
7914 logical :: is_symmetry
7915 integer :: is, ie, js, je, isd, ied, jsd, jed, pe
7917 real*8,
allocatable,
dimension(:,:,:) :: x_ad, y_ad, x_fd, y_fd, x_save, y_save
7918 real*8 :: ad_sum, fd_sum
7920 if(index(
type,
'symmetry') == 0) then
7921 is_symmetry = .false.
7923 is_symmetry = .true.
7926 case(
'Simple',
'Simple symmetry' )
7929 shalo=shalo, nhalo=nhalo, name=
type, symmetry = is_symmetry )
7930 case(
'Cyclic',
'Cyclic symmetry' )
7933 shalo=shalo, nhalo=nhalo, xflags=cyclic_global_domain, yflags=cyclic_global_domain, &
7934 name=
type, symmetry = is_symmetry )
7936 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//
type )
7945 allocate( x_fd(isd:ied,jsd:jed,nz) )
7946 allocate( x_ad(isd:ied,jsd:jed,nz) )
7947 allocate( x_save(isd:ied,jsd:jed,nz) )
7948 x_fd = 0.; x_ad = 0.; x_save = 0.
7966 fd_sum = fd_sum + x_fd(i,j,k)*x_fd(i,j,k)
7979 ad_sum = ad_sum + x_ad(i,j,k)*x_save(i,j,k)
7986 if( pe.EQ.mpp_root_pe() )
then 7987 if (abs(ad_sum-fd_sum)/fd_sum.lt.1e-7)
then 7988 print*,
"Passed Adjoint Dot Test: mpp_update_domains_ad(single 3D field)" 7992 deallocate (x_ad, x_fd, x_save)
7995 allocate( x_ad(isd:ied+shift,jsd:jed ,nz) )
7996 allocate( x_fd(isd:ied+shift,jsd:jed ,nz) )
7997 allocate( x_save(isd:ied+shift,jsd:jed ,nz) )
7998 allocate( y_ad(isd:ied ,jsd:jed+shift,nz) )
7999 allocate( y_fd(isd:ied ,jsd:jed+shift,nz) )
8000 allocate( y_save(isd:ied ,jsd:jed+shift,nz) )
8019 do i = isd,ied+shift
8020 fd_sum = fd_sum + x_fd(i,j,k)*x_fd(i,j,k)
8025 do j = jsd,jed+shift
8027 fd_sum = fd_sum + y_fd(i,j,k)*y_fd(i,j,k)
8040 do i = isd,ied+shift
8041 ad_sum = ad_sum + x_ad(i,j,k)*x_save(i,j,k)
8046 do j = jsd,jed+shift
8048 ad_sum = ad_sum + y_ad(i,j,k)*y_save(i,j,k)
8054 if( pe.EQ.mpp_root_pe() )
then 8055 if (abs(ad_sum-fd_sum)/fd_sum.lt.1e-7)
then 8056 print*,
"Passed Adjoint Dot Test: mpp_update_domains_ad(vector 3D fields)" 8059 deallocate (x_ad, y_ad, x_fd, y_fd, x_save, y_save)
8061 end subroutine test_halo_update_ad
8063 subroutine test_global_reduce_ad (type)
8066 character(len=*),
intent(in) :: type
8067 real :: gsum_tl, gsum_ad
8068 real*8 :: gsum_tl_save, gsum_ad_save
8069 real :: gsum_tl_bit, gsum_ad_bit
8070 real*8 :: gsum_tl_save_bit, gsum_ad_save_bit
8071 integer :: i,j,k, ishift, jshift, position
8072 integer :: isd, ied, jsd, jed
8074 type(domain2D) :: domain
8075 real,
allocatable,
dimension(:,:,:) :: x, x_ad, x_ad_bit
8082 shalo=shalo, nhalo=nhalo, name=
type )
8083 case(
'Simple symmetry center',
'Simple symmetry corner',
'Simple symmetry east',
'Simple symmetry north' )
8085 shalo=shalo, nhalo=nhalo, name=
type, symmetry = .true. )
8086 case(
'Cyclic symmetry center',
'Cyclic symmetry corner',
'Cyclic symmetry east',
'Cyclic symmetry north' )
8087 call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
8088 name=
type, symmetry = .true., xflags=cyclic_global_domain, yflags=cyclic_global_domain )
8090 call mpp_error( fatal,
'TEST_MPP_DOMAINS: no such test: '//type//
' in test_global_field' )
8096 ishift = 0; jshift = 0; position = center
8098 case (
'Simple symmetry corner',
'Cyclic symmetry corner')
8099 ishift = 1; jshift = 1; position = corner
8100 case (
'Simple symmetry east',
'Cyclic symmetry east' )
8101 ishift = 1; jshift = 0; position = east
8102 case (
'Simple symmetry north',
'Cyclic symmetry north')
8103 ishift = 0; jshift = 1; position = north
8106 ied = ied+ishift; jed = jed+jshift
8108 allocate( x(isd:ied,jsd:jed,nz), x_ad(isd:ied,jsd:jed,nz), x_ad_bit(isd:ied,jsd:jed,nz) )
8120 gsum_tl_bit =
mpp_global_sum( domain, x, flags=bitwise_exact_sum )
8121 gsum_tl_save = gsum_tl*gsum_tl
8122 gsum_tl_save_bit = gsum_tl_bit*gsum_tl_bit
8125 gsum_ad_bit = gsum_tl_bit
8130 call mpp_global_sum_ad( domain, x_ad_bit, gsum_ad_bit, flags = bitwise_exact_sum )
8133 gsum_ad_save_bit = 0.
8138 gsum_ad_save = gsum_ad_save + x_ad(i,j,k)*x(i,j,k)
8139 gsum_ad_save_bit = gsum_ad_save_bit + x_ad_bit(i,j,k)*x(i,j,k)
8145 call mpp_sum( gsum_ad_save_bit )
8148 if( pe.EQ.mpp_root_pe() )
then 8149 if (abs(gsum_ad_save-gsum_tl_save)/gsum_tl_save.lt.1e-7)
then 8150 print*,
"Passed Adjoint Dot Test: mpp_global_sum_ad" 8152 if (abs(gsum_ad_save_bit-gsum_tl_save_bit)/gsum_tl_save_bit.lt.1e-7)
then 8153 print*,
"Passed Adjoint Dot Test: mpp_global_sum_ad, flags=BITWISE_EXACT_SUM" 8157 deallocate(x, x_ad, x_ad_bit)
8159 end subroutine test_global_reduce_ad
real(fp), parameter, public zero
subroutine define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_start, pe_end)
subroutine, public mpp_memuse_begin
subroutine compare_checksums(a, b, string)
character(len=input_str_length), dimension(:), allocatable, target, public input_nml_file
subroutine, public mpp_memuse_end(text, unit)
subroutine compare_checksums_2d(a, b, string)