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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

icblbc.F90 in branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB – NEMO

Context Navigation

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

Last change on this file since 3339 was 3339, checked in by sga, 12 years ago
NEMO branch dev_r3337_NOCS10_ICB: add new iceberg sub-directory ICB
File size: 36.9 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	!! mpp_send_bergs : 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 (icbdi-icbei, icbdj-icbej)
22	!! so that iceberg does not exist in more than one processor
23	!! North fold exchanges controlled by three arrays:
24	!! icbflddest - unique processor numbers that current one exchanges with
25	!! icbfldproc - processor number that current grid point exchanges with
26	!! icbfldpts - packed i,j point in exchanging processor
27	!!----------------------------------------------------------------------
28
29	USE par_oce ! ocean parameters
30	USE dom_oce ! ocean domain
31	USE in_out_manager ! IO parameters
32	USE lib_mpp ! MPI code and lk_mpp in particular
33	USE icb_oce ! define iceberg arrays
34	USE icbutl ! iceberg utility routines
35
36	IMPLICIT NONE
37	PRIVATE
38
39	#if defined key_mpp_mpi
40
41	!$AGRIF_DO_NOT_TREAT
42	INCLUDE 'mpif.h'
43	!$AGRIF_END_DO_NOT_TREAT
44
45	TYPE, PUBLIC :: buffer
46	INTEGER :: size=0
47	REAL(wp), DIMENSION(:,:), POINTER :: data
48	END TYPE buffer
49
50	TYPE(buffer), POINTER :: obuffer_n=>NULL() , ibuffer_n=>NULL()
51	TYPE(buffer), POINTER :: obuffer_s=>NULL() , ibuffer_s=>NULL()
52	TYPE(buffer), POINTER :: obuffer_e=>NULL() , ibuffer_e=>NULL()
53	TYPE(buffer), POINTER :: obuffer_w=>NULL() , ibuffer_w=>NULL()
54
55	! north fold exchange buffers
56	TYPE(buffer), POINTER :: obuffer_f=>NULL() , ibuffer_f=>NULL()
57
58	INTEGER, PARAMETER, PUBLIC :: delta_buf = 25 ! Size by which to increment buffers
59	INTEGER, PARAMETER, PUBLIC :: buffer_width = 15+nkounts ! items to store for each berg
60
61	#endif
62
63	PUBLIC lbc_send_bergs
64	PRIVATE lbc_nfld_bergs
65	PUBLIC mpp_send_bergs
66	PUBLIC dealloc_buffers
67
68	#if defined key_mpp_mpi
69	PRIVATE mpp_nfld_bergs
70	PRIVATE dealloc_buffer
71	PRIVATE pack_berg_into_buffer
72	PRIVATE unpack_berg_from_buffer
73	PRIVATE increase_buffer
74	PRIVATE increase_ibuffer
75	#endif
76
77	!!-------------------------------------------------------------------------
78	CONTAINS
79
80	SUBROUTINE lbc_send_bergs()
81	!!----------------------------------------------------------------------
82	!! * SUBROUTINE lbc_send_bergs *
83	!!
84	!! ** Purpose : in non-mpp case need to deal with cyclic conditions
85	!! including north-fold
86	!!----------------------------------------------------------------------
87	! Local variables
88	TYPE(iceberg), POINTER :: this
89	TYPE(point) , POINTER :: pt
90	INTEGER :: ine
91
92	!! periodic east/west boundaries
93	!! =============================
94
95	IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
96
97	this => first_berg
98	DO WHILE( ASSOCIATED(this) )
99	pt => this%current_point
100	ine = INT( pt%xi + 0.5 )
101	IF( ine .GT. nimpp+icbei-1 ) THEN
102	pt%xi = icb_right + MOD(pt%xi, 1._wp ) - 1._wp
103	ELSE IF( ine .LT. nimpp+icbdi-1 ) THEN
104	pt%xi = icb_left + MOD(pt%xi, 1._wp )
105	ENDIF
106	this => this%next
107	ENDDO
108
109	ENDIF
110
111	!! north/south boundaries
112	!! ======================
113
114	!! south symmetric
115
116	IF( nperio == 2 ) THEN
117	CALL ctl_stop(' south symmetric condition not implemented for icebergs')
118	ENDIF
119
120	!! north fold
121
122	IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 ) CALL lbc_nfld_bergs()
123
124	END SUBROUTINE lbc_send_bergs
125
126	!!-------------------------------------------------------------------------
127
128	SUBROUTINE lbc_nfld_bergs()
129	!!----------------------------------------------------------------------
130	!! * SUBROUTINE lbc_nfld_bergs *
131	!!
132	!! ** Purpose : single processor north fold exchange
133	!!----------------------------------------------------------------------
134	!
135	! Local variables
136	TYPE(iceberg), POINTER :: this
137	TYPE(point) , POINTER :: pt
138	INTEGER :: ine, jne, kpts
139	INTEGER :: jiglo, jjglo
140
141	this => first_berg
142	DO WHILE( ASSOCIATED(this) )
143	pt => this%current_point
144	jne = INT( pt%yj + 0.5 )
145	IF( jne .GT. njmpp+icbej-1 ) THEN
146	!
147	ine = INT( pt%xi + 0.5 )
148	kpts = icbfldpts (ine-nimpp+1)
149	!
150	! moving across the cut line means both position and
151	! velocity must change
152	jjglo = INT( kpts/icbpack )
153	jiglo = kpts - icbpack*jjglo
154	pt%xi = jiglo - ( pt%xi - REAL(ine,wp) )
155	pt%yj = jjglo - ( pt%yj - REAL(jne,wp) )
156	pt%uvel = -1._wp * pt%uvel
157	pt%vvel = -1._wp * pt%vvel
158	ENDIF
159	this => this%next
160	ENDDO
161
162	END SUBROUTINE lbc_nfld_bergs
163
164	!!-------------------------------------------------------------------------
165
166	#if defined key_mpp_mpi
167
168	SUBROUTINE mpp_send_bergs()
169	!!----------------------------------------------------------------------
170	!! * SUBROUTINE mpp_send_bergs *
171	!!
172	!! ** Purpose : multi processor exchange
173	!!
174	!! ** Method : identify direction for exchange, pack into a buffer
175	!! which is basically a real array and delete from linked list
176	!! length of buffer is exchanged first with receiving processor
177	!! then buffer is sent if necessary
178	!!----------------------------------------------------------------------
179
180	! Local variables
181	TYPE(iceberg) , POINTER :: tmpberg, this
182	TYPE(point) , POINTER :: pt
183	INTEGER :: nbergs_to_send_e, nbergs_to_send_w
184	INTEGER :: nbergs_to_send_n, nbergs_to_send_s
185	INTEGER :: nbergs_rcvd_from_e, nbergs_rcvd_from_w
186	INTEGER :: nbergs_rcvd_from_n, nbergs_rcvd_from_s
187	INTEGER :: i, nbergs_start, nbergs_end
188	INTEGER :: ine, jne
189	INTEGER :: pe_N, pe_S, pe_W, pe_E
190	REAL(wp), DIMENSION(2) :: ewbergs, webergs, nsbergs, snbergs
191	INTEGER :: ml_req1, ml_req2, ml_req3, ml_req4
192	INTEGER :: ml_req5, ml_req6, ml_req7, ml_req8, ml_err
193	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat
194
195	! set up indices of neighbouring processors
196	pe_N = -1
197	pe_S = -1
198	pe_W = -1
199	pe_E = -1
200	IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) pe_W = nowe
201	IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) pe_E = noea
202	IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) pe_S = noso
203	IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) pe_N = nono
204	!
205	! at northern line of processors with north fold handle bergs differently
206	IF( npolj > 0 ) pe_N = -1
207
208	! if there's only one processor in x direction then don't let mpp try to handle periodicity
209	IF( jpni == 1 ) THEN
210	pe_E = -1
211	pe_W = -1
212	ENDIF
213
214	IF( nn_verbose_level >= 2 ) THEN
215	WRITE(numicb,*) 'processor west : ', pe_W
216	WRITE(numicb,*) 'processor east : ', pe_E
217	WRITE(numicb,*) 'processor north : ', pe_N
218	WRITE(numicb,*) 'processor south : ', pe_S
219	WRITE(numicb,*) 'processor nimpp : ', nimpp
220	WRITE(numicb,*) 'processor njmpp : ', njmpp
221	WRITE(numicb,*) 'processor nbondi: ', nbondi
222	WRITE(numicb,*) 'processor nbondj: ', nbondj
223	CALL flush( numicb )
224	ENDIF
225
226	! periodicity is handled here when using mpp when there is more than one processor in
227	! the i direction, but it also has to happen when jpni=1 case so this is dealt with
228	! in lbc_send_bergs and called here
229
230	IF( jpni == 1 ) CALL lbc_send_bergs()
231
232	! Note that xi is adjusted when swapping because of periodic condition
233
234	IF( nn_verbose_level > 0 ) THEN
235	! store the number of icebergs on this processor at start
236	nbergs_start = count_bergs()
237	ENDIF
238
239	nbergs_to_send_e = 0
240	nbergs_to_send_w = 0
241	nbergs_to_send_n = 0
242	nbergs_to_send_s = 0
243	nbergs_rcvd_from_e = 0
244	nbergs_rcvd_from_w = 0
245	nbergs_rcvd_from_n = 0
246	nbergs_rcvd_from_s = 0
247
248	! Find number of bergs that headed east/west
249	IF( ASSOCIATED(first_berg) ) THEN
250	this => first_berg
251	DO WHILE (ASSOCIATED(this))
252	pt => this%current_point
253	ine = INT( pt%xi + 0.5 )
254	IF( pe_E >= 0 .AND. ine .GT. nimpp+icbei-1 ) THEN
255	tmpberg => this
256	this => this%next
257	nbergs_to_send_e = nbergs_to_send_e + 1
258	IF( nn_verbose_level >= 4 ) THEN
259	WRITE(numicb,*) 'bergstep ',ktberg,' packing berg ',tmpberg%number(:),' for transfer to east'
260	CALL flush( numicb )
261	ENDIF
262	! deal with periodic case
263	tmpberg%current_point%xi = icb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp
264	! now pack it into buffer and delete from list
265	CALL pack_berg_into_buffer( tmpberg, obuffer_e, nbergs_to_send_e)
266	CALL delete_iceberg_from_list(first_berg, tmpberg)
267	ELSE IF( pe_W >= 0 .AND. ine .LT. nimpp+icbdi-1 ) THEN
268	tmpberg => this
269	this => this%next
270	nbergs_to_send_w = nbergs_to_send_w + 1
271	IF( nn_verbose_level >= 4 ) THEN
272	WRITE(numicb,*) 'bergstep ',ktberg,' packing berg ',tmpberg%number(:),' for transfer to west'
273	CALL flush( numicb )
274	ENDIF
275	! deal with periodic case
276	tmpberg%current_point%xi = icb_left + MOD(tmpberg%current_point%xi, 1._wp )
277	! now pack it into buffer and delete from list
278	CALL pack_berg_into_buffer( tmpberg, obuffer_w, nbergs_to_send_w)
279	CALL delete_iceberg_from_list(first_berg, tmpberg)
280	ELSE
281	this => this%next
282	ENDIF
283	ENDDO
284	ENDIF
285	if( nn_verbose_level >= 3) then
286	write(numicb,*) 'bergstep ',ktberg,' send ew: ', nbergs_to_send_e, nbergs_to_send_w
287	call flush(numicb)
288	endif
289
290	! send bergs east and receive bergs from west (ie ones that were sent east)
291	! and vice versa
292
293	! pattern here is copied from lib_mpp code
294
295	SELECT CASE ( nbondi )
296	CASE( -1 )
297	webergs(1) = nbergs_to_send_e
298	CALL mppsend( 12, webergs(1), 1, pe_E, ml_req1)
299	CALL mpprecv( 11, ewbergs(2), 1 )
300	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
301	nbergs_rcvd_from_e = INT( ewbergs(2) )
302	CASE( 0 )
303	ewbergs(1) = nbergs_to_send_w
304	webergs(1) = nbergs_to_send_e
305	CALL mppsend( 11, ewbergs(1), 1, pe_W, ml_req2)
306	CALL mppsend( 12, webergs(1), 1, pe_E, ml_req3)
307	CALL mpprecv( 11, ewbergs(2), 1 )
308	CALL mpprecv( 12, webergs(2), 1 )
309	IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
310	IF( l_isend ) CALL mpi_wait( ml_req3, ml_stat, ml_err )
311	nbergs_rcvd_from_e = INT( ewbergs(2) )
312	nbergs_rcvd_from_w = INT( webergs(2) )
313	CASE( 1 )
314	ewbergs(1) = nbergs_to_send_w
315	CALL mppsend( 11, ewbergs(1), 1, pe_W, ml_req4)
316	CALL mpprecv( 12, webergs(2), 1 )
317	IF( l_isend ) CALL mpi_wait( ml_req4, ml_stat, ml_err )
318	nbergs_rcvd_from_w = INT( webergs(2) )
319	END SELECT
320	if( nn_verbose_level >= 3) then
321	write(numicb,*) 'bergstep ',ktberg,' recv ew: ', nbergs_rcvd_from_w, nbergs_rcvd_from_e
322	call flush(numicb)
323	endif
324
325	SELECT CASE ( nbondi )
326	CASE( -1 )
327	IF( nbergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, nbergs_to_send_e*buffer_width, pe_E, ml_req1 )
328	IF( nbergs_rcvd_from_e > 0 ) THEN
329	CALL increase_ibuffer(ibuffer_e, nbergs_rcvd_from_e)
330	CALL mpprecv( 13, ibuffer_e%data, nbergs_rcvd_from_e*buffer_width )
331	ENDIF
332	IF( nbergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
333	DO i = 1, nbergs_rcvd_from_e
334	IF( nn_verbose_level >= 4 ) THEN
335	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
336	CALL flush( numicb )
337	ENDIF
338	CALL unpack_berg_from_buffer(first_berg, ibuffer_e, i)
339	ENDDO
340	CASE( 0 )
341	IF( nbergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, nbergs_to_send_w*buffer_width, pe_W, ml_req2 )
342	IF( nbergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, nbergs_to_send_e*buffer_width, pe_E, ml_req3 )
343	IF( nbergs_rcvd_from_e > 0 ) THEN
344	CALL increase_ibuffer(ibuffer_e, nbergs_rcvd_from_e)
345	CALL mpprecv( 13, ibuffer_e%data, nbergs_rcvd_from_e*buffer_width )
346	ENDIF
347	IF( nbergs_rcvd_from_w > 0 ) THEN
348	CALL increase_ibuffer(ibuffer_w, nbergs_rcvd_from_w)
349	CALL mpprecv( 14, ibuffer_w%data, nbergs_rcvd_from_w*buffer_width )
350	ENDIF
351	IF( nbergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
352	IF( nbergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( ml_req3, ml_stat, ml_err )
353	DO i = 1, nbergs_rcvd_from_e
354	IF( nn_verbose_level >= 4 ) THEN
355	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
356	CALL flush( numicb )
357	ENDIF
358	CALL unpack_berg_from_buffer(first_berg, ibuffer_e, i)
359	ENDDO
360	DO i = 1, nbergs_rcvd_from_w
361	IF( nn_verbose_level >= 4 ) THEN
362	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
363	CALL flush( numicb )
364	ENDIF
365	CALL unpack_berg_from_buffer(first_berg, ibuffer_w, i)
366	ENDDO
367	CASE( 1 )
368	IF( nbergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, nbergs_to_send_w*buffer_width, pe_W, ml_req4 )
369	IF( nbergs_rcvd_from_w > 0 ) THEN
370	CALL increase_ibuffer(ibuffer_w, nbergs_rcvd_from_w)
371	CALL mpprecv( 14, ibuffer_w%data, nbergs_rcvd_from_w*buffer_width )
372	ENDIF
373	IF( nbergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( ml_req4, ml_stat, ml_err )
374	DO i = 1, nbergs_rcvd_from_w
375	IF( nn_verbose_level >= 4 ) THEN
376	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
377	CALL flush( numicb )
378	ENDIF
379	CALL unpack_berg_from_buffer(first_berg, ibuffer_w, i)
380	ENDDO
381	END SELECT
382
383	! Find number of bergs that headed north/south
384	! (note: this block should technically go ahead of the E/W recv block above
385	! to handle arbitrary orientation of PEs. But for simplicity, it is
386	! here to accomodate diagonal transfer of bergs between PEs -AJA)
387
388	IF( ASSOCIATED(first_berg) ) THEN
389	this => first_berg
390	DO WHILE (ASSOCIATED(this))
391	pt => this%current_point
392	jne = INT( pt%yj + 0.5 )
393	IF( pe_N >= 0 .AND. jne .GT. njmpp+icbej-1 ) THEN
394	tmpberg => this
395	this => this%next
396	nbergs_to_send_n = nbergs_to_send_n + 1
397	IF( nn_verbose_level >= 4 ) THEN
398	WRITE(numicb,*) 'bergstep ',ktberg,' packing berg ',tmpberg%number(:),' for transfer to north'
399	CALL flush( numicb )
400	ENDIF
401	CALL pack_berg_into_buffer( tmpberg, obuffer_n, nbergs_to_send_n)
402	CALL delete_iceberg_from_list(first_berg, tmpberg)
403	ELSE IF( pe_S >= 0 .AND. jne .LT. njmpp+icbdj-1 ) THEN
404	tmpberg => this
405	this => this%next
406	nbergs_to_send_s = nbergs_to_send_s + 1
407	IF( nn_verbose_level >= 4 ) THEN
408	WRITE(numicb,*) 'bergstep ',ktberg,' packing berg ',tmpberg%number(:),' for transfer to south'
409	CALL flush( numicb )
410	ENDIF
411	CALL pack_berg_into_buffer( tmpberg, obuffer_s, nbergs_to_send_s)
412	CALL delete_iceberg_from_list(first_berg, tmpberg)
413	ELSE
414	this => this%next
415	ENDIF
416	ENDDO
417	ENDIF
418	if( nn_verbose_level >= 3) then
419	write(numicb,*) 'bergstep ',ktberg,' send ns: ', nbergs_to_send_n, nbergs_to_send_s
420	call flush(numicb)
421	endif
422
423	! send bergs north
424	! and receive bergs from south (ie ones sent north)
425
426	SELECT CASE ( nbondj )
427	CASE( -1 )
428	snbergs(1) = nbergs_to_send_n
429	CALL mppsend( 16, snbergs(1), 1, pe_N, ml_req1)
430	CALL mpprecv( 15, nsbergs(2), 1 )
431	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
432	nbergs_rcvd_from_n = INT( nsbergs(2) )
433	CASE( 0 )
434	nsbergs(1) = nbergs_to_send_s
435	snbergs(1) = nbergs_to_send_n
436	CALL mppsend( 15, nsbergs(1), 1, pe_S, ml_req2)
437	CALL mppsend( 16, snbergs(1), 1, pe_N, ml_req3)
438	CALL mpprecv( 15, nsbergs(2), 1 )
439	CALL mpprecv( 16, snbergs(2), 1 )
440	IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
441	IF( l_isend ) CALL mpi_wait( ml_req3, ml_stat, ml_err )
442	nbergs_rcvd_from_n = INT( nsbergs(2) )
443	nbergs_rcvd_from_s = INT( snbergs(2) )
444	CASE( 1 )
445	nsbergs(1) = nbergs_to_send_s
446	CALL mppsend( 15, nsbergs(1), 1, pe_S, ml_req4)
447	CALL mpprecv( 16, snbergs(2), 1 )
448	IF( l_isend ) CALL mpi_wait( ml_req4, ml_stat, ml_err )
449	nbergs_rcvd_from_s = INT( snbergs(2) )
450	END SELECT
451	if( nn_verbose_level >= 3) then
452	write(numicb,*) 'bergstep ',ktberg,' recv ns: ', nbergs_rcvd_from_s, nbergs_rcvd_from_n
453	call flush(numicb)
454	endif
455
456	SELECT CASE ( nbondj )
457	CASE( -1 )
458	IF( nbergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, nbergs_to_send_n*buffer_width, pe_N, ml_req1 )
459	IF( nbergs_rcvd_from_n > 0 ) THEN
460	CALL increase_ibuffer(ibuffer_n, nbergs_rcvd_from_n)
461	CALL mpprecv( 17, ibuffer_n%data, nbergs_rcvd_from_n*buffer_width )
462	ENDIF
463	IF( nbergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
464	DO i = 1, nbergs_rcvd_from_n
465	IF( nn_verbose_level >= 4 ) THEN
466	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
467	CALL flush( numicb )
468	ENDIF
469	CALL unpack_berg_from_buffer(first_berg, ibuffer_n, i)
470	ENDDO
471	CASE( 0 )
472	IF( nbergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, nbergs_to_send_s*buffer_width, pe_S, ml_req2 )
473	IF( nbergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, nbergs_to_send_n*buffer_width, pe_N, ml_req3 )
474	IF( nbergs_rcvd_from_n > 0 ) THEN
475	CALL increase_ibuffer(ibuffer_n, nbergs_rcvd_from_n)
476	CALL mpprecv( 17, ibuffer_n%data, nbergs_rcvd_from_n*buffer_width )
477	ENDIF
478	IF( nbergs_rcvd_from_s > 0 ) THEN
479	CALL increase_ibuffer(ibuffer_s, nbergs_rcvd_from_s)
480	CALL mpprecv( 18, ibuffer_s%data, nbergs_rcvd_from_s*buffer_width )
481	ENDIF
482	IF( nbergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
483	IF( nbergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( ml_req3, ml_stat, ml_err )
484	DO i = 1, nbergs_rcvd_from_n
485	IF( nn_verbose_level >= 4 ) THEN
486	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
487	CALL flush( numicb )
488	ENDIF
489	CALL unpack_berg_from_buffer(first_berg, ibuffer_n, i)
490	ENDDO
491	DO i = 1, nbergs_rcvd_from_s
492	IF( nn_verbose_level >= 4 ) THEN
493	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
494	CALL flush( numicb )
495	ENDIF
496	CALL unpack_berg_from_buffer(first_berg, ibuffer_s, i)
497	ENDDO
498	CASE( 1 )
499	IF( nbergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, nbergs_to_send_s*buffer_width, pe_S, ml_req4 )
500	IF( nbergs_rcvd_from_s > 0 ) THEN
501	CALL increase_ibuffer(ibuffer_s, nbergs_rcvd_from_s)
502	CALL mpprecv( 18, ibuffer_s%data, nbergs_rcvd_from_s*buffer_width )
503	ENDIF
504	IF( nbergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( ml_req4, ml_stat, ml_err )
505	DO i = 1, nbergs_rcvd_from_s
506	IF( nn_verbose_level >= 4 ) THEN
507	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
508	CALL flush( numicb )
509	ENDIF
510	CALL unpack_berg_from_buffer(first_berg, ibuffer_s, i)
511	ENDDO
512	END SELECT
513
514	IF( nn_verbose_level > 0 ) THEN
515	! compare the number of icebergs on this processor from the start to the end
516	nbergs_end = count_bergs()
517	i = ( nbergs_rcvd_from_n + nbergs_rcvd_from_s + nbergs_rcvd_from_e + nbergs_rcvd_from_w ) - &
518	( nbergs_to_send_n + nbergs_to_send_s + nbergs_to_send_e + nbergs_to_send_w )
519	IF( nbergs_end-(nbergs_start+i) .NE. 0 ) THEN
520	WRITE( numicb,* ) 'send_bergs_to_other_pes: net change in number of icebergs'
521	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_end=', &
522	nbergs_end,' on PE',narea
523	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_start=', &
524	nbergs_start,' on PE',narea
525	WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', &
526	i,' on PE',narea
527	WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', &
528	nbergs_end-(nbergs_start+i),' on PE',narea
529	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_n=', &
530	nbergs_to_send_n,' on PE',narea
531	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_s=', &
532	nbergs_to_send_s,' on PE',narea
533	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_e=', &
534	nbergs_to_send_e,' on PE',narea
535	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_to_send_w=', &
536	nbergs_to_send_w,' on PE',narea
537	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_n=', &
538	nbergs_rcvd_from_n,' on PE',narea
539	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_s=', &
540	nbergs_rcvd_from_s,' on PE',narea
541	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_e=', &
542	nbergs_rcvd_from_e,' on PE',narea
543	WRITE( numicb,1000) 'send_bergs_to_other_pes: nbergs_rcvd_from_w=', &
544	nbergs_rcvd_from_w,' on PE',narea
545	1000 FORMAT(a,i5,a,i4)
546	CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two')
547	ENDIF
548	ENDIF
549
550	! deal with north fold if we necessary when there is more than one top row processor
551	! note that for jpni=1 north fold has been dealt with above in call to lbc_send_bergs
552	IF( npolj /= 0 .AND. jpni > 1 ) CALL mpp_nfld_bergs( )
553
554	IF( nn_verbose_level > 0 ) THEN
555	i = 0
556	this => first_berg
557	DO WHILE (ASSOCIATED(this))
558	pt => this%current_point
559	ine = INT( pt%xi + 0.5 )
560	jne = INT( pt%yj + 0.5 )
561	! CALL check_position(grd, this, 'exchange (bot)')
562	IF( ine .LT. nimpp+icbdi-1 .OR. &
563	ine .GT. nimpp+icbei-1 .OR. &
564	jne .LT. njmpp+icbdj-1 .OR. &
565	jne .GT. njmpp+icbej-1) THEN
566	i = i + 1
567	WRITE(numicb,*) 'berg lost in halo: ', this%number(:),ine,jne
568	WRITE(numicb,*) ' ', nimpp, njmpp
569	WRITE(numicb,*) ' ', icbdi, icbei, icbdj, icbej
570	CALL flush( numicb )
571	ENDIF
572	this => this%next
573	ENDDO ! WHILE
574	CALL mpp_sum(i)
575	IF( i .GT. 0 ) THEN
576	WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i
577	CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!')
578	ENDIF ! root_pe
579	ENDIF ! debug
580
581	CALL mppsync()
582
583	END SUBROUTINE mpp_send_bergs
584
585	!!-------------------------------------------------------------------------
586
587	SUBROUTINE mpp_nfld_bergs()
588
589	! Local variables
590	TYPE(iceberg) , POINTER :: tmpberg, this
591	TYPE(point) , POINTER :: pt
592	INTEGER :: nbergs_to_send
593	INTEGER :: nbergs_to_rcv
594	INTEGER :: jiglo, jjglo, jk, jn
595	INTEGER :: jfldproc, kproc, kpts
596	INTEGER :: ine, jne
597	REAL(wp), DIMENSION(2) :: sbergs, nbergs
598	INTEGER :: ml_req1, ml_req2, ml_err
599	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat
600
601	! set up indices of neighbouring processors
602
603	! icbfldproc is a list of unique processor numbers that this processor
604	! exchanges with (including itself), so we loop over this array; since
605	! its of fixed size, the first -1 marks end of list of processors
606	!
607	DO jn = 1, jpni
608	IF( icbfldproc(jn) == -1 ) EXIT
609	jfldproc = icbfldproc(jn)
610	nbergs_to_send = 0
611
612	! Find number of bergs that need to be exchanged
613	! Pick out exchanges with processor jfldproc
614	! if jfldproc is this processor then don't send
615	!
616	IF( ASSOCIATED(first_berg) ) THEN
617	this => first_berg
618	DO WHILE (ASSOCIATED(this))
619	pt => this%current_point
620	ine = INT( pt%xi + 0.5 )
621	jne = INT( pt%yj + 0.5 )
622	kpts = icbfldpts (ine-nimpp+1)
623	kproc = icbflddest(ine-nimpp+1)
624	IF( jne .GT. njmpp+icbej-1 ) THEN
625	IF( kproc == jfldproc ) THEN
626	!
627	! moving across the cut line means both position and
628	! velocity must change
629	jjglo = INT( kpts/icbpack )
630	jiglo = kpts - icbpack*jjglo
631	pt%xi = jiglo - ( pt%xi - REAL(ine,wp) )
632	pt%yj = jjglo - ( pt%yj - REAL(jne,wp) )
633	pt%uvel = -1._wp * pt%uvel
634	pt%vvel = -1._wp * pt%vvel
635	!
636	! now remove berg from list and pack it into a buffer
637	IF( kproc /= narea ) THEN
638	tmpberg => this
639	nbergs_to_send = nbergs_to_send + 1
640	IF( nn_verbose_level >= 4 ) THEN
641	WRITE(numicb,*) 'bergstep ',ktberg,' packing berg ',tmpberg%number(:),' for north fold'
642	CALL flush( numicb )
643	ENDIF
644	CALL pack_berg_into_buffer( tmpberg, obuffer_f, nbergs_to_send)
645	CALL delete_iceberg_from_list(first_berg, tmpberg)
646	ENDIF
647	!
648	ENDIF
649	ENDIF
650	this => this%next
651	ENDDO
652	ENDIF
653	if( nn_verbose_level >= 3) then
654	write(numicb,*) 'bergstep ',ktberg,' send nfld: ', nbergs_to_send
655	call flush(numicb)
656	endif
657	!
658	! if we're in this processor, then we've done everything we need to
659	! so go on to next element of loop
660	IF( jfldproc == narea ) CYCLE
661
662	sbergs(1) = nbergs_to_send
663	CALL mppsend( 21, sbergs(1), 1, jfldproc-1, ml_req1)
664	CALL mpprecv( 21, nbergs(2), 1 )
665	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
666	nbergs_to_rcv = INT( nbergs(2) )
667
668	! send bergs
669
670	IF( nbergs_to_send > 0 ) &
671	CALL mppsend( 12, obuffer_f%data, nbergs_to_send*buffer_width, jfldproc-1, ml_req2 )
672	IF( nbergs_to_rcv > 0 ) THEN
673	CALL increase_ibuffer(ibuffer_f, nbergs_to_rcv)
674	CALL mpprecv( 12, ibuffer_f%data, nbergs_to_rcv*buffer_width )
675	ENDIF
676	IF( nbergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
677	DO jk = 1, nbergs_to_rcv
678	IF( nn_verbose_level >= 4 ) THEN
679	WRITE(numicb,*) 'bergstep ',ktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold'
680	CALL flush( numicb )
681	ENDIF
682	CALL unpack_berg_from_buffer(first_berg, ibuffer_f, jk )
683	ENDDO
684
685	ENDDO
686
687	END SUBROUTINE mpp_nfld_bergs
688
689	!!-------------------------------------------------------------------------
690
691	SUBROUTINE dealloc_buffers()
692
693	CALL dealloc_buffer( obuffer_n )
694	CALL dealloc_buffer( obuffer_s )
695	CALL dealloc_buffer( obuffer_e )
696	CALL dealloc_buffer( obuffer_w )
697	CALL dealloc_buffer( ibuffer_n )
698	CALL dealloc_buffer( ibuffer_s )
699	CALL dealloc_buffer( ibuffer_e )
700	CALL dealloc_buffer( ibuffer_w )
701
702	END SUBROUTINE dealloc_buffers
703
704	!!-------------------------------------------------------------------------
705
706	SUBROUTINE dealloc_buffer(buff)
707	! Arguments
708	TYPE(buffer), POINTER :: buff
709
710	IF( ASSOCIATED(buff) ) THEN
711	IF( ASSOCIATED(buff%data)) DEALLOCATE(buff%data)
712	DEALLOCATE(buff)
713	ENDIF
714	END SUBROUTINE dealloc_buffer
715
716	!!-------------------------------------------------------------------------
717
718	SUBROUTINE pack_berg_into_buffer(berg, buff, n)
719	! Arguments
720	TYPE(iceberg), POINTER :: berg
721	TYPE(buffer) , POINTER :: buff
722	INTEGER , INTENT(in) :: n
723	! Local
724	INTEGER :: k
725
726	IF( .NOT. ASSOCIATED(buff) ) CALL increase_buffer( buff, delta_buf )
727	IF( n .GT. buff%size ) CALL increase_buffer( buff, delta_buf )
728
729	!! pack points into buffer
730
731	buff%data( 1,n) = berg%current_point%lon
732	buff%data( 2,n) = berg%current_point%lat
733	buff%data( 3,n) = berg%current_point%uvel
734	buff%data( 4,n) = berg%current_point%vvel
735	buff%data( 5,n) = berg%current_point%xi
736	buff%data( 6,n) = berg%current_point%yj
737	buff%data( 7,n) = float(berg%current_point%year)
738	buff%data( 8,n) = berg%current_point%day
739	buff%data( 9,n) = berg%current_point%mass
740	buff%data(10,n) = berg%current_point%thickness
741	buff%data(11,n) = berg%current_point%width
742	buff%data(12,n) = berg%current_point%length
743	buff%data(13,n) = berg%current_point%mass_of_bits
744	buff%data(14,n) = berg%current_point%heat_density
745
746	buff%data(15,n) = berg%mass_scaling
747	DO k=1,nkounts
748	buff%data(15+k,n) = REAL( berg%number(k), wp )
749	END DO
750
751	END SUBROUTINE pack_berg_into_buffer
752
753	!!-------------------------------------------------------------------------
754
755	SUBROUTINE unpack_berg_from_buffer(first, buff, n)
756	! Arguments
757	TYPE(iceberg), POINTER :: first
758	TYPE(buffer) , POINTER :: buff
759	INTEGER , INTENT(in) :: n
760	! Local variables
761	LOGICAL :: lres
762	TYPE(iceberg) :: currentberg
763	TYPE(point) :: pt
764	INTEGER :: k
765
766	pt%lon = buff%data( 1,n)
767	pt%lat = buff%data( 2,n)
768	pt%uvel = buff%data( 3,n)
769	pt%vvel = buff%data( 4,n)
770	pt%xi = buff%data( 5,n)
771	pt%yj = buff%data( 6,n)
772	pt%year = INT( buff%data( 7,n) )
773	pt%day = buff%data( 8,n)
774	pt%mass = buff%data( 9,n)
775	pt%thickness = buff%data(10,n)
776	pt%width = buff%data(11,n)
777	pt%length = buff%data(12,n)
778	pt%mass_of_bits = buff%data(13,n)
779	pt%heat_density = buff%data(14,n)
780
781	currentberg%mass_scaling = buff%data(15,n)
782	DO k=1,nkounts
783	currentberg%number(k) = INT( buff%data(15+k,n) )
784	END DO
785
786	CALL add_new_berg_to_list(currentberg, pt )
787
788	END SUBROUTINE unpack_berg_from_buffer
789
790	!!-------------------------------------------------------------------------
791
792	SUBROUTINE increase_buffer(old,delta)
793	! Arguments
794	TYPE(buffer), POINTER :: old
795	INTEGER , INTENT(in) :: delta
796	! Local variables
797	TYPE(buffer), POINTER :: new
798	INTEGER :: new_size
799
800	IF( .NOT. ASSOCIATED(old) ) THEN
801	new_size = delta
802	ELSE
803	new_size = old%size + delta
804	ENDIF
805	ALLOCATE( new )
806	ALLOCATE( new%data( buffer_width, new_size) )
807	new%size = new_size
808	IF( ASSOCIATED(old) ) THEN
809	new%data(:,1:old%size) = old%data(:,1:old%size)
810	DEALLOCATE(old%data)
811	DEALLOCATE(old)
812	ENDIF
813	old => new
814
815	END SUBROUTINE increase_buffer
816
817	!!-------------------------------------------------------------------------
818
819	SUBROUTINE increase_ibuffer(old,delta)
820	! Arguments
821	TYPE(buffer), POINTER :: old
822	INTEGER , INTENT(in) :: delta
823	! Local variables
824	TYPE(buffer), POINTER :: new
825	INTEGER :: new_size, old_size
826
827	IF( .NOT. ASSOCIATED(old) ) THEN
828	new_size = delta + delta_buf
829	old_size = 0
830	ELSE
831	old_size = old%size
832	IF( delta .LT. old%size ) THEN
833	new_size = old%size + delta
834	ELSE
835	new_size = delta + delta_buf
836	ENDIF
837	ENDIF
838
839	IF( old_size .NE. new_size ) THEN
840	ALLOCATE( new )
841	ALLOCATE( new%data( buffer_width, new_size) )
842	new%size = new_size
843	IF( ASSOCIATED(old) ) THEN
844	new%data(:,1:old%size) = old%data(:,1:old%size)
845	DEALLOCATE(old%data)
846	DEALLOCATE(old)
847	ENDIF
848	old => new
849	!WRITE( numicb,*) 'increase_ibuffer',narea,' increased to',new_size
850	ENDIF
851
852	END SUBROUTINE increase_ibuffer
853
854	!!-------------------------------------------------------------------------
855
856	#else
857
858	SUBROUTINE mpp_send_bergs()
859	WRITE(numout,*) 'mpp_send_bergs: You should not have seen this message!!'
860	END SUBROUTINE mpp_send_bergs
861
862	SUBROUTINE dealloc_buffers()
863	WRITE(numout,*) 'dealloc_buffers: You should not have seen this message!!'
864	END SUBROUTINE dealloc_buffers
865
866	#endif
867
868	END MODULE icblbc

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

Download in other formats: