Context Navigation

icblbc.F90 @ 12377

Last change on this file since 12377 was 12377, checked in by acc, 5 years ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge --ignore-ancestry \

svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The --ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

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.

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

Context Navigation

source: NEMO/trunk/src/OCE/ICB/icblbc.F90 @ 12377

Download in other formats: