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/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/ICB – NEMO

source: branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90 @ 5965

Last change on this file since 5965 was 5965, checked in by timgraham, 8 years ago

Upgraded branch to r5518 of trunk (v3.6 stable revision)

  • Property svn:keywords set to Id
File size: 40.2 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, ipe_E )
283         IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
284         ibergs_rcvd_from_e = INT( zewbergs(2) )
285      CASE(  0 )
286         zewbergs(1) = ibergs_to_send_w
287         zwebergs(1) = ibergs_to_send_e
288         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2)
289         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3)
290         CALL mpprecv( 11, zewbergs(2), 1, ipe_E )
291         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
292         IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
293         IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
294         ibergs_rcvd_from_e = INT( zewbergs(2) )
295         ibergs_rcvd_from_w = INT( zwebergs(2) )
296      CASE(  1 )
297         zewbergs(1) = ibergs_to_send_w
298         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4)
299         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
300         IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
301         ibergs_rcvd_from_w = INT( zwebergs(2) )
302      END SELECT
303      IF( nn_verbose_level >= 3) 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, ipe_N )
414         IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
415         ibergs_rcvd_from_n = INT( znsbergs(2) )
416      CASE(  0 )
417         znsbergs(1) = ibergs_to_send_s
418         zsnbergs(1) = ibergs_to_send_n
419         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2)
420         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3)
421         CALL mpprecv( 15, znsbergs(2), 1, ipe_N )
422         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
423         IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
424         IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
425         ibergs_rcvd_from_n = INT( znsbergs(2) )
426         ibergs_rcvd_from_s = INT( zsnbergs(2) )
427      CASE(  1 )
428         znsbergs(1) = ibergs_to_send_s
429         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4)
430         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
431         IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
432         ibergs_rcvd_from_s = INT( zsnbergs(2) )
433      END SELECT
434      if( nn_verbose_level >= 3) 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      INTEGER                             :: jjn
584      REAL(wp), DIMENSION(0:3)            :: zsbergs, znbergs
585      INTEGER                             :: iml_req1, iml_req2, iml_err
586      INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat
587
588      ! set up indices of neighbouring processors
589
590      ! nicbfldproc is a list of unique processor numbers that this processor
591      ! exchanges with (including itself), so we loop over this array; since
592      ! its of fixed size, the first -1 marks end of list of processors
593      !
594      nicbfldnsend(:) = 0
595      nicbfldexpect(:) = 0
596      nicbfldreq(:) = 0
597      !
598      ! Since each processor may be communicating with more than one northern
599      ! neighbour, cycle through the sends so that the receive order can be
600      ! controlled.
601      !
602      ! First compute how many icebergs each active neighbour should expect
603      DO jn = 1, jpni
604         IF( nicbfldproc(jn) /= -1 ) THEN
605            ifldproc = nicbfldproc(jn)
606            nicbfldnsend(jn) = 0
607
608            ! Find number of bergs that need to be exchanged
609            ! Pick out exchanges with processor ifldproc
610            ! if ifldproc is this processor then don't send
611            !
612            IF( ASSOCIATED(first_berg) ) THEN
613               this => first_berg
614               DO WHILE (ASSOCIATED(this))
615                  pt => this%current_point
616                  iine = INT( pt%xi + 0.5 )
617                  ijne = INT( pt%yj + 0.5 )
618                  iproc = nicbflddest(mi1(iine))
619                  IF( ijne .GT. mjg(nicbej) ) THEN
620                     IF( iproc == ifldproc ) THEN
621                        !
622                        IF( iproc /= narea ) THEN
623                           tmpberg => this
624                           nicbfldnsend(jn) = nicbfldnsend(jn) + 1
625                        ENDIF
626                        !
627                     ENDIF
628                  ENDIF
629                  this => this%next
630               END DO
631            ENDIF
632            !
633         ENDIF
634         !
635      END DO
636      !
637      ! Now tell each active neighbour how many icebergs to expect
638      DO jn = 1, jpni
639         IF( nicbfldproc(jn) /= -1 ) THEN
640            ifldproc = nicbfldproc(jn)
641            IF( ifldproc == narea ) CYCLE
642   
643            zsbergs(0) = narea
644            zsbergs(1) = nicbfldnsend(jn)
645            !IF ( nicbfldnsend(jn) .GT. 0) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc
646            CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn))
647         ENDIF
648         !
649      END DO
650      !
651      ! and receive the heads-up from active neighbours preparing to send
652      DO jn = 1, jpni
653         IF( nicbfldproc(jn) /= -1 ) THEN
654            ifldproc = nicbfldproc(jn)
655            IF( ifldproc == narea ) CYCLE
656
657            CALL mpprecv( 21, znbergs(1:2), 2 )
658            DO jjn = 1,jpni
659             IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT
660            END DO
661            IF( jjn .GT. jpni ) write(numicb,*) 'ICB ERROR'
662            nicbfldexpect(jjn) = INT( znbergs(2) )
663            !IF ( nicbfldexpect(jjn) .GT. 0) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn)
664            !CALL FLUSH(numicb)
665         ENDIF
666         !
667      END DO
668      !
669      ! post the mpi waits if using immediate send protocol
670      DO jn = 1, jpni
671         IF( nicbfldproc(jn) /= -1 ) THEN
672            ifldproc = nicbfldproc(jn)
673            IF( ifldproc == narea ) CYCLE
674
675            IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err )
676         ENDIF
677         !
678      END DO
679   
680         !
681         ! Cycle through the icebergs again, this time packing and sending any
682         ! going through the north fold. They will be expected.
683      DO jn = 1, jpni
684         IF( nicbfldproc(jn) /= -1 ) THEN
685            ifldproc = nicbfldproc(jn)
686            ibergs_to_send = 0
687   
688            ! Find number of bergs that need to be exchanged
689            ! Pick out exchanges with processor ifldproc
690            ! if ifldproc is this processor then don't send
691            !
692            IF( ASSOCIATED(first_berg) ) THEN
693               this => first_berg
694               DO WHILE (ASSOCIATED(this))
695                  pt => this%current_point
696                  iine = INT( pt%xi + 0.5 )
697                  ijne = INT( pt%yj + 0.5 )
698                  ipts  = nicbfldpts (mi1(iine))
699                  iproc = nicbflddest(mi1(iine))
700                  IF( ijne .GT. mjg(nicbej) ) THEN
701                     IF( iproc == ifldproc ) THEN
702                        !
703                        ! moving across the cut line means both position and
704                        ! velocity must change
705                        ijglo = INT( ipts/nicbpack )
706                        iiglo = ipts - nicbpack*ijglo
707                        pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
708                        pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
709                        pt%uvel = -1._wp * pt%uvel
710                        pt%vvel = -1._wp * pt%vvel
711                        !
712                        ! now remove berg from list and pack it into a buffer
713                        IF( iproc /= narea ) THEN
714                           tmpberg => this
715                           ibergs_to_send = ibergs_to_send + 1
716                           IF( nn_verbose_level >= 4 ) THEN
717                              WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold'
718                              CALL flush( numicb )
719                           ENDIF
720                           CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send)
721                           CALL icb_utl_delete(first_berg, tmpberg)
722                        ENDIF
723                        !
724                     ENDIF
725                  ENDIF
726                  this => this%next
727               END DO
728            ENDIF
729            if( nn_verbose_level >= 3) then
730               write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send
731               call flush(numicb)
732            endif
733            !
734            ! if we're in this processor, then we've done everything we need to
735            ! so go on to next element of loop
736            IF( ifldproc == narea ) CYCLE
737   
738            ! send bergs
739   
740            IF( ibergs_to_send > 0 )  &
741                CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) )
742            !
743         ENDIF
744         !
745      END DO
746      !
747      ! Now receive the expected number of bergs from the active neighbours
748      DO jn = 1, jpni
749         IF( nicbfldproc(jn) /= -1 ) THEN
750            ifldproc = nicbfldproc(jn)
751            IF( ifldproc == narea ) CYCLE
752            ibergs_to_rcv = nicbfldexpect(jn)
753
754            IF( ibergs_to_rcv  > 0 ) THEN
755               CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv)
756               CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 )
757            ENDIF
758            !
759            DO jk = 1, ibergs_to_rcv
760               IF( nn_verbose_level >= 4 ) THEN
761                  WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold'
762                  CALL flush( numicb )
763               ENDIF
764               CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk )
765            END DO
766         ENDIF
767         !
768      END DO
769      !
770      ! Finally post the mpi waits if using immediate send protocol
771      DO jn = 1, jpni
772         IF( nicbfldproc(jn) /= -1 ) THEN
773            ifldproc = nicbfldproc(jn)
774            IF( ifldproc == narea ) CYCLE
775
776            IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err )
777         ENDIF
778         !
779      END DO
780      !
781   END SUBROUTINE icb_lbc_mpp_nfld
782
783
784   SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb )
785      !!----------------------------------------------------------------------
786      !!----------------------------------------------------------------------
787      TYPE(iceberg), POINTER :: berg
788      TYPE(buffer) , POINTER :: pbuff
789      INTEGER               , INTENT(in) :: kb
790      !
791      INTEGER ::   k   ! local integer
792      !!----------------------------------------------------------------------
793      !
794      IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
795      IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
796
797      !! pack points into buffer
798
799      pbuff%data( 1,kb) = berg%current_point%lon
800      pbuff%data( 2,kb) = berg%current_point%lat
801      pbuff%data( 3,kb) = berg%current_point%uvel
802      pbuff%data( 4,kb) = berg%current_point%vvel
803      pbuff%data( 5,kb) = berg%current_point%xi
804      pbuff%data( 6,kb) = berg%current_point%yj
805      pbuff%data( 7,kb) = float(berg%current_point%year)
806      pbuff%data( 8,kb) = berg%current_point%day
807      pbuff%data( 9,kb) = berg%current_point%mass
808      pbuff%data(10,kb) = berg%current_point%thickness
809      pbuff%data(11,kb) = berg%current_point%width
810      pbuff%data(12,kb) = berg%current_point%length
811      pbuff%data(13,kb) = berg%current_point%mass_of_bits
812      pbuff%data(14,kb) = berg%current_point%heat_density
813
814      pbuff%data(15,kb) = berg%mass_scaling
815      DO k=1,nkounts
816         pbuff%data(15+k,kb) = REAL( berg%number(k), wp )
817      END DO
818      !
819   END SUBROUTINE icb_pack_into_buffer
820
821
822   SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb)
823      !!----------------------------------------------------------------------
824      !!----------------------------------------------------------------------
825      TYPE(iceberg),             POINTER :: first
826      TYPE(buffer) ,             POINTER :: pbuff
827      INTEGER      , INTENT(in)          :: kb
828      !
829      TYPE(iceberg)                      :: currentberg
830      TYPE(point)                        :: pt
831      INTEGER                            :: ik
832      !!----------------------------------------------------------------------
833      !
834      pt%lon            =      pbuff%data( 1,kb)
835      pt%lat            =      pbuff%data( 2,kb)
836      pt%uvel           =      pbuff%data( 3,kb)
837      pt%vvel           =      pbuff%data( 4,kb)
838      pt%xi             =      pbuff%data( 5,kb)
839      pt%yj             =      pbuff%data( 6,kb)
840      pt%year           = INT( pbuff%data( 7,kb) )
841      pt%day            =      pbuff%data( 8,kb)
842      pt%mass           =      pbuff%data( 9,kb)
843      pt%thickness      =      pbuff%data(10,kb)
844      pt%width          =      pbuff%data(11,kb)
845      pt%length         =      pbuff%data(12,kb)
846      pt%mass_of_bits   =      pbuff%data(13,kb)
847      pt%heat_density   =      pbuff%data(14,kb)
848
849      currentberg%mass_scaling =      pbuff%data(15,kb)
850      DO ik = 1, nkounts
851         currentberg%number(ik) = INT( pbuff%data(15+ik,kb) )
852      END DO
853      !
854      CALL icb_utl_add(currentberg, pt )
855      !
856   END SUBROUTINE icb_unpack_from_buffer
857
858
859   SUBROUTINE icb_increase_buffer(old,kdelta)
860      !!----------------------------------------------------------------------
861      TYPE(buffer), POINTER    :: old
862      INTEGER     , INTENT(in) :: kdelta
863      !
864      TYPE(buffer), POINTER ::   new
865      INTEGER ::   inew_size
866      !!----------------------------------------------------------------------
867      !
868      IF( .NOT. ASSOCIATED(old) ) THEN   ;   inew_size = kdelta
869      ELSE                               ;   inew_size = old%size + kdelta
870      ENDIF
871      ALLOCATE( new )
872      ALLOCATE( new%data( jp_buffer_width, inew_size) )
873      new%size = inew_size
874      IF( ASSOCIATED(old) ) THEN
875         new%data(:,1:old%size) = old%data(:,1:old%size)
876         DEALLOCATE(old%data)
877         DEALLOCATE(old)
878      ENDIF
879      old => new
880      !
881   END SUBROUTINE icb_increase_buffer
882
883
884   SUBROUTINE icb_increase_ibuffer(old,kdelta)
885      !!----------------------------------------------------------------------
886      !!----------------------------------------------------------------------
887      TYPE(buffer),            POINTER :: old
888      INTEGER     , INTENT(in)         :: kdelta
889      !
890      TYPE(buffer),            POINTER :: new
891      INTEGER                          :: inew_size, iold_size
892      !!----------------------------------------------------------------------
893
894      IF( .NOT. ASSOCIATED(old) ) THEN
895         inew_size = kdelta + jp_delta_buf
896         iold_size = 0
897      ELSE
898         iold_size = old%size
899         IF( kdelta .LT. old%size ) THEN
900            inew_size = old%size + kdelta
901         ELSE
902            inew_size = kdelta + jp_delta_buf
903         ENDIF
904      ENDIF
905
906      IF( iold_size .NE. inew_size ) THEN
907         ALLOCATE( new )
908         ALLOCATE( new%data( jp_buffer_width, inew_size) )
909         new%size = inew_size
910         IF( ASSOCIATED(old) ) THEN
911            new%data(:,1:old%size) = old%data(:,1:old%size)
912            DEALLOCATE(old%data)
913            DEALLOCATE(old)
914         ENDIF
915         old => new
916        !WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size
917      ENDIF
918      !
919   END SUBROUTINE icb_increase_ibuffer
920
921#else
922   !!----------------------------------------------------------------------
923   !!   Default case:            Dummy module        share memory computing
924   !!----------------------------------------------------------------------
925   SUBROUTINE icb_lbc_mpp()
926      WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!'
927   END SUBROUTINE icb_lbc_mpp
928
929#endif
930
931   !!======================================================================
932END MODULE icblbc
Note: See TracBrowser for help on using the repository browser.