New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

exchtestmod.F90 in branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchtestmod.F90 @ 4409

Last change on this file since 4409 was 4409, checked in by trackstand2, 10 years ago
Changes to allow jpk to be modified to deepest level within a subdomain. jpkorig holds original value.
File size: 61.1 KB

Line
1	MODULE exchtestmod
2	USE par_kind, ONLY: wp
3	USE mapcomm_mod, ONLY: cyclic_bc, trimmed, nidx, eidx, sidx, widx
4	PRIVATE
5
6	LOGICAL, PARAMETER :: stop_after_testing = .FALSE., & ! STOP the nemo run
7	! once these tests are complete
8	#if defined key_mpp_rkpart
9	compare_exch_methods= .FALSE., & ! Do both packed and
10	do_integer_tests = .FALSE., & ! indiv. exchanges and compare output
11	do_real_tests = .TRUE. , &
12	do_integer_timings = .FALSE., &
13	do_real_timings = .TRUE., &
14	use_exch_list = .FALSE. ! Whether to use the halo
15	! packing API for the tests
16	! - NOT currently working!
17	#else
18	compare_exch_methods= .FALSE., &
19	! WARNING: test code not supported for non rkpart build!
20	do_integer_tests = .FALSE., &
21	do_real_tests = .FALSE., &
22	do_integer_timings = .FALSE., &
23	do_real_timings = .FALSE., &
24	use_exch_list = .FALSE. ! Whether to use the halo
25	! packing API for the tests
26	! - NOT currently working!
27	#endif
28
29	LOGICAL :: test_failed ! Updated if any test fails so we can
30	! stop the job once testing complete
31
32	! We need to test exchanges of {REAL, INTEGER} {2D, 3D} arrays on
33	! {U, V, W, Z, T} grids
34	!FTRANS r3d :I :I :z
35	!FTRANS r3d_2 :I :I :z
36	!FTRANS r3d_3 :I :I :z
37	REAL (kind=wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: r3d, r3d_2, r3d_3
38	REAL (kind=wp), DIMENSION(:,:) , ALLOCATABLE, TARGET :: r2d, r2d_2
39	REAL (kind=wp), DIMENSION(:,:) , ALLOCATABLE :: r2dxz
40	!FTRANS i3d :I :I :z
41	!FTRANS i3d_2 :I :I :z
42	INTEGER, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: i3d, i3d_2
43	INTEGER, DIMENSION(:,:), ALLOCATABLE, TARGET :: i2d, i2d_2
44
45	! Last ocean level above ocean floor
46	INTEGER, DIMENSION(:,:), POINTER :: pmaxdepth
47
48	! Unit to use for outputting log of results
49	INTEGER, PARAMETER :: LOG_UNIT = 1002
50
51	! Identifiers for types of test
52	INTEGER, PARAMETER :: PE_ID_TEST = 0, &
53	GLOBAL_LOCN_TEST = 1
54
55	! No. of times to repeat a message exchange while doing timing
56	INTEGER, PARAMETER :: loops_to_time = 5000
57
58	INTERFACE compare_arrays
59	MODULE PROCEDURE compare_arrays2d, compare_arrays3d
60	END INTERFACE compare_arrays
61
62	PUBLIC mpp_test_comms ! Only the top-level driver routine is public
63
64	CONTAINS
65
66	!====================================================================
67
68	SUBROUTINE mpp_test_comms(depth, lmaxdepth)
69	USE par_oce, ONLY: jpi, jpj, jpk, jpkorig, jpreci
70	USE par_kind, ONLY: wp
71	USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE
72	USE lib_mpp, ONLY: ctl_stop, ctl_warn
73	USE dom_oce, ONLY: narea
74	USE exchmod, ONLY: add_exch, bound_exch_list, bound_exch
75	USE timing, ONLY: timing_finalize
76	USE profile
77	#if defined key_mpp_mpi
78	USE lib_mpp, ONLY: mpi_comm_opa
79	USE mpi
80	#endif
81	IMPLICIT none
82	! Routine arguments
83	INTEGER, DIMENSION(:,:), INTENT(in) :: depth ! Mask (1 for ocean, 0 for land)
84	INTEGER, DIMENSION(:,:), TARGET :: lmaxdepth ! Last level above ocean floor
85	! Local vars
86	INTEGER :: ierr
87	CHARACTER(len=256) :: name
88
89	#if ! defined key_mpp_mpi
90	CALL ctl_warn('mpp_test_comms: not built with MPI so nothing to do!')
91	RETURN
92	#endif
93
94	CALL prof_tracing_on()
95
96	! Initialise the flag that will store whether we have any fails
97	test_failed = .FALSE.
98
99	ALLOCATE(r3d(jpi,jpj,jpkorig), r3d_2(jpi,jpj,jpkorig), r3d_3(jpi,jpj,jpkorig), &
100	r2d(jpi,jpj), r2d_2(jpi,jpj), Stat=ierr)
101
102	! Set module member variable to point to max-depth data so we can access it
103	! when checking results of halo swaps.
104	pmaxdepth => lmaxdepth
105
106	IF(ierr .ne. 0)THEN
107	WRITE (,) "Failed to allocate memory in mpp_test_comms - no tests will be performed!"
108	RETURN
109	END IF
110
111	WRITE(name, FMT="('testing.',I4.4,'.log')") narea-1
112	OPEN(UNIT=LOG_UNIT, FILE=TRIM(name), &
113	STATUS='REPLACE', ACTION='WRITE', IOSTAT=ierr)
114
115	IF(ierr .ne. 0)THEN
116	WRITE (,) "Failed to open testing.log for logging - no tests will be performed!"
117	RETURN
118	END IF
119
120	! Test exchanges of real arrays ------------------------------------------
121
122	IF(do_real_tests)THEN
123
124	IF(narea == 1) WRITE (,) '1. Testing exchanges of real arrays...'
125
126	! 1. Test halo exchanges for a 3D REAL array at 'W' point...
127
128	name = '3D REAL array at W point'
129	CALL exch_test(name, 'W', GLOBAL_LOCN_TEST, depth, r3d1=r3d, isgn=-1)
130
131	name = '3D REAL array at W point, lfill reversed'
132	CALL exch_test(name, 'W', GLOBAL_LOCN_TEST, depth, r3d1=r3d, &
133	lfill=.TRUE.)
134
135	IF(narea == 1) WRITE (,) 'Test 1 done.'
136
137	! 2. Test halo exchanges for a 3D REAL array at 'Z' point...
138
139	name = '3D REAL array at Z point'
140	CALL exch_test(name, 'Z', GLOBAL_LOCN_TEST, depth, &
141	r3d1=r3d, isgn=-999, lfill=.TRUE.)
142
143	IF(narea == 1) WRITE (,) 'Test 2 done.'
144
145	! 3. Test halo exchanges for a 2D REAL array at 'Z' point...
146
147	name = '2D REAL array at Z point'
148	CALL exch_test(name, 'Z', GLOBAL_LOCN_TEST, depth, r2d1=r2d, &
149	isgn=-999, lfill=.TRUE.)
150
151	IF(narea == 1) WRITE (,) 'Test 3 done.'
152
153	! 4. Test halo exchanges for a 2D REAL array at 'T' point...
154
155	name = '2D REAL array at T point'
156	CALL exch_test(name, 'T', GLOBAL_LOCN_TEST, depth, r2d1=r2d, &
157	isgn=1, lfill=.FALSE.)
158
159	IF(narea == 1) WRITE (,) 'Test 4 done.'
160
161
162	! 5. Test halo exchanges for a 3D REAL array at 'T' point...
163
164	name = '3D REAL array at T point'
165	CALL exch_test(name, 'T', GLOBAL_LOCN_TEST, depth, r3d1=r3d, &
166	isgn=-999, lfill=.TRUE.)
167
168	name = '3D REAL array at T point, lfill now .FALSE.'
169	CALL exch_test(name, 'T', GLOBAL_LOCN_TEST, depth, r3d1=r3d)
170
171	IF(narea == 1) WRITE (,) 'Test 5 done.'
172
173	! 6. Test halo exchanges for a 3D REAL array at 'V' point...
174
175	name = '3D REAL array at V point'
176	CALL exch_test(name, 'V', PE_ID_TEST, depth, r3d1=r3d, &
177	isgn=-999, lfill=.TRUE.)
178
179	IF(narea == 1) WRITE (,) 'Test 6 done.'
180
181	! 7. Test halo exchanges for _two_ 2D REAL arrays at 'V' point...
182
183	name = 'Two 2D REAL arrays at V point'
184	CALL exch_test(name,'V', PE_ID_TEST, depth, r2d1=r2d, r2d2=r2d_2, &
185	isgn=-999, lfill=.TRUE.)
186
187	IF(narea == 1) WRITE (,) 'Test 7 done.'
188
189	! 8. Test halo exchanges for _two_ 3D REAL arrays at 'V' point...
190
191	name = 'Two 3D REAL arrays at V point'
192	CALL exch_test(name,'V', PE_ID_TEST, depth, r3d1=r3d, r3d2=r3d_2, &
193	isgn=-999, lfill=.TRUE.)
194
195	IF(narea == 1) WRITE (,) 'Test 8 done.'
196
197	! 9. Test halo exchanges for _three_ 3D REAL arrays at 'T' point...
198
199	name = 'Three 3D REAL arrays at T point'
200	CALL exch_test(name,'T', PE_ID_TEST, depth, &
201	r3d1=r3d, r3d2=r3d_2, r3d3=r3d_3, &
202	isgn=-999, lfill=.TRUE.)
203
204	IF(narea == 1) WRITE (,) 'Test 9 done.'
205
206	END IF
207
208	! End of real-array tests, now for timing ------------------------------
209
210	IF(do_real_timings)THEN
211
212	IF(narea == 1)THEN
213	WRITE (,) '2. Measuring performance for real arrays...'
214	END IF
215
216	CALL exch_timing('Z', r2d1=r2d, &
217	isgn=-999, lfill=.TRUE.)
218	CALL exch_timing('T', r2d1=r2d, r2d2=r2d_2, &
219	isgn=-999, lfill=.TRUE.)
220	CALL exch_timing('T', r2d1=r2d)
221	CALL exch_timing('U', r2d1=r2d, isgn=-1)
222	CALL exch_timing('T', r2d1=r2d, r2d2=r2d_2)
223
224	CALL exch_timing('T', r3d1=r3d)
225	CALL exch_timing('Z', r3d1=r3d, r2d1=r2d, &
226	isgn=-999, lfill=.TRUE.)
227	CALL exch_timing('U', r3d1=r3d, r3d2=r3d_2, &
228	isgn=-1, lfill=.TRUE.)
229	CALL exch_timing('U', r3d1=r3d, r3d2=r3d_2, isgn=-1)
230	CALL exch_timing('T', r3d1=r3d, r3d2=r3d_2, &
231	isgn=-1, lfill=.TRUE.)
232	CALL exch_timing('T', r3d1=r3d, r3d2=r3d_2)
233
234	IF(narea == 1)THEN
235	WRITE (,) '...performance tests for real array exchanges complete.'
236	END IF
237
238	END IF
239
240	! Free-up memory used for real-array tests
241
242	DEALLOCATE(r3d, r3d_2, r3d_3, r2d)
243	! and allocate that for integer-array tests
244	ALLOCATE(i3d(jpi,jpj,jpkorig), i3d_2(jpi,jpj,jpkorig), &
245	i2d(jpi,jpj), i2d_2(jpi,jpj), Stat=ierr)
246
247	IF(ierr .ne. 0)THEN
248	WRITE (,) "Failed to allocate memory in mpp_test_comms - no INTEGER tests will be performed!"
249	RETURN
250	END IF
251
252	! Test exchanges of integer arrays ------------------------------------------
253
254	IF(do_integer_tests)THEN
255
256	IF(narea == 1)THEN
257	WRITE (,) '3. Testing exchanges of integer arrays...'
258	END IF
259
260	! 8. Test halo exchanges for a 3D INTEGER array at 'W' point...
261
262	name = 'One 3D integer array at W point'
263	CALL exch_test(name,'W', PE_ID_TEST, depth, i3d1=i3d, &
264	isgn=-999, lfill=.TRUE.)
265
266	! 9. Test halo exchanges for a 3D INTEGER array at 'Z' point...
267
268	name = 'One 3D integer array at Z point'
269	CALL exch_test(name,'Z', PE_ID_TEST, depth, i3d1=i3d, &
270	isgn=-999, lfill=.TRUE.)
271
272	! 10. Test halo exchanges for a 2D INTEGER array at 'Z' point...
273
274	name = 'One 2D integer array at Z point'
275	CALL exch_test(name,'Z', PE_ID_TEST, depth, i2d1=i2d, &
276	isgn=-999, lfill=.TRUE.)
277
278	! 11. Test halo exchanges for _two_ 3D INTEGER arrays at 'Z' point...
279
280	name = 'Two 3D integer arrays at Z point'
281	CALL exch_test(name,'Z', PE_ID_TEST, depth, i3d1=i3d, i3d2=i3d_2, &
282	isgn=-999, lfill=.TRUE.)
283
284
285	IF(narea == 1)THEN
286	WRITE (,) '...integer-array tests complete'
287	END IF
288
289	END IF
290
291	! End of tests, now for timing ------------------------------------
292
293	IF(do_integer_timings)THEN
294
295	IF(narea == 1)THEN
296	WRITE (,) '4. Measuring performance for integer arrays...'
297	END IF
298
299	CALL exch_timing('Z', i2d1=i2d, &
300	isgn=-999, lfill=.TRUE.)
301
302	CALL exch_timing('Z', i2d1=i2d, i2d2=i2d_2, &
303	isgn=-999, lfill=.TRUE.)
304
305	CALL exch_timing('Z', i3d1=i3d, &
306	isgn=-999, lfill=.TRUE.)
307
308	CALL exch_timing('Z', i2d1 = i2d, i3d1=i3d, &
309	isgn=-999, lfill=.TRUE.)
310
311	CALL exch_timing('Z', i3d1=i3d, i3d2=i3d_2, &
312	isgn=-999, lfill=.TRUE.)
313
314	CALL exch_timing('Z', i2d1 = i2d, i3d1=i3d, i3d2=i3d_2, &
315	isgn=-999, lfill=.TRUE.)
316
317	IF(narea == 1)THEN
318	WRITE (,) '...integer-array performance tests complete.'
319	END IF
320
321	END IF
322
323	! End of timing of integer exchanges -------------------------------
324
325	CLOSE(UNIT=LOG_UNIT)
326
327	DEALLOCATE(i3d, i3d_2, i2d, i2d_2)
328
329	#if defined key_mpp_mpi
330	! Check for success or otherwise of tests on all PEs
331	CALL mpi_allreduce(MPI_IN_PLACE, test_failed, 1, MPI_LOGICAL, MPI_LOR, &
332	mpi_comm_opa, ierr )
333	#endif
334
335	IF(stop_after_testing .OR. test_failed )THEN
336	IF(narea == 1)THEN
337	IF(test_failed)THEN
338	WRITE (*,FMT="('Stopping due to error in msg. exchange tests!')")
339	ELSE
340	WRITE (*,FMT="('Stopping now that comms tests are complete!')")
341	END IF
342	END IF
343	! Generate a timing report
344	CALL timing_finalize()
345	! Dirty way of causing NEMO to stop immediately
346	CALL ctl_stop('STOP', 'Stopping now that comms tests are complete')
347	END IF
348
349	END SUBROUTINE mpp_test_comms
350
351	!======================================================================
352
353	SUBROUTINE exch_test(descr, gridType, testType, depth, r2d1, r2d2, &
354	r3d1, r3d2, r3d3, i2d1, i3d1, i3d2, isgn, lfill)
355	USE par_kind, ONLY: wp
356	USE par_oce, ONLY: jpreci
357	USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE
358	USE exchmod, ONLY: add_exch, bound_exch_list, bound_exch
359	USE lbclnk, ONLY: lbc_lnk
360	USE lib_mpp, ONLY: ctl_warn
361	USE dom_oce, ONLY: narea
362	IMPLICIT none
363	!FTRANS r3d1 :I :I :z
364	!FTRANS r3d2 :I :I :z
365	!FTRANS r3d3 :I :I :z
366	!FTRANS i3d1 :I :I :z
367	!FTRANS i3d2 :I :I :z
368	!FTRANS r3dcopy :I :I :z
369	! Arguments
370	CHARACTER(LEN=256), INTENT(in) :: descr ! Description of the test being done
371	CHARACTER(LEN=1), INTENT(in) :: gridType ! Grid on which test being done
372	INTEGER, INTENT(in) :: testType ! Type of test to do
373	INTEGER, DIMENSION(:,:), INTENT(in) :: depth ! Global land mask
374	LOGICAL, INTENT(in), OPTIONAL :: lfill
375	REAL (kind=wp), DIMENSION(:,:), INTENT(inout), OPTIONAL :: r2d1,r2d2
376	REAL (kind=wp), DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: r3d1,r3d2,r3d3
377	INTEGER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: i3d1,i3d2
378	INTEGER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: i2d1
379	INTEGER, INTENT(in), OPTIONAL :: isgn
380	! Local vars
381	LOGICAL :: hit_error, test_pass
382	REAL (kind=wp), DIMENSION(:,:), ALLOCATABLE :: r2dcopy
383	REAL (kind=wp), DIMENSION(:,:,:), ALLOCATABLE :: r3dcopy
384	INTEGER :: ierr
385	INTEGER :: isize_x, isize_y, isize_z
386	REAL (kind=wp):: psgn
387	!!-----------------------------------------------------------------------
388
389	#if ! defined key_mpp_rkpart
390	CALL ctl_warn('exch_test: halo exchange testing not supported for build without key_mpp_rkpart defined')
391	RETURN
392	#endif
393
394	! Initialise arrays being exchanged
395	! A correct exchange process (but without north-fold) won't change
396	! these values. If lfill is set to .TRUE. then no north-fold exchange
397	! is performed.
398	CALL init_test_arrays(testType, &
399	r2d1, r2d2, r3d1, r3d2, r3d3, i2d1, i3d1, i3d2)
400
401	IF(PRESENT(r3d1))THEN
402
403	#if defined key_mpp_rkpart
404	IF(use_exch_list)THEN
405	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r3d=r3d1, &
406	isgn=isgn, lfill=lfill)
407	ELSE
408	CALL bound_exch(r3d1, jpreci, jpreci, &
409	Iplus, Iminus, Jplus, Jminus, &
410	gridType, isgn=isgn, lfill=lfill)
411	END IF
412	#else
413	! psgn is NOT an optional argument to lbc_lnk
414	psgn = 1.0_wp
415	IF(PRESENT(isgn))psgn = REAL(isgn)
416	CALL lbc_lnk(r3d1, gridType, psgn)
417	#endif
418	END IF
419
420	#if defined key_mpp_rkpart
421	IF(PRESENT(r3d2))THEN
422	IF(use_exch_list)THEN
423	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r3d=r3d2, &
424	isgn=isgn, lfill=lfill)
425	ELSE
426	CALL bound_exch(r3d2, jpreci, jpreci, &
427	Iplus, Iminus, Jplus, Jminus, &
428	gridType, isgn=isgn, lfill=lfill)
429	END IF
430	END IF
431	#endif
432
433	IF(PRESENT(r3d3))THEN
434
435	#if defined key_mpp_rkpart
436	IF(use_exch_list)THEN
437	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r3d=r3d3, &
438	isgn=isgn, lfill=lfill)
439	ELSE
440	CALL bound_exch(r3d3, jpreci, jpreci, &
441	Iplus, Iminus, Jplus, Jminus, &
442	gridType, isgn=isgn, lfill=lfill)
443	END IF
444	#endif
445
446	END IF
447
448	IF(PRESENT(r2d1))THEN
449
450	#if defined key_mpp_rkpart
451	IF(use_exch_list)THEN
452	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r2d=r2d1, &
453	isgn=isgn, lfill=lfill)
454	ELSE
455	CALL bound_exch(r2d1, jpreci, jpreci, &
456	Iplus, Iminus, Jplus, Jminus, &
457	gridType, isgn=isgn, lfill=lfill)
458	END IF
459	#endif
460	END IF
461
462	IF(PRESENT(r2d2))THEN
463
464	#if defined key_mpp_rkpart
465	IF(use_exch_list)THEN
466	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r2d=r2d2, &
467	isgn=isgn, lfill=lfill)
468	ELSE
469	CALL bound_exch(r2d2, jpreci, jpreci, &
470	Iplus, Iminus, Jplus, Jminus, &
471	gridType, isgn=isgn, lfill=lfill)
472	END IF
473	#endif
474	END IF
475
476	IF( PRESENT(i2d1) )THEN
477
478	#if defined key_mpp_rkpart
479	IF(use_exch_list)THEN
480	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, i2d=i2d1, &
481	isgn=isgn, lfill=lfill)
482	ELSE
483	CALL bound_exch(i2d1, jpreci, jpreci, &
484	Iplus, Iminus, Jplus, Jminus, &
485	gridType, isgn=isgn, lfill=lfill)
486	END IF
487	#endif
488	END IF
489
490	IF( PRESENT(i3d1) )THEN
491
492	#if defined key_mpp_rkpart
493	IF(use_exch_list)THEN
494	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, i3d=i3d1, &
495	isgn=isgn, lfill=lfill)
496	ELSE
497	CALL bound_exch(i3d1, jpreci, jpreci, &
498	Iplus, Iminus, Jplus, Jminus, &
499	gridType, isgn=isgn, lfill=lfill)
500	END IF
501	#endif
502	END IF
503
504	IF( PRESENT(i3d2) )THEN
505
506	#if defined key_mpp_rkpart
507	IF(use_exch_list)THEN
508	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, i3d=i3d2, &
509	isgn=isgn, lfill=lfill)
510	ELSE
511	CALL bound_exch(i3d2, jpreci, jpreci, &
512	Iplus, Iminus, Jplus, Jminus, &
513	gridType, isgn=isgn, lfill=lfill)
514	END IF
515	#endif
516	END IF
517
518	#if defined key_mpp_rkpart
519	IF(use_exch_list)THEN
520	! Finally, exchange halos for the arrays that we've added to the list
521	CALL bound_exch_list()
522	END IF
523	#endif
524
525	! In this section we test to see that the results of using the halo-packing
526	! API are the same as doing individual halo swaps.
527	#if defined key_mpp_rkpart
528	IF(compare_exch_methods .AND. use_exch_list)THEN
529
530	WRITE (LOG_UNIT, FMT="('Comparing array exch. methods...')")
531
532	IF(PRESENT(r3d1))THEN
533
534	#if defined key_z_first
535	! Store the results of the SIZE calls in variables otherwise ftrans falls
536	! over when dealing with the ALLOCATE call.
537	isize_z = SIZE(r3d1,1)
538	isize_y = SIZE(r3d1,3)
539	isize_x = SIZE(r3d1,2)
540	ALLOCATE(r3dcopy(isize_x, isize_y, isize_z), Stat=ierr)
541	#else
542	ALLOCATE(r3dcopy(SIZE(r3d1,1),SIZE(r3d1,2),SIZE(r3d1,3)), Stat=ierr)
543	#endif
544	IF(ierr == 0)THEN
545	CALL init_test_arrays(testType, r3d1=r3dcopy)
546
547	CALL bound_exch(r3dcopy, jpreci, jpreci, &
548	Iplus, Iminus, Jplus, Jminus, &
549	gridType, isgn=isgn, lfill=lfill)
550
551	CALL compare_arrays(r3d1, r3dcopy)
552	ELSE
553	WRITE (LOG_UNIT, FMT="('ERROR: failed to allocate r3dcopy to compare array exch. methods.')")
554	END IF
555	END IF
556
557	IF(PRESENT(r2d1))THEN
558	ALLOCATE(r2dcopy(SIZE(r2d1,1),SIZE(r2d1,2)), Stat=ierr)
559
560	IF(ierr == 0)THEN
561
562	CALL init_test_arrays(testType, r2d1=r2dcopy)
563
564	CALL bound_exch(r2dcopy, jpreci, jpreci, &
565	Iminus,Jminus,Iplus,Jplus, &
566	gridType, isgn=isgn, lfill=lfill)
567
568	CALL compare_arrays(r2d1, r2dcopy)
569	ELSE
570	WRITE (LOG_UNIT, FMT="('ERROR: failed to allocate r2dcopy to compare array exch. methods.')")
571	END IF
572	END IF
573	END IF
574	#endif
575
576	! Use test_pass as a temporary, logical variable here
577	test_pass = .FALSE.
578	IF(PRESENT(lfill))test_pass = lfill
579
580	SELECT CASE(testType)
581
582	CASE (PE_ID_TEST)
583	WRITE(LOG_UNIT, FMT="('Testing results of exchanging PE IDs')")
584	CASE(GLOBAL_LOCN_TEST)
585	WRITE(LOG_UNIT, FMT="('Testing results of exchanging global coords')")
586	CASE DEFAULT
587	WRITE(LOG_UNIT, FMT="('ERROR: unrecognised test type in exch_test()')")
588	test_pass = .FALSE.
589	RETURN
590	END SELECT
591	WRITE(LOG_UNIT, FMT="((A),' with lfill=',L3,':')") TRIM(descr), test_pass
592
593	test_pass = .TRUE.
594
595	IF( PRESENT(r3d1) )THEN
596	CALL array_check(gridType, testType, depth, r3d=r3d1, lfill=lfill, &
597	stat=hit_error)
598	IF(test_pass)test_pass = .NOT. hit_error
599	END IF
600	IF( PRESENT(r3d2) )THEN
601	CALL array_check(gridType, testType, depth, r3d=r3d2, lfill=lfill, &
602	stat=hit_error)
603	IF(test_pass)test_pass = .NOT. hit_error
604	END IF
605	IF( PRESENT(r3d3) )THEN
606	CALL array_check(gridType, testType, depth, r3d=r3d3, lfill=lfill, &
607	stat=hit_error)
608	IF(test_pass)test_pass = .NOT. hit_error
609	END IF
610	IF( PRESENT(r2d1) )THEN
611	CALL array_check(gridType, testType, depth, r2d=r2d1, lfill=lfill, &
612	stat=hit_error)
613	IF(test_pass)test_pass = .NOT. hit_error
614	END IF
615	IF( PRESENT(r2d2) )THEN
616	CALL array_check(gridType, testType, depth, r2d=r2d2, lfill=lfill, &
617	stat=hit_error)
618	IF(test_pass)test_pass = .NOT. hit_error
619	END IF
620	IF( PRESENT(i2d1) )THEN
621	CALL array_check(gridType, testType, depth, i2d=i2d1, lfill=lfill, &
622	stat=hit_error)
623	IF(test_pass)test_pass = .NOT. hit_error
624	END IF
625	IF( PRESENT(i3d1) )THEN
626	CALL array_check(gridType, testType, depth, i3d=i3d1, lfill=lfill, &
627	stat=hit_error)
628	IF(test_pass)test_pass = .NOT. hit_error
629	END IF
630	IF( PRESENT(i3d2) )THEN
631	CALL array_check(gridType, testType, depth, i3d=i3d2, lfill=lfill, &
632	stat=hit_error)
633	IF(test_pass)test_pass = .NOT. hit_error
634	END IF
635
636	IF(test_pass)THEN
637	WRITE(LOG_UNIT,FMT="('PASS: All arrays OK after exchange.')")
638	ELSE
639	WRITE(LOG_UNIT,FMT="('FAIL: Errors occurred during this exchange (see above).')")
640	! Set module-wide flag to say that test has failed
641	test_failed = .TRUE.
642	END IF
643	WRITE(LOG_UNIT,*)
644
645	END SUBROUTINE exch_test
646
647	!======================================================================
648
649	SUBROUTINE init_test_arrays(testType, &
650	r2d1, r2d2, r3d1, r3d2, r3d3, i2d1, i3d1, i3d2)
651	IMPLICIT none
652	!FTRANS r3d1 :I :I :z
653	!FTRANS r3d2 :I :I :z
654	!FTRANS r3d3 :I :I :z
655	!FTRANS i3d1 :I :I :z
656	!FTRANS i3d2 :I :I :z
657	INTEGER, INTENT(in) :: testType ! Type of test to do
658	REAL (kind=wp), DIMENSION(:,:), INTENT(inout), OPTIONAL :: r2d1,r2d2
659	REAL (kind=wp), DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: r3d1,r3d2,r3d3
660	INTEGER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: i3d1,i3d2
661	INTEGER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: i2d1
662
663	! Initialise array using global coordinates (mig and mjg arrays are
664	! not used here as they've not been set-up yet).
665
666	IF(testType .EQ. GLOBAL_LOCN_TEST)THEN
667	IF( PRESENT(r3d1) )THEN
668	CALL set_by_global_coords_3dr(r3d1)
669	END IF
670	IF( PRESENT(r3d2) )THEN
671	CALL set_by_global_coords_3dr(r3d2)
672	END IF
673	IF( PRESENT(r3d3) )THEN
674	CALL set_by_global_coords_3dr(r3d3)
675	END IF
676	IF( PRESENT(r2d1) )THEN
677	CALL set_by_global_coords_2dr(r2d1)
678	END IF
679	IF( PRESENT(r2d2) )THEN
680	CALL set_by_global_coords_2dr(r2d2)
681	END IF
682	IF( PRESENT(i2d1) )THEN
683	CALL set_by_global_coords_2di(i2d1)
684	END IF
685	IF( PRESENT(i3d1) )THEN
686	CALL set_by_global_coords_3di(i3d1)
687	END IF
688	IF( PRESENT(i3d2) )THEN
689	CALL set_by_global_coords_3di(i3d2)
690	END IF
691	ELSE IF(testType .EQ. PE_ID_TEST)THEN
692	IF(PRESENT(r3d1) )THEN
693	CALL set_by_pe_id_3dr(r3d1)
694	END IF
695	IF(PRESENT(r3d2) )THEN
696	CALL set_by_pe_id_3dr(r3d2)
697	END IF
698	IF(PRESENT(r3d3) )THEN
699	CALL set_by_pe_id_3dr(r3d3)
700	END IF
701	IF(PRESENT(r2d1) )THEN
702	CALL set_by_pe_id_2dr(r2d1)
703	END IF
704	IF(PRESENT(r2d2) )THEN
705	CALL set_by_pe_id_2dr(r2d2)
706	END IF
707	IF( PRESENT(i2d1) )THEN
708	CALL set_by_pe_id_2di(i2d1)
709	END IF
710	IF( PRESENT(i3d1) )THEN
711	CALL set_by_pe_id_3di(i3d1)
712	END IF
713	IF( PRESENT(i3d2) )THEN
714	CALL set_by_pe_id_3di(i3d2)
715	END IF
716	END IF
717
718	END SUBROUTINE init_test_arrays
719
720	!======================================================================
721
722	SUBROUTINE set_by_pe_id_3dr(r3d)
723	USE par_kind, ONLY: wp
724	USE dom_oce, ONLY: narea, nlci, nlcj
725	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
726	IMPLICIT none
727	!FTRANS r3d :I :I :z
728	! Arguments
729	REAL (kind=wp), DIMENSION(:,:,:), INTENT(inout) :: r3d
730
731	! Initialise array with the PE id
732	r3d(:, :, :) = narea
733
734	! Set halos so that they contain negative values. If we do not
735	! have cyclic boundary conditions then there are no halos on the E and W
736	! boundaries of the model domain.
737	IF((.NOT. ilbext) .OR. (ilbext .AND. cyclic_bc) ) r3d(1, :, :) = -narea
738	IF((.NOT. iubext) .OR. (iubext .AND. cyclic_bc) )THEN
739	r3d(nlci:,:,:) = -narea
740	END IF
741
742	! No halos at top and bottom of global domain
743	IF(.not.jlbext)r3d(:,1,:) = -narea
744	IF(.not.jubext)r3d(:,nlcj:,:) = -narea
745
746	END SUBROUTINE set_by_pe_id_3dr
747
748	!======================================================================
749
750	SUBROUTINE set_by_pe_id_2dr(r2d)
751	USE par_kind, ONLY: wp
752	USE dom_oce, ONLY: narea, nlci, nlcj
753	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
754	IMPLICIT none
755	! Arguments
756	REAL (kind=wp), DIMENSION(:,:), INTENT(inout) :: r2d
757
758	! Initialise array with the PE id
759	r2d(:, :) = narea
760
761	! Set halos so that they contain negative values. If we do not
762	! have cyclic boundary conditions then there are no halos on the E and W
763	! boundaries of the model domain.
764	IF((.NOT. ilbext) .OR. (ilbext .AND. cyclic_bc) ) r2d(1, :) = -narea
765	IF((.NOT. iubext) .OR. (iubext .AND. cyclic_bc) )THEN
766	r2d(nlci:,:) = -narea
767	END IF
768
769	! No halos at top and bottom of global domain
770	IF(.not.jlbext)r2d(:,1) = -narea
771	IF(.not.jubext)r2d(:,nlcj:) = -narea
772
773	END SUBROUTINE set_by_pe_id_2dr
774
775	!======================================================================
776
777	SUBROUTINE set_by_pe_id_3di(i3d)
778	USE dom_oce, ONLY: narea, nlci, nlcj
779	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
780	IMPLICIT none
781	!FTRANS i3d :I :I :z
782	! Arguments
783	INTEGER, DIMENSION(:,:,:), INTENT(inout) :: i3d
784
785	! Initialise array with the PE id
786	i3d(:, :, :) = narea
787
788	! Set halos so that they contain negative values. If we do not
789	! have cyclic boundary conditions then there are no halos on the E and W
790	! boundaries of the model domain.
791	IF((.NOT. ilbext) .OR. (ilbext .AND. cyclic_bc) ) i3d(1, :, :) = -narea
792	IF((.NOT. iubext) .OR. (iubext .AND. cyclic_bc) )THEN
793	i3d(nlci:,:,:) = -narea
794	END IF
795
796	! No halos at top and bottom of global domain
797	IF(.not.jlbext)i3d(:,1,:) = -narea
798	IF(.not.jubext)i3d(:,nlcj:,:) = -narea
799
800	END SUBROUTINE set_by_pe_id_3di
801
802	!======================================================================
803
804	SUBROUTINE set_by_pe_id_2di(i2d)
805	USE dom_oce, ONLY: narea, nlci, nlcj
806	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
807	IMPLICIT none
808	! Arguments
809	INTEGER, DIMENSION(:,:), INTENT(inout) :: i2d
810	!!-------------------------------------------------------------------
811
812	! Initialise array with the PE id
813	i2d(:, :) = narea
814
815	! Set halos so that they contain negative values. If we do not
816	! have cyclic boundary conditions then there are no halos on the E and W
817	! boundaries of the model domain.
818	IF((.NOT. ilbext) .OR. (ilbext .AND. cyclic_bc) )i2d(1, :) = -narea
819	IF((.NOT. iubext) .OR. (iubext .AND. cyclic_bc) )THEN
820	i2d(nlci:,:) = -narea
821	END IF
822
823	! No halos at top and bottom of global domain
824	IF(.not.jlbext)i2d(:,1) = -narea
825	IF(.not.jubext)i2d(:,nlcj:) = -narea
826
827	END SUBROUTINE set_by_pe_id_2di
828
829	!======================================================================
830
831	SUBROUTINE set_by_global_coords_3dr(r3d)
832	USE par_kind, ONLY: wp
833	USE par_oce, ONLY: jpi, jpj, jpk, jpreci
834	USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, &
835	nldj, nlej, narea
836	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
837	IMPLICIT none
838	!FTRANS r3d :I :I :z
839	! Arguments
840	REAL (kind=wp), DIMENSION(:,:,:), INTENT(inout) :: r3d
841	! Locals
842	INTEGER :: ik, ij, ii
843	!!-------------------------------------------------------------------
844
845	! Initialise array using global coordinates (mig and mjg arrays are
846	! not used here as they've not been set-up yet).
847	! A correct exchange process (but without north-fold) won't change
848	! these values
849	#if defined key_z_first
850	DO ij=1,jpj,1
851	DO ii=1,jpi,1
852	DO ik=1,jpk,1
853	#else
854	DO ik=1,jpk,1
855	DO ij=1,jpj,1
856	DO ii=1,jpi,1
857	#endif
858	r3d(ii,ij,ik) = REAL( gcoords_to_int(ii,ij,ik) )
859	END DO
860	END DO
861	END DO
862
863	! Set halos so that they contain negative values. If we do not
864	! have cyclic boundary conditions then there are no halos on the E and W
865	! boundaries of the model domain.
866	IF( (.NOT. ilbext) .OR. (ilbext .AND. cyclic_bc) )r3d(1, :, :) = -1.0_wp*r3d(nldi, :, :)
867	IF( (.NOT. iubext) .OR. (iubext .AND. cyclic_bc) )THEN
868	DO ii=nlci,jpi,1
869	r3d(ii,:,:) = -1.0_wp*r3d(nlei, :, :)
870	END DO
871	END IF
872
873	! No halos at top and bottom of global domain
874	IF(.NOT.jlbext)r3d(:,1,:) = -1.0_wp*r3d(:,2,:)
875	IF(.NOT.jubext)THEN
876	DO ij=nlcj, jpj, 1
877	r3d(:,ij,:) = -1.0_wp*r3d(:,nlej,:)
878	END DO
879	END IF
880
881	END SUBROUTINE set_by_global_coords_3dr
882
883	!======================================================================
884
885	SUBROUTINE set_by_global_coords_2dr(r2d)
886	USE par_kind, ONLY: wp
887	USE par_oce, ONLY: jpi, jpj, jpk, jpreci
888	USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, &
889	nldj, nlej
890	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
891	IMPLICIT none
892	REAL (kind=wp), DIMENSION(:,:), INTENT(inout) :: r2d
893	! Locals
894	INTEGER :: ij, ii
895
896	! Initialise array using global coordinates (mig and mjg arrays are
897	! not used here as they've not been set-up yet).
898	! A correct exchange process (but without north-fold) won't change
899	! these values
900	DO ij=nldj,jpj,1
901	DO ii=nldi,jpi,1
902	r2d(ii,ij) = REAL( gcoords_to_int(ii,ij) )
903	END DO
904	END DO
905
906	! Set halos so that they contain negative values. If we do not
907	! have cyclic boundary conditions then there are no halos on the E and W
908	! boundaries of the model domain.
909	IF((.NOT. ilbext) .OR. (ilbext .AND. cyclic_bc) )r2d(1, :) = -1.0*r2d(nldi, :)
910	IF((.NOT. iubext) .OR. (iubext .AND. cyclic_bc) )THEN
911	DO ii=nlci,jpi,1
912	r2d(ii,:) = -1.0*r2d(nlei, :)
913	END DO
914	END IF
915	! No halos at top and bottom of global domain
916	IF(.NOT.jlbext)r2d(:,1) = -1.0_wp*r2d(:,2)
917	IF(.NOT.jubext)THEN
918	DO ij=nlcj, jpj, 1
919	r2d(:,ij) = -1.0*r2d(:,nlej)
920	END DO
921	END IF
922
923	END SUBROUTINE set_by_global_coords_2dr
924
925	!======================================================================
926
927	SUBROUTINE compare_arrays2d(r2d1, r2d2)
928	USE par_kind, ONLY: wp
929	IMPLICIT none
930	REAL (kind=wp), DIMENSION(:,:), INTENT(in) :: r2d1,r2d2
931
932	!WRITE(,) 'compare_arrays2d: IMPLEMENT ME!'
933
934	END SUBROUTINE compare_arrays2d
935
936	!======================================================================
937
938	SUBROUTINE compare_arrays3d(r3d1, r3d2)
939	USE par_kind, ONLY: wp
940	IMPLICIT none
941	REAL (kind=wp), DIMENSION(:,:,:), INTENT(in) :: r3d1,r3d2
942
943	!WRITE(,) 'compare_arrays3d: IMPLEMENT ME!'
944
945	END SUBROUTINE compare_arrays3d
946
947	!======================================================================
948
949	SUBROUTINE exch_timing(gridType, &
950	r2d1, r2d2, &
951	r3d1, r3d2, r3d3, &
952	i2d1, i2d2, i3d1, i3d2, isgn, lfill)
953	USE par_kind, ONLY: wp
954	USE par_oce, ONLY: jpreci
955	USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE
956	USE mpi, ONLY: MPI_COMM_WORLD, MPI_Wtime
957	IMPLICIT none
958	! Arguments
959	CHARACTER(LEN=1), INTENT(in) :: gridType ! Grid on which test being done
960	REAL (kind=wp), DIMENSION(:,:), INTENT(inout), OPTIONAL :: r2d1,r2d2
961	REAL (kind=wp), DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: r3d1,r3d2,r3d3
962	INTEGER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: i3d1,i3d2
963	INTEGER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: i2d1,i2d2
964	INTEGER, INTENT(in), OPTIONAL :: isgn
965	LOGICAL, INTENT(in), OPTIONAL :: lfill
966	! Local vars
967	INTEGER :: iloop, narrays
968	REAL :: t1, t2, ttaken, speed
969	INTEGER :: nr3darrays, nr2darrays, ni3darrays, ni2darrays
970	LOGICAL :: lfilllocal
971	CHARACTER(LEN=200) :: fmtString
972
973	IF(PRESENT(lfill))THEN
974	lfilllocal = lfill
975	ELSE
976	lfilllocal = .FALSE.
977	END IF
978
979	narrays = 0
980	nr3darrays = 0
981	nr2darrays = 0
982	ni3darrays = 0
983	ni2darrays = 0
984
985	IF(PRESENT(r3d1) )THEN
986	CALL set_by_pe_id_3dr(r3d1)
987	nr3darrays = nr3darrays + 1
988	END IF
989	IF(PRESENT(r3d2) )THEN
990	CALL set_by_pe_id_3dr(r3d2)
991	nr3darrays = nr3darrays + 1
992	END IF
993	IF(PRESENT(r3d3) )THEN
994	CALL set_by_pe_id_3dr(r3d3)
995	nr3darrays = nr3darrays + 1
996	END IF
997	IF(PRESENT(r2d1) )THEN
998	CALL set_by_pe_id_2dr(r2d1)
999	nr2darrays = nr2darrays +1
1000	END IF
1001	IF(PRESENT(r2d2) )THEN
1002	CALL set_by_pe_id_2dr(r2d2)
1003	nr2darrays = nr2darrays +1
1004	END IF
1005	IF( PRESENT(i2d1) )THEN
1006	CALL set_by_pe_id_2di(i2d1)
1007	ni2darrays = ni2darrays +1
1008	END IF
1009	IF( PRESENT(i2d2) )THEN
1010	CALL set_by_pe_id_2di(i2d2)
1011	ni2darrays = ni2darrays +1
1012	END IF
1013	IF( PRESENT(i3d1) )THEN
1014	CALL set_by_pe_id_3di(i3d1)
1015	ni3darrays = ni3darrays +1
1016	END IF
1017	IF( PRESENT(i3d2) )THEN
1018	CALL set_by_pe_id_3di(i3d2)
1019	ni3darrays = ni3darrays +1
1020	END IF
1021
1022	narrays = nr3darrays + nr2darrays + ni3darrays + ni2darrays
1023
1024	IF(use_exch_list)THEN
1025
1026	CALL time_packed_exch(ttaken, gridType, &
1027	r2d1=r2d1, r2d2=r2d2, &
1028	r3d1=r3d1, r3d2=r3d2, r3d3=r3d3, &
1029	i2d1=i2d1, i2d2=i2d2, &
1030	i3d1=i3d1, i3d2=i3d2, &
1031	isgn=isgn, lfill=lfill)
1032
1033	#ifdef key_mpp_mpi
1034	IF (ttaken > 0.0D0) THEN
1035	speed = dble(loops_to_time*narrays)/ttaken
1036	ELSE
1037	speed = 0.0D0
1038	END IF
1039
1040	! This format string exceeds the maximum fortran line length and must
1041	! therefore be broken up. However, using the concatenation operator
1042	! 'in place' within the write statement has nasty side effects on the
1043	! Cray XE with the cray compiler (maybe stack related?). Therefore we
1044	! use fmtString as a temporary variable to construct the string.
1045	fmtString = ""
1046	fmtString = "(I6,'*(',I1,' 2Di,',I1,' 3Di,',I1,' 2Dr,',I1,' 3Dr) "// &
1047	"packd exchs at ',A,' in ',F10.6,'s, ',F10.1,' arr ex/s, lfill = ',L1)"
1048	WRITE (LOG_UNIT, TRIM(fmtString)) &
1049	loops_to_time,ni2darrays,ni3darrays,nr2darrays,nr3darrays,gridType,&
1050	ttaken,speed, lfilllocal
1051	#endif
1052	ELSE
1053	WRITE (LOG_UNIT, "('Packed exchanges not timed because exchange lists switched off in exchtestmod.F90')")
1054	END IF
1055
1056	CALL time_indiv_exch(ttaken, gridType, &
1057	r2d1=r2d1, r2d2=r2d2, &
1058	r3d1=r3d1, r3d2=r3d2, r3d3=r3d3, &
1059	i2d1=i2d1, i2d2=i2d2, &
1060	i3d1=i3d1, i3d2=i3d2, &
1061	isgn=isgn, lfill=lfill)
1062
1063	#ifdef key_mpp_mpi
1064	IF (ttaken > 0.0D0) THEN
1065	speed = dble(loops_to_time*narrays)/ttaken
1066	ELSE
1067	speed = 0.0D0
1068	END IF
1069
1070	! See comment on first use of fmtString above.
1071	fmtString = ""
1072	fmtString = "(I6,'*(',I1,' 2Di,',I1,' 3Di,',I1,' 2Dr,',I1,' 3Dr) "// &
1073	"indiv. exchanges at ',A,' in ',F10.6,'s, ',F10.1,' array exch/s, lfill = ',L1)"
1074	WRITE (LOG_UNIT, TRIM(fmtString)) &
1075	loops_to_time,ni2darrays,ni3darrays,nr2darrays,nr3darrays,gridType,&
1076	ttaken,speed, lfilllocal
1077	!!$ WRITE (LOG_UNIT,"(I6,'*(',I1,' 2Di,',I1,' 3Di,',I1,' 2Dr,',I1,' 3Dr) "// &
1078	!!$"indiv. exchanges at ',A,' in ',F10.6,'s, ',F10.1,' array exch/s, lfill = ',L1)") &
1079	!!$ loops_to_time,ni2darrays,ni3darrays,nr2darrays,nr3darrays,gridType,&
1080	!!$ ttaken,speed, lfilllocal
1081	#endif
1082
1083	END SUBROUTINE exch_timing
1084
1085	!======================================================================
1086
1087	SUBROUTINE time_packed_exch(ttaken, gridType, &
1088	r2d1, r2d2, &
1089	r3d1, r3d2, r3d3, &
1090	i2d1, i2d2, i3d1, i3d2, &
1091	isgn, lfill)
1092	USE par_kind, ONLY: wp
1093	USE par_oce, ONLY: jpreci
1094	USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE
1095	USE exchmod, ONLY: add_exch, bound_exch_list
1096	USE mpi, ONLY: MPI_COMM_WORLD, MPI_Wtime
1097	IMPLICIT none
1098	! Arguments
1099	REAL (kind=wp), INTENT(out) :: ttaken
1100	CHARACTER(LEN=1), INTENT(in) :: gridType ! Grid on which test being done
1101	REAL (kind=wp), DIMENSION(:,:), INTENT(inout), OPTIONAL :: r2d1,r2d2
1102	REAL (kind=wp), DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: r3d1,r3d2,r3d3
1103	INTEGER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: i3d1,i3d2
1104	INTEGER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: i2d1,i2d2
1105	INTEGER, INTENT(in), OPTIONAL :: isgn
1106	LOGICAL, INTENT(in), OPTIONAL :: lfill
1107	! Local vars
1108	REAL :: t1, t2
1109	INTEGER :: iloop, ierror
1110
1111	#if ! defined key_mpp_rkpart
1112	ttaken = 0.0
1113	RETURN
1114	#endif
1115
1116	#ifdef key_mpp_mpi
1117	CALL MPI_barrier(MPI_comm_world, ierror)
1118	t1 = MPI_wtime()
1119	#endif
1120
1121	DO iloop = 1, loops_to_time, 1
1122
1123	IF(PRESENT(r3d1))THEN
1124	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r3d=r3d1, &
1125	isgn=isgn, lfill=lfill)
1126	END IF
1127	IF(PRESENT(r3d2))THEN
1128	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r3d=r3d2, &
1129	isgn=isgn, lfill=lfill)
1130	END IF
1131	IF(PRESENT(r3d3))THEN
1132	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r3d=r3d3, &
1133	isgn=isgn, lfill=lfill)
1134	END IF
1135	IF(PRESENT(r2d1))THEN
1136	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r2d=r2d1, &
1137	isgn=isgn, lfill=lfill)
1138	END IF
1139	IF(PRESENT(r2d2))THEN
1140	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, r2d=r2d2, &
1141	isgn=isgn, lfill=lfill)
1142	END IF
1143	IF( PRESENT(i2d1) )THEN
1144	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, i2d=i2d1, &
1145	isgn=isgn, lfill=lfill)
1146	END IF
1147	IF( PRESENT(i2d2) )THEN
1148	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, i2d=i2d2, &
1149	isgn=isgn, lfill=lfill)
1150	END IF
1151	IF( PRESENT(i3d1) )THEN
1152	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, i3d=i3d1, &
1153	isgn=isgn, lfill=lfill)
1154	END IF
1155	IF( PRESENT(i3d2) )THEN
1156	CALL add_exch(jpreci, gridType, Iminus,Jminus,Iplus,Jplus, i3d=i3d2, &
1157	isgn=isgn, lfill=lfill)
1158	END IF
1159
1160	CALL bound_exch_list()
1161
1162	END DO
1163
1164	#ifdef key_mpp_mpi
1165	t2 = MPI_wtime()
1166	ttaken = t2-t1
1167	#endif
1168
1169	END SUBROUTINE time_packed_exch
1170
1171	!======================================================================
1172
1173	SUBROUTINE time_indiv_exch(ttaken, gridType, &
1174	r2d1, r2d2, &
1175	r3d1, r3d2, r3d3, &
1176	i2d1, i2d2, i3d1, i3d2, &
1177	isgn, lfill)
1178	USE par_kind, ONLY: wp
1179	USE par_oce, ONLY: jpreci
1180	USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE
1181	USE exchmod, ONLY: bound_exch
1182	USE lbclnk, ONLY: lbc_lnk
1183	USE mpi, ONLY: MPI_COMM_WORLD, MPI_Wtime
1184	IMPLICIT none
1185	! Arguments
1186	REAL (kind=wp), INTENT(out) :: ttaken
1187	CHARACTER(LEN=1), INTENT(in) :: gridType ! Grid on which test being done
1188	REAL (kind=wp), DIMENSION(:,:), INTENT(inout), OPTIONAL :: r2d1,r2d2
1189	REAL (kind=wp), DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: r3d1,r3d2,r3d3
1190	INTEGER, DIMENSION(:,:,:), INTENT(inout), OPTIONAL :: i3d1,i3d2
1191	INTEGER, DIMENSION(:,:), INTENT(inout), OPTIONAL :: i2d1,i2d2
1192	INTEGER, INTENT(in), OPTIONAL :: isgn
1193	LOGICAL, INTENT(in), OPTIONAL :: lfill
1194	! Local vars
1195	REAL :: t1, t2, psgn
1196	INTEGER :: iloop, ierror
1197
1198	#ifdef key_mpp_mpi
1199	CALL MPI_barrier(MPI_comm_world, ierror)
1200	t1 = MPI_wtime()
1201	#endif
1202
1203	indiv_timing: DO iloop = 1, loops_to_time, 1
1204
1205	IF(PRESENT(r3d1))THEN
1206	#if defined key_mpp_rkpart
1207	CALL bound_exch(r3d1, jpreci, jpreci, &
1208	Iplus, Iminus, Jplus, Jminus, &
1209	gridType, isgn=isgn, lfill=lfill)
1210	#else
1211	! psgn is NOT an optional argument to lbc_lnk
1212	psgn = 1.0_wp
1213	IF( PRESENT(isgn) )psgn=REAL(isgn)
1214	CALL lbc_lnk(r3d1, gridType, psgn)
1215	#endif
1216	END IF
1217	IF(PRESENT(r3d2))THEN
1218	#if defined key_mpp_rkpart
1219	CALL bound_exch(r3d2, jpreci, jpreci, &
1220	Iplus, Iminus, Jplus, Jminus, &
1221	gridType, isgn=isgn, lfill=lfill)
1222	#endif
1223	END IF
1224	IF(PRESENT(r3d3))THEN
1225	#if defined key_mpp_rkpart
1226	CALL bound_exch(r3d3, jpreci, jpreci, &
1227	Iplus, Iminus, Jplus, Jminus, &
1228	gridType, isgn=isgn, lfill=lfill)
1229	#endif
1230	END IF
1231	IF(PRESENT(r2d1))THEN
1232	#if defined key_mpp_rkpart
1233	CALL bound_exch(r2d1, jpreci, jpreci, &
1234	Iplus, Iminus, Jplus, Jminus, &
1235	gridType, isgn=isgn, lfill=lfill)
1236	#else
1237	! psgn is NOT an optional argument to lbc_lnk
1238	psgn = 1.0_wp
1239	IF( PRESENT(isgn) )psgn=REAL(isgn)
1240	CALL lbc_lnk(r2d1, gridType, psgn)
1241	#endif
1242	END IF
1243	IF(PRESENT(r2d2))THEN
1244	#if defined key_mpp_rkpart
1245	CALL bound_exch(r2d2, jpreci, jpreci, &
1246	Iplus, Iminus, Jplus, Jminus, &
1247	gridType, isgn=isgn, lfill=lfill)
1248	#else
1249	! psgn is NOT an optional argument to lbc_lnk
1250	psgn = 1.0_wp
1251	IF( PRESENT(isgn) )psgn=REAL(isgn)
1252	CALL lbc_lnk(r2d2, gridType, psgn)
1253	#endif
1254	END IF
1255	IF( PRESENT(i2d1) )THEN
1256	#if defined key_mpp_rkpart
1257	CALL bound_exch(i2d1, jpreci, jpreci, &
1258	Iplus, Iminus, Jplus, Jminus, &
1259	gridType, isgn=isgn, lfill=lfill)
1260	#endif
1261	END IF
1262	IF( PRESENT(i2d2) )THEN
1263	#if defined key_mpp_rkpart
1264	CALL bound_exch(i2d2, jpreci, jpreci, &
1265	Iplus, Iminus, Jplus, Jminus, &
1266	gridType, isgn=isgn, lfill=lfill)
1267	#endif
1268	END IF
1269	IF( PRESENT(i3d1) )THEN
1270	#if defined key_mpp_rkpart
1271	CALL bound_exch(i3d1, jpreci, jpreci, &
1272	Iplus, Iminus, Jplus, Jminus, &
1273	gridType, isgn=isgn, lfill=lfill)
1274	#endif
1275	END IF
1276	IF( PRESENT(i3d2) )THEN
1277	#if defined key_mpp_rkpart
1278	CALL bound_exch(i3d2, jpreci, jpreci, &
1279	Iplus, Iminus, Jplus, Jminus, &
1280	gridType, isgn=isgn, lfill=lfill)
1281	#endif
1282	END IF
1283
1284	END DO indiv_timing
1285
1286	#ifdef key_mpp_mpi
1287	t2 = MPI_wtime()
1288	ttaken = t2-t1
1289	#endif
1290
1291	END SUBROUTINE time_indiv_exch
1292
1293	!======================================================================
1294
1295	SUBROUTINE set_by_global_coords_3di(i3d)
1296	USE par_kind, ONLY: wp
1297	USE par_oce, ONLY: jpi, jpj, jpk, jpreci
1298	USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, &
1299	nldj, nlej
1300	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
1301	IMPLICIT none
1302	!FTRANS i3d :I :I :z
1303	! Arguments
1304	INTEGER, DIMENSION(:,:,:), INTENT(inout) :: i3d
1305	! Locals
1306	INTEGER :: ik, ij, ii
1307
1308	! Initialise array using global coordinates (mig and mjg arrays are
1309	! not used here as they've not been set-up yet).
1310	! A correct exchange process (but without north-fold) won't change
1311	! these values
1312	#if defined key_z_first
1313	DO ij=nldj,jpj,1
1314	DO ii=nldi,jpi,1
1315	DO ik=1,jpk,1
1316	#else
1317	DO ik=1,jpk,1
1318	DO ij=nldj,jpj,1
1319	DO ii=nldi,jpi,1
1320	#endif
1321	i3d(ii,ij,ik) = gcoords_to_int(ii,ij,ik)
1322	END DO
1323	END DO
1324	END DO
1325
1326	! Set halos so that they contain negative values. If we do not
1327	! have cyclic boundary conditions then there are no halos on the E and W
1328	! boundaries of the model domain.
1329	IF((.NOT. ilbext) .OR. (ilbext .AND. cyclic_bc) )i3d(1, :, :) = -1*i3d(nldi, :, :)
1330	IF((.NOT. iubext) .OR. (iubext .AND. cyclic_bc) )THEN
1331	DO ii=nlci,jpi,1
1332	i3d(ii,:,:) = -1*i3d(nlei, :, :)
1333	END DO
1334	END IF
1335
1336	! No halos at top and bottom of global domain
1337	IF(.not.jlbext)i3d(:,1,:) = -1*i3d(:,2,:)
1338	IF(.not.jubext)THEN
1339	DO ij=nlcj, jpj, 1
1340	i3d(:,ij,:) = -1*i3d(:,nlej,:)
1341	END DO
1342	END IF
1343
1344	END SUBROUTINE set_by_global_coords_3di
1345
1346	!======================================================================
1347
1348	SUBROUTINE set_by_global_coords_2di(i2d)
1349	USE par_kind, ONLY: wp
1350	USE par_oce, ONLY: jpi, jpj, jpk, jpreci
1351	USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, &
1352	nldj, nlej
1353	USE mapcomm_mod, ONLY: ilbext, iubext, jlbext, jubext
1354	IMPLICIT none
1355	! Arguments
1356	INTEGER, DIMENSION(:,:), INTENT(inout) :: i2d
1357	! Locals
1358	INTEGER :: ij, ii
1359
1360	! Initialise array using global coordinates (mig and mjg arrays are
1361	! not used here as they've not been set-up yet).
1362	! A correct exchange process (but without north-fold) won't change
1363	! these values
1364	DO ij=nldj,jpj,1
1365	DO ii=nldi,jpi,1
1366	i2d(ii,ij) = gcoords_to_int(ii,ij)
1367	END DO
1368	END DO
1369
1370	! Set halos so that they contain negative values
1371	i2d(1, :) = -1*i2d(nldi, :)
1372	DO ii=nlci,jpi,1
1373	i2d(ii,:) = -1*i2d(nlei, :)
1374	END DO
1375	! No halos at top and bottom of global domain
1376	IF(.not.jlbext)i2d(:,1) = -1*i2d(:,2)
1377	IF(.not.jubext)THEN
1378	DO ij=nlcj, jpj, 1
1379	i2d(:,ij) = -1*i2d(:,nlej)
1380	END DO
1381	END IF
1382
1383	END SUBROUTINE set_by_global_coords_2di
1384
1385	!======================================================================
1386
1387	SUBROUTINE array_check(gridType, testType, depth, r2d, r3d, i2d, i3d, &
1388	lfill, stat)
1389	USE par_kind, ONLY: wp
1390	USE par_oce, ONLY: jpi, jpj, jpk, jpreci, jpiglo
1391	USE dom_oce, ONLY: nlci, nldi, nlei, nldj, nlej, nimpp, njmpp, narea
1392	USE mapcomm_mod, ONLY: jlbext, jubext, ilbext, iubext
1393	USE exchmod, ONLY: num_nfold_rows
1394	IMPLICIT none
1395	!FTRANS r3d :I :I :z
1396	!FTRANS i3d :I :I :z
1397	! Arguments
1398	CHARACTER(LEN=1), INTENT(in) :: gridType
1399	INTEGER, INTENT(in) :: testType
1400	INTEGER, DIMENSION(:,:), INTENT(in) :: depth ! Global land mask
1401	REAL (kind=wp), DIMENSION(:,:), INTENT(in), OPTIONAL :: r2d
1402	REAL (kind=wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: r3d
1403	INTEGER, DIMENSION(:,:), INTENT(in), OPTIONAL :: i2d
1404	INTEGER, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: i3d
1405	LOGICAL, INTENT(in), OPTIONAL :: lfill
1406	LOGICAL, INTENT(out) :: stat
1407	! Locals
1408	INTEGER :: ik, ij, ii, ipt
1409	LOGICAL :: hit_error, local_lfill
1410	INTEGER :: gVal, jstart, jstop, istart, istop
1411	REAL (kind=wp), PARAMETER :: TOL_ZERO = 1.0e-6
1412
1413	hit_error = .FALSE.
1414
1415	IF(PRESENT(lfill))THEN
1416	local_lfill = lfill
1417	ELSE
1418	local_lfill = .FALSE.
1419	END IF
1420
1421	WRITE (LOG_UNIT, &
1422	FMT="('array_check: grid = ',A,' test = ',I1, ' lfill = ',L1)") &
1423	gridType, testType, local_lfill
1424
1425	! Exclude halos either side of GLOBAL domain because of cyclic
1426	! B.C.'s
1427	istart = 1
1428	! Halos at either side of simulation domain are zeroed if the domain
1429	! is closed and lfill is false.
1430	IF( ilbext .AND. (.NOT. local_lfill) .AND. (.NOT. cyclic_bc) )istart = 2
1431	!IF(ilbext .AND. cyclic_bc)istart = 2
1432	istop = nlci
1433	IF( iubext .AND. (.NOT. local_lfill) .AND. (.NOT. cyclic_bc) )istop = nlci-1
1434	! IF(iubext .AND. cyclic_bc)istop = nlci - 1
1435
1436	! No halos at top and bottom of GLOBAL domain
1437	jstart = nldj
1438	IF(jlbext)THEN
1439	IF(local_lfill)THEN
1440	jstart = 1
1441	ELSE
1442	jstart = 2 ! Bottom row of global domain is set to zero
1443	! when lfill is false.
1444	END IF
1445	END IF
1446
1447	jstop = nlej
1448	IF(jubext)THEN
1449	IF(local_lfill)THEN
1450	jstop = nlej
1451	ELSE
1452	! If lfill isn't true then the north-fold condition is applied
1453	! and our simple test will fail so exclude any affected rows
1454	jstop = nlej - num_nfold_rows
1455	END IF
1456	END IF
1457
1458	! Now the tests themselves...
1459
1460	IF( PRESENT(r3d) )THEN
1461
1462	! Halo on W edge of model domain is zeroed when lfill is false and
1463	! domain is closed (no cyclic b.c.)
1464	IF( (.NOT. local_lfill) .AND. ilbext .AND. (.NOT. trimmed(widx,narea)) &
1465	.AND. (.NOT. cyclic_bc) )THEN
1466
1467	#if defined key_z_first
1468	DO ij = 1, jpj, 1
1469	DO ii=1,nldi-1,1
1470	DO ik=1,jpk,1
1471	#else
1472	DO ik=1,jpk,1
1473	DO ij = 1, jpj, 1
1474	DO ii=1,nldi-1,1
1475	#endif
1476	IF( ABS(depth(ii+nimpp-1,ij+njmpp-1)*r3d(ii,ij,ik)) > TOL_ZERO)THEN
1477	hit_error = .TRUE.
1478	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',F10.0, ' NOT zero')") &
1479	#if defined key_z_first
1480	narea-1, gridType, ik, ii, ij, r3d(ii, 1, ik)
1481	#else
1482	narea-1, gridType, ii, ij, ik, r3d(ii, 1, ik)
1483	#endif
1484	END IF
1485	END DO
1486	END DO
1487	END DO
1488	END IF
1489
1490	! Halo on E edge of model domain is zeroed when lfill is false and
1491	! domain is closed (no cyclic b.c.)
1492	IF( (.NOT. local_lfill) .AND. iubext .AND. (.NOT. trimmed(eidx,narea)) &
1493	.AND. (.NOT. cyclic_bc) )THEN
1494
1495	#if defined key_z_first
1496	DO ij = 1, jpj, 1
1497	DO ii=nlei+1,jpi,1
1498	DO ik=1,jpk,1
1499	#else
1500	DO ik=1,jpk,1
1501	DO ij = 1, jpj, 1
1502	DO ii=nlei+1,jpi,1
1503	#endif
1504	IF( ABS(depth(ii+nimpp-1,ij+njmpp-1)*r3d(ii,ij,ik)) > TOL_ZERO )THEN
1505	hit_error = .TRUE.
1506	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',F10.0, ' NOT zero')") &
1507	#if defined key_z_first
1508	narea-1, gridType, ik, ii, ij, r3d(ii, ij, ik)
1509	#else
1510	narea-1, gridType, ii, ij, ik, r3d(ii, ij, ik)
1511	#endif
1512	END IF
1513	END DO
1514	END DO
1515	END DO
1516	END IF
1517
1518	! Our code initialises halo regions to negative values. After a
1519	! successful halo swap there should be no negative values anywhere.
1520	#if defined key_z_first
1521	DO ij = jstart, jstop, 1
1522	DO ii=1,jpi,1
1523	DO ik = 1, jpk, 1
1524	#else
1525	DO ik = 1, jpk, 1
1526	DO ij = jstart, jstop, 1
1527	DO ii=1,jpi,1
1528	#endif
1529	IF(ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1))THEN
1530	IF( depth(ii+nimpp-1,ij+njmpp-1)*r3d(ii,ij,ik) < 0.0 )THEN
1531	hit_error = .TRUE.
1532	WRITE(LOG_UNIT, &
1533	FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',F10.0)") &
1534	#if defined key_z_first
1535	narea-1, gridType, ik, ii, ij, r3d(ii, ij, ik)
1536	#else
1537	narea-1, gridType, ii, ij, ik, r3d(ii, ij, ik)
1538	#endif
1539	END IF
1540	END IF
1541	END DO
1542	END DO
1543	END DO
1544
1545	IF(testType .eq. GLOBAL_LOCN_TEST)THEN
1546
1547	WRITE(LOG_UNIT, *) 'istart, istop = ',istart, istop
1548	WRITE(LOG_UNIT, *) 'jstart, jstop = ',jstart, jstop
1549
1550	DO ik=1,jpk,1
1551	DO ij=jstart,jstop,1
1552	DO ii=istart,istop,1
1553
1554	IF(ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1))THEN
1555
1556	ipt = ii+nimpp-1
1557	! Treat halo regions on E/W edges of global domain
1558	! with care when cyclic boundary conditions are
1559	! enabled.
1560	IF(cyclic_bc)THEN
1561	IF( (ii+nimpp-1) == jpiglo )THEN
1562	! Eastern edge of global domain - this halo
1563	! should therefore contain values from the
1564	! first non-halo column on the Western edge.
1565	ipt = 2
1566	ELSE IF( (ii+nimpp-1) == 1 )THEN
1567	! Western edge of global domain - this halo
1568	! should therefore contain values from the
1569	! last non-halo column on the Eastern edge.
1570	ipt = jpiglo-1
1571	END IF
1572	END IF
1573
1574	gval = gcoords_to_int(ipt, (ij+njmpp-1), ik, &
1575	are_global=.TRUE.)
1576
1577	! depth is the mask for the whole simulation domain so
1578	! must convert from local to domain coordinates
1579	IF( (depth(ii+nimpp-1,ij+njmpp-1) > 0) .AND. &
1580	(INT(r3d(ii,ij,ik)) /= gVal) )THEN
1581
1582	WRITE(LOG_UNIT, &
1583	FMT="(I4,': ERROR: ',A1,' pt, r3d(',2(I3,','),I3,') = ',I10.9,' /= gVal = ',I10.9)") &
1584	#if defined key_z_first
1585	narea-1, gridType, ik, ii, ij, &
1586	#else
1587	narea-1, gridType, ii, ij, ik, &
1588	#endif
1589	INT(r3d(ii, ij, ik)), gVal
1590	WRITE (LOG_UNIT,"(I4,': depth(',I3,',',I3,') = ',I2,' bot. level = ',I3)") &
1591	narea-1, ii+nimpp-1,ij+njmpp-1, &
1592	depth(ii+nimpp-1,ij+njmpp-1), &
1593	pmaxdepth(ii+nimpp-1,ij+njmpp-1)
1594
1595	hit_error = .TRUE.
1596	END IF
1597	END IF
1598
1599	END DO
1600	END DO
1601
1602	END DO
1603
1604	END IF ! testType == GLOBAL_LOCN_TEST
1605
1606	END IF ! PRESENT(r3d)
1607
1608	IF( PRESENT(r2d) )THEN
1609
1610	DO ij = jstart, jstop, 1
1611	DO ii=1,jpi,1
1612	IF( depth(ii,ij)*r2d(ii,ij) < 0.0 )THEN
1613	hit_error = .TRUE.
1614	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, r2d(',I3,',',I3,') = ',F10.0)") &
1615	narea-1, gridType, ii, ij, r2d(ii, ij)
1616	END IF
1617	END DO
1618	END DO
1619
1620	IF(testType .eq. GLOBAL_LOCN_TEST)THEN
1621
1622	DO ij=jstart, jstop, 1
1623	DO ii=istart, istop, 1
1624
1625	ipt = ii+nimpp-1
1626	! Treat halo regions on E/W edges of global domain
1627	! with care when cyclic boundary conditions are
1628	! enabled.
1629	IF(cyclic_bc)THEN
1630	IF( (ii+nimpp-1) == jpiglo )THEN
1631	! Eastern edge of global domain - this halo
1632	! should therefore contain values from the
1633	! first non-halo column on the Western edge.
1634	ipt = 2
1635	ELSE IF( (ii+nimpp-1) == 1 )THEN
1636	! Western edge of global domain - this halo
1637	! should therefore contain values from the
1638	! last non-halo column on the Eastern edge.
1639	ipt = jpiglo-1
1640	END IF
1641	END IF
1642
1643	gval = gcoords_to_int(ipt, (ij+njmpp-1), &
1644	are_global=.TRUE.)
1645
1646	! gval = gcoords_to_int(ii,ij)
1647
1648	IF( (depth(ii+nimpp-1,ij+njmpp-1) > 0) .AND. &
1649	(INT(r2d(ii,ij)) /= gval) )THEN
1650	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, r2d(',I3,',',I3,') = ',I7.6,' /= gVal = ',I7.6)") &
1651	narea-1, gridType, ii, ij, INT(r2d(ii, ij)), gVal
1652	hit_error = .TRUE.
1653	END IF
1654	END DO
1655	END DO
1656
1657	END IF ! testType == GLOBAL_LOCN_TEST
1658
1659	END IF ! PRESENT(r2d)
1660
1661	IF( PRESENT(i3d) )THEN
1662
1663	IF( ANY( MASK=(i3d(1:jpi,jstart:jstop,1:jpk) < 0.0) ) )THEN
1664	hit_error = .TRUE.
1665
1666	DO ik=1,jpk,1
1667	DO ij=jstart,jstop,1
1668	DO ii=1,jpi,1
1669	IF( (i3d(ii,ij,ik) < 0.0) .AND. &
1670	(ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1)) )THEN
1671
1672	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, i3d(',2(I3,','),I3,') = ',I10.9)") &
1673	#if defined key_z_first
1674	narea-1, gridType, ik, ii, ij, i3d(ii, ij, ik)
1675	#else
1676	narea-1, gridType, ii, ij, ik, i3d(ii, ij, ik)
1677	#endif
1678	END IF
1679	END DO
1680	END DO
1681	END DO
1682	END IF ! any array values negative
1683
1684	IF(testType == GLOBAL_LOCN_TEST)THEN
1685
1686	WRITE(LOG_UNIT, *) 'istart, istop = ',istart, istop
1687	WRITE(LOG_UNIT, *) 'jstart, jstop = ',jstart, jstop
1688
1689	DO ik=1,jpk,1
1690
1691	DO ij=jstart,jstop,1
1692	DO ii=istart,istop,1
1693	gval = gcoords_to_int(ii,ij,ik)
1694	IF( (i3d(ii,ij,ik) /= gval) .AND. &
1695	(ik <= pmaxdepth(ii+nimpp-1,ij+njmpp-1)) )THEN
1696	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, i3d(',2(I3,','),I3,') = ',I10.9,' /= gVal = ',I10.9)") &
1697	#if defined key_z_first
1698	narea-1, gridType, ik, ii, ij, &
1699	#else
1700	narea-1, gridType, ii, ij, ik, &
1701	#endif
1702	i3d(ii, ij, ik), gVal
1703	hit_error = .TRUE.
1704	END IF
1705	END DO
1706	END DO
1707
1708	END DO
1709	END IF ! testType == GLOBAL_LOCN_TEST
1710
1711	END IF ! PRESENT(i3d)
1712
1713	IF( PRESENT(i2d) )THEN
1714
1715	IF( ANY( MASK=(i2d(1:jpi,jstart:jstop) < 0.0) ) )THEN
1716	hit_error = .TRUE.
1717
1718	DO ij=jstart,jstop,1
1719	DO ii=1,jpi,1
1720	IF(i2d(ii,ij) < 0.0)THEN
1721	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, i2d(',I3,',',I3,') = ',I10.9)") &
1722	narea-1, gridType, ii, ij, i2d(ii, ij)
1723	END IF
1724	END DO
1725	END DO
1726	END IF ! any array values negative
1727
1728	IF(testType == GLOBAL_LOCN_TEST)THEN
1729
1730	WRITE(LOG_UNIT, *) 'istart, istop = ',istart, istop
1731	WRITE(LOG_UNIT, *) 'jstart, jstop = ',jstart, jstop
1732
1733	DO ij=jstart,jstop,1
1734	DO ii=istart,istop,1
1735
1736	gval = gcoords_to_int(ii,ij,ik )
1737	IF(i2d(ii,ij) /= gval)THEN
1738	WRITE (LOG_UNIT,FMT="(I4,': ERROR: ',A1,' pt, i2d(',I3,',',I3,') = ',I10.9,' /= gVal = ',I10.9)") &
1739	narea-1, gridType, ii, ij, &
1740	i2d(ii, ij), gVal
1741	hit_error = .TRUE.
1742	END IF
1743	END DO
1744	END DO
1745
1746	END IF ! testType == GLOBAL_LOCN_TEST
1747
1748	END IF ! PRESENT(i2d)
1749
1750	stat=hit_error
1751
1752	END SUBROUTINE array_check
1753
1754	FUNCTION gcoords_to_int(ii, ij, ik, are_global) RESULT(value)
1755	USE dom_oce, ONLY: nimpp, njmpp, nldi, nldj
1756	IMPLICIT None
1757	! Convert the specified coordinates in the local domain into global
1758	! coordinates and encode into a single integer number.
1759	INTEGER, INTENT(in) :: ii, ij
1760	INTEGER, INTENT(in), OPTIONAL :: ik
1761	LOGICAL, INTENT(in), OPTIONAL :: are_global ! Whether input coordinates
1762	! are already global rather
1763	! than just relative to local
1764	! domain
1765	! Locals
1766	INTEGER :: value
1767	LOGICAL :: lglobal
1768	!!====================================================================
1769
1770	lglobal = .FALSE.
1771	IF( PRESENT(are_global) )lglobal = are_global
1772
1773	IF(lglobal)THEN
1774	! ii and ij are already global coordinates
1775	value = ii*1000000 + &
1776	ij*1000
1777	ELSE
1778	value = (ii + nimpp - 1)*1000000 + &
1779	(ij + njmpp - 1)*1000
1780	END IF
1781
1782	IF(PRESENT(ik))THEN
1783	value = value + ik
1784	END IF
1785
1786	END FUNCTION gcoords_to_int
1787
1788
1789	END MODULE exchtestmod

Note: See TracBrowser for help on using the repository browser.

Download in other formats: