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 branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB – NEMO

Context Navigation

source: branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90 @ 3372

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

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

Download in other formats: