Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

icblbc.F90 @ 11738

Last change on this file since 11738 was 11738, checked in by marc, 5 years ago
The Dr Hook changes from my perl code.
File size: 43.4 KB

Line
1	MODULE 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	!!----------------------------------------------------------------------
75	CONTAINS
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	!!======================================================================
1016	END MODULE icblbc

Note: See TracBrowser for help on using the repository browser.

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

Context Navigation

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

Download in other formats: