source: branches/UKMO/dev_r5518_GO6_under_ice_relax_dr_hook/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90 @ 11738

Last change on this file since 11738 was 11738, checked in by marc, 12 months ago

The Dr Hook changes from my perl code.

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