source: NEMO/branches/UKMO/NEMO_4.0_GO8_package_text_diagnostics/src/OCE/ICB/icblbc.F90 @ 10948

Last change on this file since 10948 was 10948, checked in by andmirek, 19 months ago

GMED 462 iceberg model

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