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 NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/ICB – NEMO

source: NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/ICB/icblbc.F90 @ 13181

Last change on this file since 13181 was 13181, checked in by orioltp, 4 years ago

Several bugfixes added by Sam Hatfield (ECMWF).

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