source: NEMO/trunk/NEMOGCM/NEMO/OCE_SRC/ICB/icblbc.F90 @ 9594

Last change on this file since 9594 was 9570, checked in by nicolasmartin, 3 years ago

Global renaming for core routines (./NEMO)

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