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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

icblbc.F90 in NEMO/branches/2019/fix_ticket2238_solution2/src/OCE/ICB – NEMO

Context Navigation

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, 5 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
1	MODULE 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	!!----------------------------------------------------------------------
70	CONTAINS
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	!!======================================================================
964	END MODULE icblbc

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

Download in other formats: