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 @ 3360

Last change on this file since 3360 was 3360, checked in by sga, 12 years ago
NEMO branch dev_r3337_NOCS10_ICB: correct names for integer parameters (thanks Andrew!)
File size: 37.3 KB

Line
1	MODULE icblbc
2
3	!!======================================================================
4	!! * MODULE icblbc *
5	!! Ocean physics: routines to handle boundary exchanges for icebergs
6	!!======================================================================
7	!! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code
8	!! - ! 2011-03 (Madec) Part conversion to NEMO form
9	!! - ! Removal of mapping from another grid
10	!! - ! 2011-04 (Alderson) Split into separate modules
11	!! - ! 2011-05 (Alderson) MPP exchanges written based on lib_mpp
12	!! - ! 2011-05 (Alderson) MPP and single processor boundary
13	!! - ! conditions added
14	!!----------------------------------------------------------------------
15	!!----------------------------------------------------------------------
16	!! 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 (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
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, PRIVATE :: jp_delta_buf = 25 ! Size by which to increment buffers
59	INTEGER, PARAMETER, PRIVATE :: jp_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 :: iine
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	iine = INT( pt%xi + 0.5 )
101	IF( iine .GT. nimpp+nicbei-1 ) THEN
102	pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp
103	ELSE IF( iine .LT. nimpp+nicbdi-1 ) THEN
104	pt%xi = ricb_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 :: iine, ijne, ipts
139	INTEGER :: iiglo, ijglo
140
141	this => first_berg
142	DO WHILE( ASSOCIATED(this) )
143	pt => this%current_point
144	ijne = INT( pt%yj + 0.5 )
145	IF( ijne .GT. njmpp+nicbej-1 ) THEN
146	!
147	iine = INT( pt%xi + 0.5 )
148	ipts = nicbfldpts (iine-nimpp+1)
149	!
150	! moving across the cut line means both position and
151	! velocity must change
152	ijglo = INT( ipts/nicbpack )
153	iiglo = ipts - nicbpack*ijglo
154	pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
155	pt%yj = ijglo - ( pt%yj - REAL(ijne,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 :: ibergs_to_send_e, ibergs_to_send_w
184	INTEGER :: ibergs_to_send_n, ibergs_to_send_s
185	INTEGER :: ibergs_rcvd_from_e, ibergs_rcvd_from_w
186	INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s
187	INTEGER :: i, ibergs_start, ibergs_end
188	INTEGER :: iine, ijne
189	INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E
190	REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs
191	INTEGER :: iml_req1, iml_req2, iml_req3, iml_req4
192	INTEGER :: iml_req5, iml_req6, iml_req7, iml_req8, iml_err
193	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat
194
195	! set up indices of neighbouring processors
196	ipe_N = -1
197	ipe_S = -1
198	ipe_W = -1
199	ipe_E = -1
200	IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe
201	IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea
202	IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso
203	IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono
204	!
205	! at northern line of processors with north fold handle bergs differently
206	IF( npolj > 0 ) ipe_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	ipe_E = -1
211	ipe_W = -1
212	ENDIF
213
214	IF( nn_verbose_level >= 2 ) THEN
215	WRITE(numicb,*) 'processor west : ', ipe_W
216	WRITE(numicb,*) 'processor east : ', ipe_E
217	WRITE(numicb,*) 'processor north : ', ipe_N
218	WRITE(numicb,*) 'processor south : ', ipe_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	ibergs_start = count_bergs()
237	ENDIF
238
239	ibergs_to_send_e = 0
240	ibergs_to_send_w = 0
241	ibergs_to_send_n = 0
242	ibergs_to_send_s = 0
243	ibergs_rcvd_from_e = 0
244	ibergs_rcvd_from_w = 0
245	ibergs_rcvd_from_n = 0
246	ibergs_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	iine = INT( pt%xi + 0.5 )
254	IF( ipe_E >= 0 .AND. iine .GT. nimpp+nicbei-1 ) THEN
255	tmpberg => this
256	this => this%next
257	ibergs_to_send_e = ibergs_to_send_e + 1
258	IF( nn_verbose_level >= 4 ) THEN
259	WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east'
260	CALL flush( numicb )
261	ENDIF
262	! deal with periodic case
263	tmpberg%current_point%xi = ricb_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, ibergs_to_send_e)
266	CALL delete_iceberg_from_list(first_berg, tmpberg)
267	ELSE IF( ipe_W >= 0 .AND. iine .LT. nimpp+nicbdi-1 ) THEN
268	tmpberg => this
269	this => this%next
270	ibergs_to_send_w = ibergs_to_send_w + 1
271	IF( nn_verbose_level >= 4 ) THEN
272	WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west'
273	CALL flush( numicb )
274	ENDIF
275	! deal with periodic case
276	tmpberg%current_point%xi = ricb_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, ibergs_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 ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_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	zwebergs(1) = ibergs_to_send_e
298	CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1)
299	CALL mpprecv( 11, zewbergs(2), 1 )
300	IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
301	ibergs_rcvd_from_e = INT( zewbergs(2) )
302	CASE( 0 )
303	zewbergs(1) = ibergs_to_send_w
304	zwebergs(1) = ibergs_to_send_e
305	CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2)
306	CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3)
307	CALL mpprecv( 11, zewbergs(2), 1 )
308	CALL mpprecv( 12, zwebergs(2), 1 )
309	IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
310	IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
311	ibergs_rcvd_from_e = INT( zewbergs(2) )
312	ibergs_rcvd_from_w = INT( zwebergs(2) )
313	CASE( 1 )
314	zewbergs(1) = ibergs_to_send_w
315	CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4)
316	CALL mpprecv( 12, zwebergs(2), 1 )
317	IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
318	ibergs_rcvd_from_w = INT( zwebergs(2) )
319	END SELECT
320	if( nn_verbose_level >= 3) then
321	write(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e
322	call flush(numicb)
323	endif
324
325	SELECT CASE ( nbondi )
326	CASE( -1 )
327	IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 )
328	IF( ibergs_rcvd_from_e > 0 ) THEN
329	CALL increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
330	CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
331	ENDIF
332	IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
333	DO i = 1, ibergs_rcvd_from_e
334	IF( nn_verbose_level >= 4 ) THEN
335	WRITE(numicb,*) 'bergstep ',nktberg,' 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( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 )
342	IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 )
343	IF( ibergs_rcvd_from_e > 0 ) THEN
344	CALL increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
345	CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
346	ENDIF
347	IF( ibergs_rcvd_from_w > 0 ) THEN
348	CALL increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
349	CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
350	ENDIF
351	IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
352	IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
353	DO i = 1, ibergs_rcvd_from_e
354	IF( nn_verbose_level >= 4 ) THEN
355	WRITE(numicb,*) 'bergstep ',nktberg,' 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, ibergs_rcvd_from_w
361	IF( nn_verbose_level >= 4 ) THEN
362	WRITE(numicb,*) 'bergstep ',nktberg,' 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( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 )
369	IF( ibergs_rcvd_from_w > 0 ) THEN
370	CALL increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
371	CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
372	ENDIF
373	IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
374	DO i = 1, ibergs_rcvd_from_w
375	IF( nn_verbose_level >= 4 ) THEN
376	WRITE(numicb,*) 'bergstep ',nktberg,' 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	ijne = INT( pt%yj + 0.5 )
393	IF( ipe_N >= 0 .AND. ijne .GT. njmpp+nicbej-1 ) THEN
394	tmpberg => this
395	this => this%next
396	ibergs_to_send_n = ibergs_to_send_n + 1
397	IF( nn_verbose_level >= 4 ) THEN
398	WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north'
399	CALL flush( numicb )
400	ENDIF
401	CALL pack_berg_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n)
402	CALL delete_iceberg_from_list(first_berg, tmpberg)
403	ELSE IF( ipe_S >= 0 .AND. ijne .LT. njmpp+nicbdj-1 ) THEN
404	tmpberg => this
405	this => this%next
406	ibergs_to_send_s = ibergs_to_send_s + 1
407	IF( nn_verbose_level >= 4 ) THEN
408	WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south'
409	CALL flush( numicb )
410	ENDIF
411	CALL pack_berg_into_buffer( tmpberg, obuffer_s, ibergs_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 ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_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	zsnbergs(1) = ibergs_to_send_n
429	CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1)
430	CALL mpprecv( 15, znsbergs(2), 1 )
431	IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
432	ibergs_rcvd_from_n = INT( znsbergs(2) )
433	CASE( 0 )
434	znsbergs(1) = ibergs_to_send_s
435	zsnbergs(1) = ibergs_to_send_n
436	CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2)
437	CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3)
438	CALL mpprecv( 15, znsbergs(2), 1 )
439	CALL mpprecv( 16, zsnbergs(2), 1 )
440	IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
441	IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
442	ibergs_rcvd_from_n = INT( znsbergs(2) )
443	ibergs_rcvd_from_s = INT( zsnbergs(2) )
444	CASE( 1 )
445	znsbergs(1) = ibergs_to_send_s
446	CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4)
447	CALL mpprecv( 16, zsnbergs(2), 1 )
448	IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
449	ibergs_rcvd_from_s = INT( zsnbergs(2) )
450	END SELECT
451	if( nn_verbose_level >= 3) then
452	write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n
453	call flush(numicb)
454	endif
455
456	SELECT CASE ( nbondj )
457	CASE( -1 )
458	IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 )
459	IF( ibergs_rcvd_from_n > 0 ) THEN
460	CALL increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
461	CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
462	ENDIF
463	IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
464	DO i = 1, ibergs_rcvd_from_n
465	IF( nn_verbose_level >= 4 ) THEN
466	WRITE(numicb,*) 'bergstep ',nktberg,' 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( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 )
473	IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 )
474	IF( ibergs_rcvd_from_n > 0 ) THEN
475	CALL increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
476	CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
477	ENDIF
478	IF( ibergs_rcvd_from_s > 0 ) THEN
479	CALL increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
480	CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
481	ENDIF
482	IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
483	IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
484	DO i = 1, ibergs_rcvd_from_n
485	IF( nn_verbose_level >= 4 ) THEN
486	WRITE(numicb,*) 'bergstep ',nktberg,' 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, ibergs_rcvd_from_s
492	IF( nn_verbose_level >= 4 ) THEN
493	WRITE(numicb,*) 'bergstep ',nktberg,' 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( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 )
500	IF( ibergs_rcvd_from_s > 0 ) THEN
501	CALL increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
502	CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
503	ENDIF
504	IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
505	DO i = 1, ibergs_rcvd_from_s
506	IF( nn_verbose_level >= 4 ) THEN
507	WRITE(numicb,*) 'bergstep ',nktberg,' 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	ibergs_end = count_bergs()
517	i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - &
518	( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w )
519	IF( ibergs_end-(ibergs_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: ibergs_end=', &
522	ibergs_end,' on PE',narea
523	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', &
524	ibergs_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	ibergs_end-(ibergs_start+i),' on PE',narea
529	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', &
530	ibergs_to_send_n,' on PE',narea
531	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', &
532	ibergs_to_send_s,' on PE',narea
533	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', &
534	ibergs_to_send_e,' on PE',narea
535	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', &
536	ibergs_to_send_w,' on PE',narea
537	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', &
538	ibergs_rcvd_from_n,' on PE',narea
539	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', &
540	ibergs_rcvd_from_s,' on PE',narea
541	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', &
542	ibergs_rcvd_from_e,' on PE',narea
543	WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', &
544	ibergs_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	iine = INT( pt%xi + 0.5 )
560	ijne = INT( pt%yj + 0.5 )
561	! CALL check_position(grd, this, 'exchange (bot)')
562	IF( iine .LT. nimpp+nicbdi-1 .OR. &
563	iine .GT. nimpp+nicbei-1 .OR. &
564	ijne .LT. njmpp+nicbdj-1 .OR. &
565	ijne .GT. njmpp+nicbej-1) THEN
566	i = i + 1
567	WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne
568	WRITE(numicb,*) ' ', nimpp, njmpp
569	WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej
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 :: ibergs_to_send
593	INTEGER :: ibergs_to_rcv
594	INTEGER :: iiglo, ijglo, jk, jn
595	INTEGER :: ifldproc, iproc, ipts
596	INTEGER :: iine, ijne
597	REAL(wp), DIMENSION(2) :: zsbergs, znbergs
598	INTEGER :: iml_req1, iml_req2, iml_err
599	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat
600
601	! set up indices of neighbouring processors
602
603	! nicbfldproc 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( nicbfldproc(jn) == -1 ) EXIT
609	ifldproc = nicbfldproc(jn)
610	ibergs_to_send = 0
611
612	! Find number of bergs that need to be exchanged
613	! Pick out exchanges with processor ifldproc
614	! if ifldproc 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	iine = INT( pt%xi + 0.5 )
621	ijne = INT( pt%yj + 0.5 )
622	ipts = nicbfldpts (iine-nimpp+1)
623	iproc = nicbflddest(iine-nimpp+1)
624	IF( ijne .GT. njmpp+nicbej-1 ) THEN
625	IF( iproc == ifldproc ) THEN
626	!
627	! moving across the cut line means both position and
628	! velocity must change
629	ijglo = INT( ipts/nicbpack )
630	iiglo = ipts - nicbpack*ijglo
631	pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
632	pt%yj = ijglo - ( pt%yj - REAL(ijne,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( iproc /= narea ) THEN
638	tmpberg => this
639	ibergs_to_send = ibergs_to_send + 1
640	IF( nn_verbose_level >= 4 ) THEN
641	WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold'
642	CALL flush( numicb )
643	ENDIF
644	CALL pack_berg_into_buffer( tmpberg, obuffer_f, ibergs_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 ',nktberg,' send nfld: ', ibergs_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( ifldproc == narea ) CYCLE
661
662	zsbergs(1) = ibergs_to_send
663	CALL mppsend( 21, zsbergs(1), 1, ifldproc-1, iml_req1)
664	CALL mpprecv( 21, znbergs(2), 1 )
665	IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
666	ibergs_to_rcv = INT( znbergs(2) )
667
668	! send bergs
669
670	IF( ibergs_to_send > 0 ) &
671	CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 )
672	IF( ibergs_to_rcv > 0 ) THEN
673	CALL increase_ibuffer(ibuffer_f, ibergs_to_rcv)
674	CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width )
675	ENDIF
676	IF( ibergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
677	DO jk = 1, ibergs_to_rcv
678	IF( nn_verbose_level >= 4 ) THEN
679	WRITE(numicb,*) 'bergstep ',nktberg,' 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(pbuff)
707	! Arguments
708	TYPE(buffer), POINTER :: pbuff
709
710	IF( ASSOCIATED(pbuff) ) THEN
711	IF( ASSOCIATED(pbuff%data)) DEALLOCATE(pbuff%data)
712	DEALLOCATE(pbuff)
713	ENDIF
714	END SUBROUTINE dealloc_buffer
715
716	!!-------------------------------------------------------------------------
717
718	SUBROUTINE pack_berg_into_buffer(berg, pbuff, kb)
719	! Arguments
720	TYPE(iceberg), POINTER :: berg
721	TYPE(buffer) , POINTER :: pbuff
722	INTEGER , INTENT(in) :: kb
723	! Local
724	INTEGER :: k
725
726	IF( .NOT. ASSOCIATED(pbuff) ) CALL increase_buffer( pbuff, jp_delta_buf )
727	IF( kb .GT. pbuff%size ) CALL increase_buffer( pbuff, jp_delta_buf )
728
729	!! pack points into buffer
730
731	pbuff%data( 1,kb) = berg%current_point%lon
732	pbuff%data( 2,kb) = berg%current_point%lat
733	pbuff%data( 3,kb) = berg%current_point%uvel
734	pbuff%data( 4,kb) = berg%current_point%vvel
735	pbuff%data( 5,kb) = berg%current_point%xi
736	pbuff%data( 6,kb) = berg%current_point%yj
737	pbuff%data( 7,kb) = float(berg%current_point%year)
738	pbuff%data( 8,kb) = berg%current_point%day
739	pbuff%data( 9,kb) = berg%current_point%mass
740	pbuff%data(10,kb) = berg%current_point%thickness
741	pbuff%data(11,kb) = berg%current_point%width
742	pbuff%data(12,kb) = berg%current_point%length
743	pbuff%data(13,kb) = berg%current_point%mass_of_bits
744	pbuff%data(14,kb) = berg%current_point%heat_density
745
746	pbuff%data(15,kb) = berg%mass_scaling
747	DO k=1,nkounts
748	pbuff%data(15+k,kb) = 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, pbuff, kb)
756	! Arguments
757	TYPE(iceberg), POINTER :: first
758	TYPE(buffer) , POINTER :: pbuff
759	INTEGER , INTENT(in) :: kb
760	! Local variables
761	TYPE(iceberg) :: currentberg
762	TYPE(point) :: pt
763	INTEGER :: ik
764
765	pt%lon = pbuff%data( 1,kb)
766	pt%lat = pbuff%data( 2,kb)
767	pt%uvel = pbuff%data( 3,kb)
768	pt%vvel = pbuff%data( 4,kb)
769	pt%xi = pbuff%data( 5,kb)
770	pt%yj = pbuff%data( 6,kb)
771	pt%year = INT( pbuff%data( 7,kb) )
772	pt%day = pbuff%data( 8,kb)
773	pt%mass = pbuff%data( 9,kb)
774	pt%thickness = pbuff%data(10,kb)
775	pt%width = pbuff%data(11,kb)
776	pt%length = pbuff%data(12,kb)
777	pt%mass_of_bits = pbuff%data(13,kb)
778	pt%heat_density = pbuff%data(14,kb)
779
780	currentberg%mass_scaling = pbuff%data(15,kb)
781	DO ik=1,nkounts
782	currentberg%number(ik) = INT( pbuff%data(15+ik,kb) )
783	END DO
784
785	CALL add_new_berg_to_list(currentberg, pt )
786
787	END SUBROUTINE unpack_berg_from_buffer
788
789	!!-------------------------------------------------------------------------
790
791	SUBROUTINE increase_buffer(old,kdelta)
792	! Arguments
793	TYPE(buffer), POINTER :: old
794	INTEGER , INTENT(in) :: kdelta
795	! Local variables
796	TYPE(buffer), POINTER :: new
797	INTEGER :: inew_size
798
799	IF( .NOT. ASSOCIATED(old) ) THEN
800	inew_size = kdelta
801	ELSE
802	inew_size = old%size + kdelta
803	ENDIF
804	ALLOCATE( new )
805	ALLOCATE( new%data( jp_buffer_width, inew_size) )
806	new%size = inew_size
807	IF( ASSOCIATED(old) ) THEN
808	new%data(:,1:old%size) = old%data(:,1:old%size)
809	DEALLOCATE(old%data)
810	DEALLOCATE(old)
811	ENDIF
812	old => new
813
814	END SUBROUTINE increase_buffer
815
816	!!-------------------------------------------------------------------------
817
818	SUBROUTINE increase_ibuffer(old,kdelta)
819	! Arguments
820	TYPE(buffer), POINTER :: old
821	INTEGER , INTENT(in) :: kdelta
822	! Local variables
823	TYPE(buffer), POINTER :: new
824	INTEGER :: inew_size, iold_size
825
826	IF( .NOT. ASSOCIATED(old) ) THEN
827	inew_size = kdelta + jp_delta_buf
828	iold_size = 0
829	ELSE
830	iold_size = old%size
831	IF( kdelta .LT. old%size ) THEN
832	inew_size = old%size + kdelta
833	ELSE
834	inew_size = kdelta + jp_delta_buf
835	ENDIF
836	ENDIF
837
838	IF( iold_size .NE. inew_size ) THEN
839	ALLOCATE( new )
840	ALLOCATE( new%data( jp_buffer_width, inew_size) )
841	new%size = inew_size
842	IF( ASSOCIATED(old) ) THEN
843	new%data(:,1:old%size) = old%data(:,1:old%size)
844	DEALLOCATE(old%data)
845	DEALLOCATE(old)
846	ENDIF
847	old => new
848	!WRITE( numicb,*) 'increase_ibuffer',narea,' increased to',inew_size
849	ENDIF
850
851	END SUBROUTINE increase_ibuffer
852
853	!!-------------------------------------------------------------------------
854
855	#else
856
857	SUBROUTINE mpp_send_bergs()
858	WRITE(numout,*) 'mpp_send_bergs: You should not have seen this message!!'
859	END SUBROUTINE mpp_send_bergs
860
861	SUBROUTINE dealloc_buffers()
862	WRITE(numout,*) 'dealloc_buffers: You should not have seen this message!!'
863	END SUBROUTINE dealloc_buffers
864
865	#endif
866
867	END MODULE icblbc

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

Download in other formats: