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 trunk/NEMOGCM/NEMO/OPA_SRC/ICB – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90 @ 4624

Last change on this file since 4624 was 3614, checked in by acc, 11 years ago
Branch dev_NOC_2012_r3555. #1006. Step 6: Minor code changes and updated namelists to enable successful SETTE testing
File size: 36.7 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 > 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	! 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. mjg(nicbej) ) THEN
132	!
133	iine = INT( pt%xi + 0.5 )
134	ipts = nicbfldpts (mi1(iine))
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 > mig(nicbei) ) 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 < mig(nicbdi) ) 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. mjg(nicbej) ) 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. mjg(nicbdj) ) 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	IF( iine .LT. mig(nicbdi) .OR. &
545	iine .GT. mig(nicbei) .OR. &
546	ijne .LT. mjg(nicbdj) .OR. &
547	ijne .GT. mjg(nicbej)) THEN
548	i = i + 1
549	WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne
550	WRITE(numicb,*) ' ', nimpp, njmpp
551	WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej
552	CALL flush( numicb )
553	ENDIF
554	this => this%next
555	ENDDO ! WHILE
556	CALL mpp_sum(i)
557	IF( i .GT. 0 ) THEN
558	WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i
559	CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!')
560	ENDIF ! root_pe
561	ENDIF ! debug
562	!
563	CALL mppsync()
564	!
565	END SUBROUTINE icb_lbc_mpp
566
567
568	SUBROUTINE icb_lbc_mpp_nfld()
569	!!----------------------------------------------------------------------
570	!! * SUBROUTINE icb_lbc_mpp_nfld *
571	!!
572	!! ** Purpose : north fold treatment in multi processor exchange
573	!!
574	!! ** Method :
575	!!----------------------------------------------------------------------
576	TYPE(iceberg) , POINTER :: tmpberg, this
577	TYPE(point) , POINTER :: pt
578	INTEGER :: ibergs_to_send
579	INTEGER :: ibergs_to_rcv
580	INTEGER :: iiglo, ijglo, jk, jn
581	INTEGER :: ifldproc, iproc, ipts
582	INTEGER :: iine, ijne
583	REAL(wp), DIMENSION(2) :: 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	DO jn = 1, jpni
594	IF( nicbfldproc(jn) /= -1 ) THEN
595	ifldproc = nicbfldproc(jn)
596	ibergs_to_send = 0
597
598	! Find number of bergs that need to be exchanged
599	! Pick out exchanges with processor ifldproc
600	! if ifldproc is this processor then don't send
601	!
602	IF( ASSOCIATED(first_berg) ) THEN
603	this => first_berg
604	DO WHILE (ASSOCIATED(this))
605	pt => this%current_point
606	iine = INT( pt%xi + 0.5 )
607	ijne = INT( pt%yj + 0.5 )
608	ipts = nicbfldpts (mi1(iine))
609	iproc = nicbflddest(mi1(iine))
610	IF( ijne .GT. mjg(nicbej) ) THEN
611	IF( iproc == ifldproc ) THEN
612	!
613	! moving across the cut line means both position and
614	! velocity must change
615	ijglo = INT( ipts/nicbpack )
616	iiglo = ipts - nicbpack*ijglo
617	pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
618	pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
619	pt%uvel = -1._wp * pt%uvel
620	pt%vvel = -1._wp * pt%vvel
621	!
622	! now remove berg from list and pack it into a buffer
623	IF( iproc /= narea ) THEN
624	tmpberg => this
625	ibergs_to_send = ibergs_to_send + 1
626	IF( nn_verbose_level >= 4 ) THEN
627	WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold'
628	CALL flush( numicb )
629	ENDIF
630	CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send)
631	CALL icb_utl_delete(first_berg, tmpberg)
632	ENDIF
633	!
634	ENDIF
635	ENDIF
636	this => this%next
637	END DO
638	ENDIF
639	if( nn_verbose_level >= 3) then
640	write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send
641	call flush(numicb)
642	endif
643	!
644	! if we're in this processor, then we've done everything we need to
645	! so go on to next element of loop
646	IF( ifldproc == narea ) CYCLE
647
648	zsbergs(1) = ibergs_to_send
649	CALL mppsend( 21, zsbergs(1), 1, ifldproc-1, iml_req1)
650	CALL mpprecv( 21, znbergs(2), 1 )
651	IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
652	ibergs_to_rcv = INT( znbergs(2) )
653
654	! send bergs
655
656	IF( ibergs_to_send > 0 ) &
657	CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 )
658	IF( ibergs_to_rcv > 0 ) THEN
659	CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv)
660	CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width )
661	ENDIF
662	IF( ibergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
663	DO jk = 1, ibergs_to_rcv
664	IF( nn_verbose_level >= 4 ) THEN
665	WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold'
666	CALL flush( numicb )
667	ENDIF
668	CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk )
669	END DO
670	!
671	ENDIF
672	!
673	END DO
674	!
675	END SUBROUTINE icb_lbc_mpp_nfld
676
677
678	SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb )
679	!!----------------------------------------------------------------------
680	!!----------------------------------------------------------------------
681	TYPE(iceberg), POINTER :: berg
682	TYPE(buffer) , POINTER :: pbuff
683	INTEGER , INTENT(in) :: kb
684	!
685	INTEGER :: k ! local integer
686	!!----------------------------------------------------------------------
687	!
688	IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
689	IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
690
691	!! pack points into buffer
692
693	pbuff%data( 1,kb) = berg%current_point%lon
694	pbuff%data( 2,kb) = berg%current_point%lat
695	pbuff%data( 3,kb) = berg%current_point%uvel
696	pbuff%data( 4,kb) = berg%current_point%vvel
697	pbuff%data( 5,kb) = berg%current_point%xi
698	pbuff%data( 6,kb) = berg%current_point%yj
699	pbuff%data( 7,kb) = float(berg%current_point%year)
700	pbuff%data( 8,kb) = berg%current_point%day
701	pbuff%data( 9,kb) = berg%current_point%mass
702	pbuff%data(10,kb) = berg%current_point%thickness
703	pbuff%data(11,kb) = berg%current_point%width
704	pbuff%data(12,kb) = berg%current_point%length
705	pbuff%data(13,kb) = berg%current_point%mass_of_bits
706	pbuff%data(14,kb) = berg%current_point%heat_density
707
708	pbuff%data(15,kb) = berg%mass_scaling
709	DO k=1,nkounts
710	pbuff%data(15+k,kb) = REAL( berg%number(k), wp )
711	END DO
712	!
713	END SUBROUTINE icb_pack_into_buffer
714
715
716	SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb)
717	!!----------------------------------------------------------------------
718	!!----------------------------------------------------------------------
719	TYPE(iceberg), POINTER :: first
720	TYPE(buffer) , POINTER :: pbuff
721	INTEGER , INTENT(in) :: kb
722	!
723	TYPE(iceberg) :: currentberg
724	TYPE(point) :: pt
725	INTEGER :: ik
726	!!----------------------------------------------------------------------
727	!
728	pt%lon = pbuff%data( 1,kb)
729	pt%lat = pbuff%data( 2,kb)
730	pt%uvel = pbuff%data( 3,kb)
731	pt%vvel = pbuff%data( 4,kb)
732	pt%xi = pbuff%data( 5,kb)
733	pt%yj = pbuff%data( 6,kb)
734	pt%year = INT( pbuff%data( 7,kb) )
735	pt%day = pbuff%data( 8,kb)
736	pt%mass = pbuff%data( 9,kb)
737	pt%thickness = pbuff%data(10,kb)
738	pt%width = pbuff%data(11,kb)
739	pt%length = pbuff%data(12,kb)
740	pt%mass_of_bits = pbuff%data(13,kb)
741	pt%heat_density = pbuff%data(14,kb)
742
743	currentberg%mass_scaling = pbuff%data(15,kb)
744	DO ik = 1, nkounts
745	currentberg%number(ik) = INT( pbuff%data(15+ik,kb) )
746	END DO
747	!
748	CALL icb_utl_add(currentberg, pt )
749	!
750	END SUBROUTINE icb_unpack_from_buffer
751
752
753	SUBROUTINE icb_increase_buffer(old,kdelta)
754	!!----------------------------------------------------------------------
755	TYPE(buffer), POINTER :: old
756	INTEGER , INTENT(in) :: kdelta
757	!
758	TYPE(buffer), POINTER :: new
759	INTEGER :: inew_size
760	!!----------------------------------------------------------------------
761	!
762	IF( .NOT. ASSOCIATED(old) ) THEN ; inew_size = kdelta
763	ELSE ; inew_size = old%size + kdelta
764	ENDIF
765	ALLOCATE( new )
766	ALLOCATE( new%data( jp_buffer_width, inew_size) )
767	new%size = inew_size
768	IF( ASSOCIATED(old) ) THEN
769	new%data(:,1:old%size) = old%data(:,1:old%size)
770	DEALLOCATE(old%data)
771	DEALLOCATE(old)
772	ENDIF
773	old => new
774	!
775	END SUBROUTINE icb_increase_buffer
776
777
778	SUBROUTINE icb_increase_ibuffer(old,kdelta)
779	!!----------------------------------------------------------------------
780	!!----------------------------------------------------------------------
781	TYPE(buffer), POINTER :: old
782	INTEGER , INTENT(in) :: kdelta
783	!
784	TYPE(buffer), POINTER :: new
785	INTEGER :: inew_size, iold_size
786	!!----------------------------------------------------------------------
787
788	IF( .NOT. ASSOCIATED(old) ) THEN
789	inew_size = kdelta + jp_delta_buf
790	iold_size = 0
791	ELSE
792	iold_size = old%size
793	IF( kdelta .LT. old%size ) THEN
794	inew_size = old%size + kdelta
795	ELSE
796	inew_size = kdelta + jp_delta_buf
797	ENDIF
798	ENDIF
799
800	IF( iold_size .NE. inew_size ) THEN
801	ALLOCATE( new )
802	ALLOCATE( new%data( jp_buffer_width, inew_size) )
803	new%size = inew_size
804	IF( ASSOCIATED(old) ) THEN
805	new%data(:,1:old%size) = old%data(:,1:old%size)
806	DEALLOCATE(old%data)
807	DEALLOCATE(old)
808	ENDIF
809	old => new
810	!WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size
811	ENDIF
812	!
813	END SUBROUTINE icb_increase_ibuffer
814
815	#else
816	!!----------------------------------------------------------------------
817	!! Default case: Dummy module share memory computing
818	!!----------------------------------------------------------------------
819	SUBROUTINE icb_lbc_mpp()
820	WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!'
821	END SUBROUTINE icb_lbc_mpp
822
823	#endif
824
825	!!======================================================================
826	END MODULE icblbc

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

Download in other formats: