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

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

Last change on this file since 3432 was 3432, checked in by trackstand2, 12 years ago

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