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

Last change on this file since 10570 was 10570, checked in by acc, 19 months ago

Trunk update to implement finer control over the choice of text report files generated. See ticket: #2167

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