source: NEMO/branches/2019/fix_ticket2238_solution2/src/OCE/ICB/icblbc.F90 @ 10693

Last change on this file since 10693 was 10693, checked in by mathiot, 3 years ago

add line to move across the north fold cut line intermediate positions/velocities/accelerations (ticket #2238 solution 2)

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