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/dev_r11078_OSMOSIS_IMMERSE_Nurser/src/OCE/ICB – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11078_OSMOSIS_IMMERSE_Nurser/src/OCE/ICB/icblbc.F90 @ 12928

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

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

Download in other formats: