Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

icblbc.F90 @ 9190

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

Download in other formats: