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

Last change on this file since 4400 was 4400, checked in by trackstand2, 7 years ago

Replace jpk with jpkf in bound_exch_generic. Turn on test timing of exchanges

File size: 61.1 KB
Line 
1MODULE 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
64CONTAINS
65
66  !====================================================================
67
68  SUBROUTINE mpp_test_comms(depth, lmaxdepth)
69    USE par_oce,      ONLY: jpi, jpj, jpk, 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,jpk), r3d_2(jpi,jpj,jpk), r3d_3(jpi,jpj,jpk), &
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,jpk), i3d_2(jpi,jpj,jpk), &
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
1789END MODULE exchtestmod
Note: See TracBrowser for help on using the repository browser.