source: NEMO/trunk/src/OCE/ICB/icblbc.F90 @ 12377

Last change on this file since 12377 was 12377, checked in by acc, 7 months ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge —ignore-ancestry \

svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The —ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

  • 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   !! * Substitutions
66#  include "do_loop_substitute.h90"
67   !!----------------------------------------------------------------------
68   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
69   !! $Id$
70   !! Software governed by the CeCILL license (see ./LICENSE)
71   !!----------------------------------------------------------------------
72CONTAINS
73
74   SUBROUTINE icb_lbc()
75      !!----------------------------------------------------------------------
76      !!                 ***  SUBROUTINE icb_lbc  ***
77      !!
78      !! ** Purpose :   in non-mpp case need to deal with cyclic conditions
79      !!                including north-fold
80      !!----------------------------------------------------------------------
81      TYPE(iceberg), POINTER ::   this
82      TYPE(point)  , POINTER ::   pt
83      INTEGER                ::   iine
84      !!----------------------------------------------------------------------
85
86      !! periodic east/west boundaries
87      !! =============================
88
89      IF( l_Iperio ) THEN
90
91         this => first_berg
92         DO WHILE( ASSOCIATED(this) )
93            pt => this%current_point
94            iine = INT( pt%xi + 0.5 )
95            IF( iine > mig(nicbei) ) THEN
96               pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp
97            ELSE IF( iine < mig(nicbdi) ) THEN
98               pt%xi = ricb_left + MOD(pt%xi, 1._wp )
99            ENDIF
100            this => this%next
101         END DO
102         !
103      ENDIF
104
105      !! north/south boundaries
106      !! ======================
107      IF( l_Jperio)      CALL ctl_stop(' north-south periodicity not implemented for icebergs')
108      ! north fold
109      IF( npolj /= 0 )   CALL icb_lbc_nfld()
110      !
111   END SUBROUTINE icb_lbc
112
113
114   SUBROUTINE icb_lbc_nfld()
115      !!----------------------------------------------------------------------
116      !!                 ***  SUBROUTINE icb_lbc_nfld  ***
117      !!
118      !! ** Purpose :   single processor north fold exchange
119      !!----------------------------------------------------------------------
120      TYPE(iceberg), POINTER ::   this
121      TYPE(point)  , POINTER ::   pt
122      INTEGER                ::   iine, ijne, ipts
123      INTEGER                ::   iiglo, ijglo
124      !!----------------------------------------------------------------------
125      !
126      this => first_berg
127      DO WHILE( ASSOCIATED(this) )
128         pt => this%current_point
129         ijne = INT( pt%yj + 0.5 )
130         IF( ijne .GT. mjg(nicbej) ) THEN
131            !
132            iine = INT( pt%xi + 0.5 )
133            ipts  = nicbfldpts (mi1(iine))
134            !
135            ! moving across the cut line means both position and
136            ! velocity must change
137            ijglo = INT( ipts/nicbpack )
138            iiglo = ipts - nicbpack*ijglo
139            pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
140            pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
141            pt%uvel = -1._wp * pt%uvel
142            pt%vvel = -1._wp * pt%vvel
143         ENDIF
144         this => this%next
145      END DO
146      !
147   END SUBROUTINE icb_lbc_nfld
148
149#if defined key_mpp_mpi
150   !!----------------------------------------------------------------------
151   !!   'key_mpp_mpi'             MPI massively parallel processing library
152   !!----------------------------------------------------------------------
153
154   SUBROUTINE icb_lbc_mpp()
155      !!----------------------------------------------------------------------
156      !!                 ***  SUBROUTINE icb_lbc_mpp  ***
157      !!
158      !! ** Purpose :   multi processor exchange
159      !!
160      !! ** Method  :   identify direction for exchange, pack into a buffer
161      !!                which is basically a real array and delete from linked list
162      !!                length of buffer is exchanged first with receiving processor
163      !!                then buffer is sent if necessary
164      !!----------------------------------------------------------------------
165      TYPE(iceberg)         , POINTER     ::   tmpberg, this
166      TYPE(point)           , POINTER     ::   pt
167      INTEGER                             ::   ibergs_to_send_e, ibergs_to_send_w
168      INTEGER                             ::   ibergs_to_send_n, ibergs_to_send_s
169      INTEGER                             ::   ibergs_rcvd_from_e, ibergs_rcvd_from_w
170      INTEGER                             ::   ibergs_rcvd_from_n, ibergs_rcvd_from_s
171      INTEGER                             ::   i, ibergs_start, ibergs_end
172      INTEGER                             ::   iine, ijne
173      INTEGER                             ::   ipe_N, ipe_S, ipe_W, ipe_E
174      REAL(wp), DIMENSION(2)              ::   zewbergs, zwebergs, znsbergs, zsnbergs
175      INTEGER                             ::   iml_req1, iml_req2, iml_req3, iml_req4
176      INTEGER                             ::   iml_req5, iml_req6, iml_req7, iml_req8, iml_err
177      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   iml_stat
178
179      ! set up indices of neighbouring processors
180      ipe_N = -1
181      ipe_S = -1
182      ipe_W = -1
183      ipe_E = -1
184      IF( nbondi .EQ.  0 .OR. nbondi .EQ. 1) ipe_W = nowe
185      IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea
186      IF( nbondj .EQ.  0 .OR. nbondj .EQ. 1) ipe_S = noso
187      IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono
188      !
189      ! at northern line of processors with north fold handle bergs differently
190      IF( npolj > 0 ) ipe_N = -1
191
192      ! if there's only one processor in x direction then don't let mpp try to handle periodicity
193      IF( jpni == 1 ) THEN
194         ipe_E = -1
195         ipe_W = -1
196      ENDIF
197
198      IF( nn_verbose_level >= 2 ) THEN
199         WRITE(numicb,*) 'processor west  : ', ipe_W
200         WRITE(numicb,*) 'processor east  : ', ipe_E
201         WRITE(numicb,*) 'processor north : ', ipe_N
202         WRITE(numicb,*) 'processor south : ', ipe_S
203         WRITE(numicb,*) 'processor nimpp : ', nimpp
204         WRITE(numicb,*) 'processor njmpp : ', njmpp
205         WRITE(numicb,*) 'processor nbondi: ', nbondi
206         WRITE(numicb,*) 'processor nbondj: ', nbondj
207         CALL flush( numicb )
208      ENDIF
209
210      ! periodicity is handled here when using mpp when there is more than one processor in
211      ! the i direction, but it also has to happen when jpni=1 case so this is dealt with
212      ! in icb_lbc and called here
213
214      IF( jpni == 1 ) CALL icb_lbc()
215
216      ! Note that xi is adjusted when swapping because of periodic condition
217
218      IF( nn_verbose_level > 0 ) THEN
219         ! store the number of icebergs on this processor at start
220         ibergs_start = icb_utl_count()
221      ENDIF
222
223      ibergs_to_send_e   = 0
224      ibergs_to_send_w   = 0
225      ibergs_to_send_n   = 0
226      ibergs_to_send_s   = 0
227      ibergs_rcvd_from_e = 0
228      ibergs_rcvd_from_w = 0
229      ibergs_rcvd_from_n = 0
230      ibergs_rcvd_from_s = 0
231
232      IF( ASSOCIATED(first_berg) ) THEN      ! Find number of bergs that headed east/west
233         this => first_berg
234         DO WHILE (ASSOCIATED(this))
235            pt => this%current_point
236            iine = INT( pt%xi + 0.5 )
237            IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN
238               tmpberg => this
239               this => this%next
240               ibergs_to_send_e = ibergs_to_send_e + 1
241               IF( nn_verbose_level >= 4 ) THEN
242                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east'
243                  CALL flush( numicb )
244               ENDIF
245               ! deal with periodic case
246               tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp
247               ! now pack it into buffer and delete from list
248               CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e)
249               CALL icb_utl_delete(first_berg, tmpberg)
250            ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi) ) THEN
251               tmpberg => this
252               this => this%next
253               ibergs_to_send_w = ibergs_to_send_w + 1
254               IF( nn_verbose_level >= 4 ) THEN
255                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west'
256                  CALL flush( numicb )
257               ENDIF
258               ! deal with periodic case
259               tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp )
260               ! now pack it into buffer and delete from list
261               CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w)
262               CALL icb_utl_delete(first_berg, tmpberg)
263            ELSE
264               this => this%next
265            ENDIF
266         END DO
267      ENDIF
268      IF( nn_verbose_level >= 3) THEN
269         WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w
270         CALL flush(numicb)
271      ENDIF
272
273      ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa
274
275      ! pattern here is copied from lib_mpp code
276
277      SELECT CASE ( nbondi )
278      CASE( -1 )
279         zwebergs(1) = ibergs_to_send_e
280         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1)
281         CALL mpprecv( 11, zewbergs(2), 1, ipe_E )
282         CALL mpi_wait( iml_req1, iml_stat, iml_err )
283         ibergs_rcvd_from_e = INT( zewbergs(2) )
284      CASE(  0 )
285         zewbergs(1) = ibergs_to_send_w
286         zwebergs(1) = ibergs_to_send_e
287         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2)
288         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3)
289         CALL mpprecv( 11, zewbergs(2), 1, ipe_E )
290         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
291         CALL mpi_wait( iml_req2, iml_stat, iml_err )
292         CALL mpi_wait( iml_req3, iml_stat, iml_err )
293         ibergs_rcvd_from_e = INT( zewbergs(2) )
294         ibergs_rcvd_from_w = INT( zwebergs(2) )
295      CASE(  1 )
296         zewbergs(1) = ibergs_to_send_w
297         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4)
298         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
299         CALL mpi_wait( iml_req4, iml_stat, iml_err )
300         ibergs_rcvd_from_w = INT( zwebergs(2) )
301      END SELECT
302      IF( nn_verbose_level >= 3) THEN
303         WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e
304         CALL flush(numicb)
305      ENDIF
306
307      SELECT CASE ( nbondi )
308      CASE( -1 )
309         IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 )
310         IF( ibergs_rcvd_from_e > 0 ) THEN
311            CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
312            CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
313         ENDIF
314         IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
315         DO i = 1, ibergs_rcvd_from_e
316            IF( nn_verbose_level >= 4 ) THEN
317               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
318               CALL flush( numicb )
319            ENDIF
320            CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i)
321         ENDDO
322      CASE(  0 )
323         IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 )
324         IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 )
325         IF( ibergs_rcvd_from_e > 0 ) THEN
326            CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
327            CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
328         ENDIF
329         IF( ibergs_rcvd_from_w > 0 ) THEN
330            CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
331            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
332         ENDIF
333         IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
334         IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
335         DO i = 1, ibergs_rcvd_from_e
336            IF( nn_verbose_level >= 4 ) THEN
337               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
338               CALL flush( numicb )
339            ENDIF
340            CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i)
341         END DO
342         DO i = 1, ibergs_rcvd_from_w
343            IF( nn_verbose_level >= 4 ) THEN
344               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
345               CALL flush( numicb )
346            ENDIF
347            CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i)
348         ENDDO
349      CASE(  1 )
350         IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 )
351         IF( ibergs_rcvd_from_w > 0 ) THEN
352            CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
353            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
354         ENDIF
355         IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
356         DO i = 1, ibergs_rcvd_from_w
357            IF( nn_verbose_level >= 4 ) THEN
358               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
359               CALL flush( numicb )
360            ENDIF
361            CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i)
362         END DO
363      END SELECT
364
365      ! Find number of bergs that headed north/south
366      ! (note: this block should technically go ahead of the E/W recv block above
367      !  to handle arbitrary orientation of PEs. But for simplicity, it is
368      !  here to accomodate diagonal transfer of bergs between PEs -AJA)
369
370      IF( ASSOCIATED(first_berg) ) THEN
371         this => first_berg
372         DO WHILE (ASSOCIATED(this))
373            pt => this%current_point
374            ijne = INT( pt%yj + 0.5 )
375            IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN
376               tmpberg => this
377               this => this%next
378               ibergs_to_send_n = ibergs_to_send_n + 1
379               IF( nn_verbose_level >= 4 ) THEN
380                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north'
381                  CALL flush( numicb )
382               ENDIF
383               CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n)
384               CALL icb_utl_delete(first_berg, tmpberg)
385            ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj) ) THEN
386               tmpberg => this
387               this => this%next
388               ibergs_to_send_s = ibergs_to_send_s + 1
389               IF( nn_verbose_level >= 4 ) THEN
390                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south'
391                  CALL flush( numicb )
392               ENDIF
393               CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s)
394               CALL icb_utl_delete(first_berg, tmpberg)
395            ELSE
396               this => this%next
397            ENDIF
398         END DO
399      ENDIF
400      if( nn_verbose_level >= 3) then
401         write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s
402         call flush(numicb)
403      endif
404
405      ! send bergs north
406      ! and receive bergs from south (ie ones sent north)
407
408      SELECT CASE ( nbondj )
409      CASE( -1 )
410         zsnbergs(1) = ibergs_to_send_n
411         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1)
412         CALL mpprecv( 15, znsbergs(2), 1, ipe_N )
413         CALL mpi_wait( iml_req1, iml_stat, iml_err )
414         ibergs_rcvd_from_n = INT( znsbergs(2) )
415      CASE(  0 )
416         znsbergs(1) = ibergs_to_send_s
417         zsnbergs(1) = ibergs_to_send_n
418         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2)
419         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3)
420         CALL mpprecv( 15, znsbergs(2), 1, ipe_N )
421         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
422         CALL mpi_wait( iml_req2, iml_stat, iml_err )
423         CALL mpi_wait( iml_req3, iml_stat, iml_err )
424         ibergs_rcvd_from_n = INT( znsbergs(2) )
425         ibergs_rcvd_from_s = INT( zsnbergs(2) )
426      CASE(  1 )
427         znsbergs(1) = ibergs_to_send_s
428         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4)
429         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
430         CALL mpi_wait( iml_req4, iml_stat, iml_err )
431         ibergs_rcvd_from_s = INT( zsnbergs(2) )
432      END SELECT
433      if( nn_verbose_level >= 3) then
434         write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n
435         call flush(numicb)
436      endif
437
438      SELECT CASE ( nbondj )
439      CASE( -1 )
440         IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 )
441         IF( ibergs_rcvd_from_n > 0 ) THEN
442            CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
443            CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
444         ENDIF
445         IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
446         DO i = 1, ibergs_rcvd_from_n
447            IF( nn_verbose_level >= 4 ) THEN
448               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
449               CALL flush( numicb )
450            ENDIF
451            CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i)
452         END DO
453      CASE(  0 )
454         IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 )
455         IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 )
456         IF( ibergs_rcvd_from_n > 0 ) THEN
457            CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
458            CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
459         ENDIF
460         IF( ibergs_rcvd_from_s > 0 ) THEN
461            CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
462            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
463         ENDIF
464         IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
465         IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
466         DO i = 1, ibergs_rcvd_from_n
467            IF( nn_verbose_level >= 4 ) THEN
468               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
469               CALL flush( numicb )
470            ENDIF
471            CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i)
472         END DO
473         DO i = 1, ibergs_rcvd_from_s
474            IF( nn_verbose_level >= 4 ) THEN
475               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
476               CALL flush( numicb )
477            ENDIF
478            CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i)
479         ENDDO
480      CASE(  1 )
481         IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 )
482         IF( ibergs_rcvd_from_s > 0 ) THEN
483            CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
484            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
485         ENDIF
486         IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
487         DO i = 1, ibergs_rcvd_from_s
488            IF( nn_verbose_level >= 4 ) THEN
489               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
490               CALL flush( numicb )
491            ENDIF
492            CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i)
493         END DO
494      END SELECT
495
496      IF( nn_verbose_level > 0 ) THEN
497         ! compare the number of icebergs on this processor from the start to the end
498         ibergs_end = icb_utl_count()
499         i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - &
500             ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w )
501         IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN
502            WRITE( numicb,*   ) 'send_bergs_to_other_pes: net change in number of icebergs'
503            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', &
504                                ibergs_end,' on PE',narea
505            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', &
506                                ibergs_start,' on PE',narea
507            WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', &
508                                i,' on PE',narea
509            WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', &
510                                ibergs_end-(ibergs_start+i),' on PE',narea
511            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', &
512                                ibergs_to_send_n,' on PE',narea
513            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', &
514                                ibergs_to_send_s,' on PE',narea
515            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', &
516                                ibergs_to_send_e,' on PE',narea
517            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', &
518                                ibergs_to_send_w,' on PE',narea
519            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', &
520                                ibergs_rcvd_from_n,' on PE',narea
521            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', &
522                                ibergs_rcvd_from_s,' on PE',narea
523            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', &
524                                ibergs_rcvd_from_e,' on PE',narea
525            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', &
526                                ibergs_rcvd_from_w,' on PE',narea
527  1000      FORMAT(a,i5,a,i4)
528            CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two')
529         ENDIF
530      ENDIF
531
532      ! deal with north fold if we necessary when there is more than one top row processor
533      ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc
534      IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( )
535
536      IF( nn_verbose_level > 0 ) THEN
537         i = 0
538         this => first_berg
539         DO WHILE (ASSOCIATED(this))
540            pt => this%current_point
541            iine = INT( pt%xi + 0.5 )
542            ijne = INT( pt%yj + 0.5 )
543            IF( iine .LT. mig(nicbdi) .OR. &
544                iine .GT. mig(nicbei) .OR. &
545                ijne .LT. mjg(nicbdj) .OR. &
546                ijne .GT. mjg(nicbej)) THEN
547               i = i + 1
548               WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne
549               WRITE(numicb,*) '                   ', nimpp, njmpp
550               WRITE(numicb,*) '                   ', nicbdi, nicbei, nicbdj, nicbej
551               CALL flush( numicb )
552            ENDIF
553            this => this%next
554         ENDDO ! WHILE
555         CALL mpp_sum('icblbc', i)
556         IF( i .GT. 0 ) THEN
557            WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i
558            CALL ctl_stop('send_bergs_to_other_pes:  there are bergs still in halos!')
559         ENDIF ! root_pe
560      ENDIF ! debug
561      !
562      CALL mppsync()
563      !
564   END SUBROUTINE icb_lbc_mpp
565
566
567   SUBROUTINE icb_lbc_mpp_nfld()
568      !!----------------------------------------------------------------------
569      !!                 ***  SUBROUTINE icb_lbc_mpp_nfld  ***
570      !!
571      !! ** Purpose :   north fold treatment in multi processor exchange
572      !!
573      !! ** Method  :   
574      !!----------------------------------------------------------------------
575      TYPE(iceberg)         , POINTER     :: tmpberg, this
576      TYPE(point)           , POINTER     :: pt
577      INTEGER                             :: ibergs_to_send
578      INTEGER                             :: ibergs_to_rcv
579      INTEGER                             :: iiglo, ijglo, jk, jn
580      INTEGER                             :: ifldproc, iproc, ipts
581      INTEGER                             :: iine, ijne
582      INTEGER                             :: jjn
583      REAL(wp), DIMENSION(0:3)            :: zsbergs, znbergs
584      INTEGER                             :: iml_req1, iml_req2, iml_err
585      INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat
586
587      ! set up indices of neighbouring processors
588
589      ! nicbfldproc is a list of unique processor numbers that this processor
590      ! exchanges with (including itself), so we loop over this array; since
591      ! its of fixed size, the first -1 marks end of list of processors
592      !
593      nicbfldnsend(:) = 0
594      nicbfldexpect(:) = 0
595      nicbfldreq(:) = 0
596      !
597      ! Since each processor may be communicating with more than one northern
598      ! neighbour, cycle through the sends so that the receive order can be
599      ! controlled.
600      !
601      ! First compute how many icebergs each active neighbour should expect
602      DO jn = 1, jpni
603         IF( nicbfldproc(jn) /= -1 ) THEN
604            ifldproc = nicbfldproc(jn)
605            nicbfldnsend(jn) = 0
606
607            ! Find number of bergs that need to be exchanged
608            ! Pick out exchanges with processor ifldproc
609            ! if ifldproc is this processor then don't send
610            !
611            IF( ASSOCIATED(first_berg) ) THEN
612               this => first_berg
613               DO WHILE (ASSOCIATED(this))
614                  pt => this%current_point
615                  iine = INT( pt%xi + 0.5 )
616                  ijne = INT( pt%yj + 0.5 )
617                  iproc = nicbflddest(mi1(iine))
618                  IF( ijne .GT. mjg(nicbej) ) THEN
619                     IF( iproc == ifldproc ) THEN
620                        !
621                        IF( iproc /= narea ) THEN
622                           tmpberg => this
623                           nicbfldnsend(jn) = nicbfldnsend(jn) + 1
624                        ENDIF
625                        !
626                     ENDIF
627                  ENDIF
628                  this => this%next
629               END DO
630            ENDIF
631            !
632         ENDIF
633         !
634      END DO
635      !
636      ! Now tell each active neighbour how many icebergs to expect
637      DO jn = 1, jpni
638         IF( nicbfldproc(jn) /= -1 ) THEN
639            ifldproc = nicbfldproc(jn)
640            IF( ifldproc == narea ) CYCLE
641   
642            zsbergs(0) = narea
643            zsbergs(1) = nicbfldnsend(jn)
644            !IF ( nicbfldnsend(jn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc
645            CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn))
646         ENDIF
647         !
648      END DO
649      !
650      ! and receive the heads-up from active neighbours preparing to send
651      DO jn = 1, jpni
652         IF( nicbfldproc(jn) /= -1 ) THEN
653            ifldproc = nicbfldproc(jn)
654            IF( ifldproc == narea ) CYCLE
655
656            CALL mpprecv( 21, znbergs(1:2), 2 )
657            DO jjn = 1,jpni
658             IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT
659            END DO
660            IF( jjn .GT. jpni .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB ERROR'
661            nicbfldexpect(jjn) = INT( znbergs(2) )
662            !IF ( nicbfldexpect(jjn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn)
663            !IF (nn_verbose_level > 0) CALL FLUSH(numicb)
664         ENDIF
665         !
666      END DO
667      !
668      ! post the mpi waits if using immediate send protocol
669      DO jn = 1, jpni
670         IF( nicbfldproc(jn) /= -1 ) THEN
671            ifldproc = nicbfldproc(jn)
672            IF( ifldproc == narea ) CYCLE
673            CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err )
674         ENDIF
675         !
676      END DO
677   
678         !
679         ! Cycle through the icebergs again, this time packing and sending any
680         ! going through the north fold. They will be expected.
681      DO jn = 1, jpni
682         IF( nicbfldproc(jn) /= -1 ) THEN
683            ifldproc = nicbfldproc(jn)
684            ibergs_to_send = 0
685   
686            ! Find number of bergs that need to be exchanged
687            ! Pick out exchanges with processor ifldproc
688            ! if ifldproc is this processor then don't send
689            !
690            IF( ASSOCIATED(first_berg) ) THEN
691               this => first_berg
692               DO WHILE (ASSOCIATED(this))
693                  pt => this%current_point
694                  iine = INT( pt%xi + 0.5 )
695                  ijne = INT( pt%yj + 0.5 )
696                  ipts  = nicbfldpts (mi1(iine))
697                  iproc = nicbflddest(mi1(iine))
698                  IF( ijne .GT. mjg(nicbej) ) THEN
699                     IF( iproc == ifldproc ) THEN
700                        !
701                        ! moving across the cut line means both position and
702                        ! velocity must change
703                        ijglo = INT( ipts/nicbpack )
704                        iiglo = ipts - nicbpack*ijglo
705                        pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
706                        pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
707                        pt%uvel = -1._wp * pt%uvel
708                        pt%vvel = -1._wp * pt%vvel
709                        !
710                        ! now remove berg from list and pack it into a buffer
711                        IF( iproc /= narea ) THEN
712                           tmpberg => this
713                           ibergs_to_send = ibergs_to_send + 1
714                           IF( nn_verbose_level >= 4 ) THEN
715                              WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold'
716                              CALL flush( numicb )
717                           ENDIF
718                           CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send)
719                           CALL icb_utl_delete(first_berg, tmpberg)
720                        ENDIF
721                        !
722                     ENDIF
723                  ENDIF
724                  this => this%next
725               END DO
726            ENDIF
727            if( nn_verbose_level >= 3) then
728               write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send
729               call flush(numicb)
730            endif
731            !
732            ! if we're in this processor, then we've done everything we need to
733            ! so go on to next element of loop
734            IF( ifldproc == narea ) CYCLE
735   
736            ! send bergs
737   
738            IF( ibergs_to_send > 0 )  &
739                CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) )
740            !
741         ENDIF
742         !
743      END DO
744      !
745      ! Now receive the expected number of bergs from the active neighbours
746      DO jn = 1, jpni
747         IF( nicbfldproc(jn) /= -1 ) THEN
748            ifldproc = nicbfldproc(jn)
749            IF( ifldproc == narea ) CYCLE
750            ibergs_to_rcv = nicbfldexpect(jn)
751
752            IF( ibergs_to_rcv  > 0 ) THEN
753               CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv)
754               CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 )
755            ENDIF
756            !
757            DO jk = 1, ibergs_to_rcv
758               IF( nn_verbose_level >= 4 ) THEN
759                  WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold'
760                  CALL flush( numicb )
761               ENDIF
762               CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk )
763            END DO
764         ENDIF
765         !
766      END DO
767      !
768      ! Finally post the mpi waits if using immediate send protocol
769      DO jn = 1, jpni
770         IF( nicbfldproc(jn) /= -1 ) THEN
771            ifldproc = nicbfldproc(jn)
772            IF( ifldproc == narea ) CYCLE
773            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         !IF (nn_verbose_level > 0) 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.