New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
icblbc.F90 in branches/2012/dev_NOC_2012_rev3555/NEMOGCM/NEMO/OPA_SRC/ICB – NEMO

source: branches/2012/dev_NOC_2012_rev3555/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90 @ 3614

Last change on this file since 3614 was 3614, checked in by acc, 10 years ago

Branch dev_NOC_2012_r3555. #1006. Step 6: Minor code changes and updated namelists to enable successful SETTE testing

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