source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/ICB/icblbc.F90 @ 10297

Last change on this file since 10297 was 10297, checked in by smasson, 23 months ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 2a: add report calls of mppmin/max/sum, see #2133

  • Property svn:keywords set to Id
File size: 40.0 KB
Line 
1MODULE icblbc
2   !!======================================================================
3   !!                       ***  MODULE  icblbc  ***
4   !! Ocean physics:  routines to handle boundary exchanges for icebergs
5   !!======================================================================
6   !! History :  3.3  !  2010-01  (Martin&Adcroft) Original code
7   !!             -   !  2011-03  (Madec)          Part conversion to NEMO form
8   !!             -   !                            Removal of mapping from another grid
9   !!             -   !  2011-04  (Alderson)       Split into separate modules
10   !!             -   !  2011-05  (Alderson)       MPP exchanges written based on lib_mpp
11   !!             -   !  2011-05  (Alderson)       MPP and single processor boundary conditions added
12   !!----------------------------------------------------------------------
13
14   !!----------------------------------------------------------------------
15   !!   icb_lbc       : -  Pass icebergs across cyclic boundaries
16   !!   icb_lbc_mpp   : -  In MPP pass icebergs from linked list between processors
17   !!                      as they advect around
18   !!                   -  Lagrangian processes cannot be handled by existing NEMO MPP
19   !!                      routines because they do not lie on regular jpi,jpj grids
20   !!                   -  Processor exchanges are handled as in lib_mpp whenever icebergs step
21   !!                      across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej)
22   !!                      so that iceberg does not exist in more than one processor
23   !!                   -  North fold exchanges controlled by three arrays:
24   !!                         nicbflddest - unique processor numbers that current one exchanges with
25   !!                         nicbfldproc - processor number that current grid point exchanges with
26   !!                         nicbfldpts  - packed i,j point in exchanging processor
27   !!----------------------------------------------------------------------
28   USE par_oce                             ! ocean parameters
29   USE dom_oce                             ! ocean domain
30   USE in_out_manager                      ! IO parameters
31   USE lib_mpp                             ! MPI code and lk_mpp in particular
32   USE icb_oce                             ! define iceberg arrays
33   USE icbutl                              ! iceberg utility routines
34
35   IMPLICIT NONE
36   PRIVATE
37
38#if defined key_mpp_mpi
39
40!$AGRIF_DO_NOT_TREAT
41   INCLUDE 'mpif.h'
42!$AGRIF_END_DO_NOT_TREAT
43
44   TYPE, PUBLIC :: buffer
45      INTEGER :: size = 0
46      REAL(wp), DIMENSION(:,:), POINTER ::   data
47   END TYPE buffer
48
49   TYPE(buffer), POINTER       ::   obuffer_n=>NULL() , ibuffer_n=>NULL()
50   TYPE(buffer), POINTER       ::   obuffer_s=>NULL() , ibuffer_s=>NULL()
51   TYPE(buffer), POINTER       ::   obuffer_e=>NULL() , ibuffer_e=>NULL()
52   TYPE(buffer), POINTER       ::   obuffer_w=>NULL() , ibuffer_w=>NULL()
53
54   ! north fold exchange buffers
55   TYPE(buffer), POINTER       ::   obuffer_f=>NULL() , ibuffer_f=>NULL()
56
57   INTEGER, PARAMETER, PRIVATE ::   jp_delta_buf = 25             ! Size by which to increment buffers
58   INTEGER, PARAMETER, PRIVATE ::   jp_buffer_width = 15+nkounts  ! items to store for each berg
59
60#endif
61
62   PUBLIC   icb_lbc
63   PUBLIC   icb_lbc_mpp
64
65   !!----------------------------------------------------------------------
66   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
67   !! $Id$
68   !! Software governed by the CeCILL license (see ./LICENSE)
69   !!----------------------------------------------------------------------
70CONTAINS
71
72   SUBROUTINE icb_lbc()
73      !!----------------------------------------------------------------------
74      !!                 ***  SUBROUTINE icb_lbc  ***
75      !!
76      !! ** Purpose :   in non-mpp case need to deal with cyclic conditions
77      !!                including north-fold
78      !!----------------------------------------------------------------------
79      TYPE(iceberg), POINTER ::   this
80      TYPE(point)  , POINTER ::   pt
81      INTEGER                ::   iine
82      !!----------------------------------------------------------------------
83
84      !! periodic east/west boundaries
85      !! =============================
86
87      IF( l_Iperio ) THEN
88
89         this => first_berg
90         DO WHILE( ASSOCIATED(this) )
91            pt => this%current_point
92            iine = INT( pt%xi + 0.5 )
93            IF( iine > mig(nicbei) ) THEN
94               pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp
95            ELSE IF( iine < mig(nicbdi) ) THEN
96               pt%xi = ricb_left + MOD(pt%xi, 1._wp )
97            ENDIF
98            this => this%next
99         END DO
100         !
101      ENDIF
102
103      !! north/south boundaries
104      !! ======================
105      IF( l_Jperio)      CALL ctl_stop(' north-south periodicity not implemented for icebergs')
106      ! north fold
107      IF( npolj /= 0 )   CALL icb_lbc_nfld()
108      !
109   END SUBROUTINE icb_lbc
110
111
112   SUBROUTINE icb_lbc_nfld()
113      !!----------------------------------------------------------------------
114      !!                 ***  SUBROUTINE icb_lbc_nfld  ***
115      !!
116      !! ** Purpose :   single processor north fold exchange
117      !!----------------------------------------------------------------------
118      TYPE(iceberg), POINTER ::   this
119      TYPE(point)  , POINTER ::   pt
120      INTEGER                ::   iine, ijne, ipts
121      INTEGER                ::   iiglo, ijglo
122      !!----------------------------------------------------------------------
123      !
124      this => first_berg
125      DO WHILE( ASSOCIATED(this) )
126         pt => this%current_point
127         ijne = INT( pt%yj + 0.5 )
128         IF( ijne .GT. mjg(nicbej) ) THEN
129            !
130            iine = INT( pt%xi + 0.5 )
131            ipts  = nicbfldpts (mi1(iine))
132            !
133            ! moving across the cut line means both position and
134            ! velocity must change
135            ijglo = INT( ipts/nicbpack )
136            iiglo = ipts - nicbpack*ijglo
137            pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
138            pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
139            pt%uvel = -1._wp * pt%uvel
140            pt%vvel = -1._wp * pt%vvel
141         ENDIF
142         this => this%next
143      END DO
144      !
145   END SUBROUTINE icb_lbc_nfld
146
147#if defined key_mpp_mpi
148   !!----------------------------------------------------------------------
149   !!   'key_mpp_mpi'             MPI massively parallel processing library
150   !!----------------------------------------------------------------------
151
152   SUBROUTINE icb_lbc_mpp()
153      !!----------------------------------------------------------------------
154      !!                 ***  SUBROUTINE icb_lbc_mpp  ***
155      !!
156      !! ** Purpose :   multi processor exchange
157      !!
158      !! ** Method  :   identify direction for exchange, pack into a buffer
159      !!                which is basically a real array and delete from linked list
160      !!                length of buffer is exchanged first with receiving processor
161      !!                then buffer is sent if necessary
162      !!----------------------------------------------------------------------
163      TYPE(iceberg)         , POINTER     ::   tmpberg, this
164      TYPE(point)           , POINTER     ::   pt
165      INTEGER                             ::   ibergs_to_send_e, ibergs_to_send_w
166      INTEGER                             ::   ibergs_to_send_n, ibergs_to_send_s
167      INTEGER                             ::   ibergs_rcvd_from_e, ibergs_rcvd_from_w
168      INTEGER                             ::   ibergs_rcvd_from_n, ibergs_rcvd_from_s
169      INTEGER                             ::   i, ibergs_start, ibergs_end
170      INTEGER                             ::   iine, ijne
171      INTEGER                             ::   ipe_N, ipe_S, ipe_W, ipe_E
172      REAL(wp), DIMENSION(2)              ::   zewbergs, zwebergs, znsbergs, zsnbergs
173      INTEGER                             ::   iml_req1, iml_req2, iml_req3, iml_req4
174      INTEGER                             ::   iml_req5, iml_req6, iml_req7, iml_req8, iml_err
175      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   iml_stat
176
177      ! set up indices of neighbouring processors
178      ipe_N = -1
179      ipe_S = -1
180      ipe_W = -1
181      ipe_E = -1
182      IF( nbondi .EQ.  0 .OR. nbondi .EQ. 1) ipe_W = nowe
183      IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea
184      IF( nbondj .EQ.  0 .OR. nbondj .EQ. 1) ipe_S = noso
185      IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono
186      !
187      ! at northern line of processors with north fold handle bergs differently
188      IF( npolj > 0 ) ipe_N = -1
189
190      ! if there's only one processor in x direction then don't let mpp try to handle periodicity
191      IF( jpni == 1 ) THEN
192         ipe_E = -1
193         ipe_W = -1
194      ENDIF
195
196      IF( nn_verbose_level >= 2 ) THEN
197         WRITE(numicb,*) 'processor west  : ', ipe_W
198         WRITE(numicb,*) 'processor east  : ', ipe_E
199         WRITE(numicb,*) 'processor north : ', ipe_N
200         WRITE(numicb,*) 'processor south : ', ipe_S
201         WRITE(numicb,*) 'processor nimpp : ', nimpp
202         WRITE(numicb,*) 'processor njmpp : ', njmpp
203         WRITE(numicb,*) 'processor nbondi: ', nbondi
204         WRITE(numicb,*) 'processor nbondj: ', nbondj
205         CALL flush( numicb )
206      ENDIF
207
208      ! periodicity is handled here when using mpp when there is more than one processor in
209      ! the i direction, but it also has to happen when jpni=1 case so this is dealt with
210      ! in icb_lbc and called here
211
212      IF( jpni == 1 ) CALL icb_lbc()
213
214      ! Note that xi is adjusted when swapping because of periodic condition
215
216      IF( nn_verbose_level > 0 ) THEN
217         ! store the number of icebergs on this processor at start
218         ibergs_start = icb_utl_count()
219      ENDIF
220
221      ibergs_to_send_e   = 0
222      ibergs_to_send_w   = 0
223      ibergs_to_send_n   = 0
224      ibergs_to_send_s   = 0
225      ibergs_rcvd_from_e = 0
226      ibergs_rcvd_from_w = 0
227      ibergs_rcvd_from_n = 0
228      ibergs_rcvd_from_s = 0
229
230      IF( ASSOCIATED(first_berg) ) THEN      ! Find number of bergs that headed east/west
231         this => first_berg
232         DO WHILE (ASSOCIATED(this))
233            pt => this%current_point
234            iine = INT( pt%xi + 0.5 )
235            IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN
236               tmpberg => this
237               this => this%next
238               ibergs_to_send_e = ibergs_to_send_e + 1
239               IF( nn_verbose_level >= 4 ) THEN
240                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east'
241                  CALL flush( numicb )
242               ENDIF
243               ! deal with periodic case
244               tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp
245               ! now pack it into buffer and delete from list
246               CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e)
247               CALL icb_utl_delete(first_berg, tmpberg)
248            ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi) ) THEN
249               tmpberg => this
250               this => this%next
251               ibergs_to_send_w = ibergs_to_send_w + 1
252               IF( nn_verbose_level >= 4 ) THEN
253                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west'
254                  CALL flush( numicb )
255               ENDIF
256               ! deal with periodic case
257               tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp )
258               ! now pack it into buffer and delete from list
259               CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w)
260               CALL icb_utl_delete(first_berg, tmpberg)
261            ELSE
262               this => this%next
263            ENDIF
264         END DO
265      ENDIF
266      IF( nn_verbose_level >= 3) THEN
267         WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w
268         CALL flush(numicb)
269      ENDIF
270
271      ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa
272
273      ! pattern here is copied from lib_mpp code
274
275      SELECT CASE ( nbondi )
276      CASE( -1 )
277         zwebergs(1) = ibergs_to_send_e
278         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1)
279         CALL mpprecv( 11, zewbergs(2), 1, ipe_E )
280         IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
281         ibergs_rcvd_from_e = INT( zewbergs(2) )
282      CASE(  0 )
283         zewbergs(1) = ibergs_to_send_w
284         zwebergs(1) = ibergs_to_send_e
285         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2)
286         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3)
287         CALL mpprecv( 11, zewbergs(2), 1, ipe_E )
288         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
289         IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
290         IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
291         ibergs_rcvd_from_e = INT( zewbergs(2) )
292         ibergs_rcvd_from_w = INT( zwebergs(2) )
293      CASE(  1 )
294         zewbergs(1) = ibergs_to_send_w
295         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4)
296         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
297         IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
298         ibergs_rcvd_from_w = INT( zwebergs(2) )
299      END SELECT
300      IF( nn_verbose_level >= 3) THEN
301         WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e
302         CALL flush(numicb)
303      ENDIF
304
305      SELECT CASE ( nbondi )
306      CASE( -1 )
307         IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 )
308         IF( ibergs_rcvd_from_e > 0 ) THEN
309            CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
310            CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
311         ENDIF
312         IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
313         DO i = 1, ibergs_rcvd_from_e
314            IF( nn_verbose_level >= 4 ) THEN
315               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
316               CALL flush( numicb )
317            ENDIF
318            CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i)
319         ENDDO
320      CASE(  0 )
321         IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 )
322         IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 )
323         IF( ibergs_rcvd_from_e > 0 ) THEN
324            CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
325            CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
326         ENDIF
327         IF( ibergs_rcvd_from_w > 0 ) THEN
328            CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
329            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
330         ENDIF
331         IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
332         IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
333         DO i = 1, ibergs_rcvd_from_e
334            IF( nn_verbose_level >= 4 ) THEN
335               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
336               CALL flush( numicb )
337            ENDIF
338            CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i)
339         END DO
340         DO i = 1, ibergs_rcvd_from_w
341            IF( nn_verbose_level >= 4 ) THEN
342               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
343               CALL flush( numicb )
344            ENDIF
345            CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i)
346         ENDDO
347      CASE(  1 )
348         IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 )
349         IF( ibergs_rcvd_from_w > 0 ) THEN
350            CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
351            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
352         ENDIF
353         IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
354         DO i = 1, ibergs_rcvd_from_w
355            IF( nn_verbose_level >= 4 ) THEN
356               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
357               CALL flush( numicb )
358            ENDIF
359            CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i)
360         END DO
361      END SELECT
362
363      ! Find number of bergs that headed north/south
364      ! (note: this block should technically go ahead of the E/W recv block above
365      !  to handle arbitrary orientation of PEs. But for simplicity, it is
366      !  here to accomodate diagonal transfer of bergs between PEs -AJA)
367
368      IF( ASSOCIATED(first_berg) ) THEN
369         this => first_berg
370         DO WHILE (ASSOCIATED(this))
371            pt => this%current_point
372            ijne = INT( pt%yj + 0.5 )
373            IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN
374               tmpberg => this
375               this => this%next
376               ibergs_to_send_n = ibergs_to_send_n + 1
377               IF( nn_verbose_level >= 4 ) THEN
378                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north'
379                  CALL flush( numicb )
380               ENDIF
381               CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n)
382               CALL icb_utl_delete(first_berg, tmpberg)
383            ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj) ) THEN
384               tmpberg => this
385               this => this%next
386               ibergs_to_send_s = ibergs_to_send_s + 1
387               IF( nn_verbose_level >= 4 ) THEN
388                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south'
389                  CALL flush( numicb )
390               ENDIF
391               CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s)
392               CALL icb_utl_delete(first_berg, tmpberg)
393            ELSE
394               this => this%next
395            ENDIF
396         END DO
397      ENDIF
398      if( nn_verbose_level >= 3) then
399         write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s
400         call flush(numicb)
401      endif
402
403      ! send bergs north
404      ! and receive bergs from south (ie ones sent north)
405
406      SELECT CASE ( nbondj )
407      CASE( -1 )
408         zsnbergs(1) = ibergs_to_send_n
409         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1)
410         CALL mpprecv( 15, znsbergs(2), 1, ipe_N )
411         IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
412         ibergs_rcvd_from_n = INT( znsbergs(2) )
413      CASE(  0 )
414         znsbergs(1) = ibergs_to_send_s
415         zsnbergs(1) = ibergs_to_send_n
416         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2)
417         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3)
418         CALL mpprecv( 15, znsbergs(2), 1, ipe_N )
419         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
420         IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
421         IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
422         ibergs_rcvd_from_n = INT( znsbergs(2) )
423         ibergs_rcvd_from_s = INT( zsnbergs(2) )
424      CASE(  1 )
425         znsbergs(1) = ibergs_to_send_s
426         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4)
427         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
428         IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
429         ibergs_rcvd_from_s = INT( zsnbergs(2) )
430      END SELECT
431      if( nn_verbose_level >= 3) then
432         write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n
433         call flush(numicb)
434      endif
435
436      SELECT CASE ( nbondj )
437      CASE( -1 )
438         IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 )
439         IF( ibergs_rcvd_from_n > 0 ) THEN
440            CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
441            CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
442         ENDIF
443         IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
444         DO i = 1, ibergs_rcvd_from_n
445            IF( nn_verbose_level >= 4 ) THEN
446               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
447               CALL flush( numicb )
448            ENDIF
449            CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i)
450         END DO
451      CASE(  0 )
452         IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 )
453         IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 )
454         IF( ibergs_rcvd_from_n > 0 ) THEN
455            CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
456            CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
457         ENDIF
458         IF( ibergs_rcvd_from_s > 0 ) THEN
459            CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
460            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
461         ENDIF
462         IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
463         IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
464         DO i = 1, ibergs_rcvd_from_n
465            IF( nn_verbose_level >= 4 ) THEN
466               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
467               CALL flush( numicb )
468            ENDIF
469            CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i)
470         END DO
471         DO i = 1, ibergs_rcvd_from_s
472            IF( nn_verbose_level >= 4 ) THEN
473               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
474               CALL flush( numicb )
475            ENDIF
476            CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i)
477         ENDDO
478      CASE(  1 )
479         IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 )
480         IF( ibergs_rcvd_from_s > 0 ) THEN
481            CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
482            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
483         ENDIF
484         IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
485         DO i = 1, ibergs_rcvd_from_s
486            IF( nn_verbose_level >= 4 ) THEN
487               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
488               CALL flush( numicb )
489            ENDIF
490            CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i)
491         END DO
492      END SELECT
493
494      IF( nn_verbose_level > 0 ) THEN
495         ! compare the number of icebergs on this processor from the start to the end
496         ibergs_end = icb_utl_count()
497         i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - &
498             ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w )
499         IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN
500            WRITE( numicb,*   ) 'send_bergs_to_other_pes: net change in number of icebergs'
501            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', &
502                                ibergs_end,' on PE',narea
503            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', &
504                                ibergs_start,' on PE',narea
505            WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', &
506                                i,' on PE',narea
507            WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', &
508                                ibergs_end-(ibergs_start+i),' on PE',narea
509            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', &
510                                ibergs_to_send_n,' on PE',narea
511            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', &
512                                ibergs_to_send_s,' on PE',narea
513            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', &
514                                ibergs_to_send_e,' on PE',narea
515            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', &
516                                ibergs_to_send_w,' on PE',narea
517            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', &
518                                ibergs_rcvd_from_n,' on PE',narea
519            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', &
520                                ibergs_rcvd_from_s,' on PE',narea
521            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', &
522                                ibergs_rcvd_from_e,' on PE',narea
523            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', &
524                                ibergs_rcvd_from_w,' on PE',narea
525  1000      FORMAT(a,i5,a,i4)
526            CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two')
527         ENDIF
528      ENDIF
529
530      ! deal with north fold if we necessary when there is more than one top row processor
531      ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc
532      IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( )
533
534      IF( nn_verbose_level > 0 ) THEN
535         i = 0
536         this => first_berg
537         DO WHILE (ASSOCIATED(this))
538            pt => this%current_point
539            iine = INT( pt%xi + 0.5 )
540            ijne = INT( pt%yj + 0.5 )
541            IF( iine .LT. mig(nicbdi) .OR. &
542                iine .GT. mig(nicbei) .OR. &
543                ijne .LT. mjg(nicbdj) .OR. &
544                ijne .GT. mjg(nicbej)) THEN
545               i = i + 1
546               WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne
547               WRITE(numicb,*) '                   ', nimpp, njmpp
548               WRITE(numicb,*) '                   ', nicbdi, nicbei, nicbdj, nicbej
549               CALL flush( numicb )
550            ENDIF
551            this => this%next
552         ENDDO ! WHILE
553         CALL mpp_sum('icblbc', i)
554         IF( i .GT. 0 ) THEN
555            WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i
556            CALL ctl_stop('send_bergs_to_other_pes:  there are bergs still in halos!')
557         ENDIF ! root_pe
558      ENDIF ! debug
559      !
560      CALL mppsync()
561      !
562   END SUBROUTINE icb_lbc_mpp
563
564
565   SUBROUTINE icb_lbc_mpp_nfld()
566      !!----------------------------------------------------------------------
567      !!                 ***  SUBROUTINE icb_lbc_mpp_nfld  ***
568      !!
569      !! ** Purpose :   north fold treatment in multi processor exchange
570      !!
571      !! ** Method  :   
572      !!----------------------------------------------------------------------
573      TYPE(iceberg)         , POINTER     :: tmpberg, this
574      TYPE(point)           , POINTER     :: pt
575      INTEGER                             :: ibergs_to_send
576      INTEGER                             :: ibergs_to_rcv
577      INTEGER                             :: iiglo, ijglo, jk, jn
578      INTEGER                             :: ifldproc, iproc, ipts
579      INTEGER                             :: iine, ijne
580      INTEGER                             :: jjn
581      REAL(wp), DIMENSION(0:3)            :: zsbergs, znbergs
582      INTEGER                             :: iml_req1, iml_req2, iml_err
583      INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat
584
585      ! set up indices of neighbouring processors
586
587      ! nicbfldproc is a list of unique processor numbers that this processor
588      ! exchanges with (including itself), so we loop over this array; since
589      ! its of fixed size, the first -1 marks end of list of processors
590      !
591      nicbfldnsend(:) = 0
592      nicbfldexpect(:) = 0
593      nicbfldreq(:) = 0
594      !
595      ! Since each processor may be communicating with more than one northern
596      ! neighbour, cycle through the sends so that the receive order can be
597      ! controlled.
598      !
599      ! First compute how many icebergs each active neighbour should expect
600      DO jn = 1, jpni
601         IF( nicbfldproc(jn) /= -1 ) THEN
602            ifldproc = nicbfldproc(jn)
603            nicbfldnsend(jn) = 0
604
605            ! Find number of bergs that need to be exchanged
606            ! Pick out exchanges with processor ifldproc
607            ! if ifldproc is this processor then don't send
608            !
609            IF( ASSOCIATED(first_berg) ) THEN
610               this => first_berg
611               DO WHILE (ASSOCIATED(this))
612                  pt => this%current_point
613                  iine = INT( pt%xi + 0.5 )
614                  ijne = INT( pt%yj + 0.5 )
615                  iproc = nicbflddest(mi1(iine))
616                  IF( ijne .GT. mjg(nicbej) ) THEN
617                     IF( iproc == ifldproc ) THEN
618                        !
619                        IF( iproc /= narea ) THEN
620                           tmpberg => this
621                           nicbfldnsend(jn) = nicbfldnsend(jn) + 1
622                        ENDIF
623                        !
624                     ENDIF
625                  ENDIF
626                  this => this%next
627               END DO
628            ENDIF
629            !
630         ENDIF
631         !
632      END DO
633      !
634      ! Now tell each active neighbour how many icebergs to expect
635      DO jn = 1, jpni
636         IF( nicbfldproc(jn) /= -1 ) THEN
637            ifldproc = nicbfldproc(jn)
638            IF( ifldproc == narea ) CYCLE
639   
640            zsbergs(0) = narea
641            zsbergs(1) = nicbfldnsend(jn)
642            !IF ( nicbfldnsend(jn) .GT. 0) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc
643            CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn))
644         ENDIF
645         !
646      END DO
647      !
648      ! and receive the heads-up from active neighbours preparing to send
649      DO jn = 1, jpni
650         IF( nicbfldproc(jn) /= -1 ) THEN
651            ifldproc = nicbfldproc(jn)
652            IF( ifldproc == narea ) CYCLE
653
654            CALL mpprecv( 21, znbergs(1:2), 2 )
655            DO jjn = 1,jpni
656             IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT
657            END DO
658            IF( jjn .GT. jpni ) write(numicb,*) 'ICB ERROR'
659            nicbfldexpect(jjn) = INT( znbergs(2) )
660            !IF ( nicbfldexpect(jjn) .GT. 0) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn)
661            !CALL FLUSH(numicb)
662         ENDIF
663         !
664      END DO
665      !
666      ! post the mpi waits if using immediate send protocol
667      DO jn = 1, jpni
668         IF( nicbfldproc(jn) /= -1 ) THEN
669            ifldproc = nicbfldproc(jn)
670            IF( ifldproc == narea ) CYCLE
671
672            IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err )
673         ENDIF
674         !
675      END DO
676   
677         !
678         ! Cycle through the icebergs again, this time packing and sending any
679         ! going through the north fold. They will be expected.
680      DO jn = 1, jpni
681         IF( nicbfldproc(jn) /= -1 ) THEN
682            ifldproc = nicbfldproc(jn)
683            ibergs_to_send = 0
684   
685            ! Find number of bergs that need to be exchanged
686            ! Pick out exchanges with processor ifldproc
687            ! if ifldproc is this processor then don't send
688            !
689            IF( ASSOCIATED(first_berg) ) THEN
690               this => first_berg
691               DO WHILE (ASSOCIATED(this))
692                  pt => this%current_point
693                  iine = INT( pt%xi + 0.5 )
694                  ijne = INT( pt%yj + 0.5 )
695                  ipts  = nicbfldpts (mi1(iine))
696                  iproc = nicbflddest(mi1(iine))
697                  IF( ijne .GT. mjg(nicbej) ) THEN
698                     IF( iproc == ifldproc ) THEN
699                        !
700                        ! moving across the cut line means both position and
701                        ! velocity must change
702                        ijglo = INT( ipts/nicbpack )
703                        iiglo = ipts - nicbpack*ijglo
704                        pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
705                        pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
706                        pt%uvel = -1._wp * pt%uvel
707                        pt%vvel = -1._wp * pt%vvel
708                        !
709                        ! now remove berg from list and pack it into a buffer
710                        IF( iproc /= narea ) THEN
711                           tmpberg => this
712                           ibergs_to_send = ibergs_to_send + 1
713                           IF( nn_verbose_level >= 4 ) THEN
714                              WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold'
715                              CALL flush( numicb )
716                           ENDIF
717                           CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send)
718                           CALL icb_utl_delete(first_berg, tmpberg)
719                        ENDIF
720                        !
721                     ENDIF
722                  ENDIF
723                  this => this%next
724               END DO
725            ENDIF
726            if( nn_verbose_level >= 3) then
727               write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send
728               call flush(numicb)
729            endif
730            !
731            ! if we're in this processor, then we've done everything we need to
732            ! so go on to next element of loop
733            IF( ifldproc == narea ) CYCLE
734   
735            ! send bergs
736   
737            IF( ibergs_to_send > 0 )  &
738                CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) )
739            !
740         ENDIF
741         !
742      END DO
743      !
744      ! Now receive the expected number of bergs from the active neighbours
745      DO jn = 1, jpni
746         IF( nicbfldproc(jn) /= -1 ) THEN
747            ifldproc = nicbfldproc(jn)
748            IF( ifldproc == narea ) CYCLE
749            ibergs_to_rcv = nicbfldexpect(jn)
750
751            IF( ibergs_to_rcv  > 0 ) THEN
752               CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv)
753               CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 )
754            ENDIF
755            !
756            DO jk = 1, ibergs_to_rcv
757               IF( nn_verbose_level >= 4 ) THEN
758                  WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold'
759                  CALL flush( numicb )
760               ENDIF
761               CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk )
762            END DO
763         ENDIF
764         !
765      END DO
766      !
767      ! Finally post the mpi waits if using immediate send protocol
768      DO jn = 1, jpni
769         IF( nicbfldproc(jn) /= -1 ) THEN
770            ifldproc = nicbfldproc(jn)
771            IF( ifldproc == narea ) CYCLE
772
773            IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err )
774         ENDIF
775         !
776      END DO
777      !
778   END SUBROUTINE icb_lbc_mpp_nfld
779
780
781   SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb )
782      !!----------------------------------------------------------------------
783      !!----------------------------------------------------------------------
784      TYPE(iceberg), POINTER :: berg
785      TYPE(buffer) , POINTER :: pbuff
786      INTEGER               , INTENT(in) :: kb
787      !
788      INTEGER ::   k   ! local integer
789      !!----------------------------------------------------------------------
790      !
791      IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
792      IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
793
794      !! pack points into buffer
795
796      pbuff%data( 1,kb) = berg%current_point%lon
797      pbuff%data( 2,kb) = berg%current_point%lat
798      pbuff%data( 3,kb) = berg%current_point%uvel
799      pbuff%data( 4,kb) = berg%current_point%vvel
800      pbuff%data( 5,kb) = berg%current_point%xi
801      pbuff%data( 6,kb) = berg%current_point%yj
802      pbuff%data( 7,kb) = float(berg%current_point%year)
803      pbuff%data( 8,kb) = berg%current_point%day
804      pbuff%data( 9,kb) = berg%current_point%mass
805      pbuff%data(10,kb) = berg%current_point%thickness
806      pbuff%data(11,kb) = berg%current_point%width
807      pbuff%data(12,kb) = berg%current_point%length
808      pbuff%data(13,kb) = berg%current_point%mass_of_bits
809      pbuff%data(14,kb) = berg%current_point%heat_density
810
811      pbuff%data(15,kb) = berg%mass_scaling
812      DO k=1,nkounts
813         pbuff%data(15+k,kb) = REAL( berg%number(k), wp )
814      END DO
815      !
816   END SUBROUTINE icb_pack_into_buffer
817
818
819   SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb)
820      !!----------------------------------------------------------------------
821      !!----------------------------------------------------------------------
822      TYPE(iceberg),             POINTER :: first
823      TYPE(buffer) ,             POINTER :: pbuff
824      INTEGER      , INTENT(in)          :: kb
825      !
826      TYPE(iceberg)                      :: currentberg
827      TYPE(point)                        :: pt
828      INTEGER                            :: ik
829      !!----------------------------------------------------------------------
830      !
831      pt%lon            =      pbuff%data( 1,kb)
832      pt%lat            =      pbuff%data( 2,kb)
833      pt%uvel           =      pbuff%data( 3,kb)
834      pt%vvel           =      pbuff%data( 4,kb)
835      pt%xi             =      pbuff%data( 5,kb)
836      pt%yj             =      pbuff%data( 6,kb)
837      pt%year           = INT( pbuff%data( 7,kb) )
838      pt%day            =      pbuff%data( 8,kb)
839      pt%mass           =      pbuff%data( 9,kb)
840      pt%thickness      =      pbuff%data(10,kb)
841      pt%width          =      pbuff%data(11,kb)
842      pt%length         =      pbuff%data(12,kb)
843      pt%mass_of_bits   =      pbuff%data(13,kb)
844      pt%heat_density   =      pbuff%data(14,kb)
845
846      currentberg%mass_scaling =      pbuff%data(15,kb)
847      DO ik = 1, nkounts
848         currentberg%number(ik) = INT( pbuff%data(15+ik,kb) )
849      END DO
850      !
851      CALL icb_utl_add(currentberg, pt )
852      !
853   END SUBROUTINE icb_unpack_from_buffer
854
855
856   SUBROUTINE icb_increase_buffer(old,kdelta)
857      !!----------------------------------------------------------------------
858      TYPE(buffer), POINTER    :: old
859      INTEGER     , INTENT(in) :: kdelta
860      !
861      TYPE(buffer), POINTER ::   new
862      INTEGER ::   inew_size
863      !!----------------------------------------------------------------------
864      !
865      IF( .NOT. ASSOCIATED(old) ) THEN   ;   inew_size = kdelta
866      ELSE                               ;   inew_size = old%size + kdelta
867      ENDIF
868      ALLOCATE( new )
869      ALLOCATE( new%data( jp_buffer_width, inew_size) )
870      new%size = inew_size
871      IF( ASSOCIATED(old) ) THEN
872         new%data(:,1:old%size) = old%data(:,1:old%size)
873         DEALLOCATE(old%data)
874         DEALLOCATE(old)
875      ENDIF
876      old => new
877      !
878   END SUBROUTINE icb_increase_buffer
879
880
881   SUBROUTINE icb_increase_ibuffer(old,kdelta)
882      !!----------------------------------------------------------------------
883      !!----------------------------------------------------------------------
884      TYPE(buffer),            POINTER :: old
885      INTEGER     , INTENT(in)         :: kdelta
886      !
887      TYPE(buffer),            POINTER :: new
888      INTEGER                          :: inew_size, iold_size
889      !!----------------------------------------------------------------------
890
891      IF( .NOT. ASSOCIATED(old) ) THEN
892         inew_size = kdelta + jp_delta_buf
893         iold_size = 0
894      ELSE
895         iold_size = old%size
896         IF( kdelta .LT. old%size ) THEN
897            inew_size = old%size + kdelta
898         ELSE
899            inew_size = kdelta + jp_delta_buf
900         ENDIF
901      ENDIF
902
903      IF( iold_size .NE. inew_size ) THEN
904         ALLOCATE( new )
905         ALLOCATE( new%data( jp_buffer_width, inew_size) )
906         new%size = inew_size
907         IF( ASSOCIATED(old) ) THEN
908            new%data(:,1:old%size) = old%data(:,1:old%size)
909            DEALLOCATE(old%data)
910            DEALLOCATE(old)
911         ENDIF
912         old => new
913        !WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size
914      ENDIF
915      !
916   END SUBROUTINE icb_increase_ibuffer
917
918#else
919   !!----------------------------------------------------------------------
920   !!   Default case:            Dummy module        share memory computing
921   !!----------------------------------------------------------------------
922   SUBROUTINE icb_lbc_mpp()
923      WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!'
924   END SUBROUTINE icb_lbc_mpp
925#endif
926
927   !!======================================================================
928END MODULE icblbc
Note: See TracBrowser for help on using the repository browser.