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.
icblbc.F90 in branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/ICB – NEMO

source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90 @ 11101

Last change on this file since 11101 was 11101, checked in by frrh, 5 years ago

Merge changes from Met Office GMED ticket 450 to reduce unnecessary
text output from NEMO.
This output, which is typically not switchable, is rarely of interest
in normal (non-debugging) runs and simply redunantley consumes extra
file space.
Further, the presence of this text output has been shown to
significantly degrade performance of models which are run during
Met Office HPC RAID (disk) checks.
The new code introduces switches which are configurable via the
changes made in the associated Met Office MOCI ticket 399.

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