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 NEMO/branches/UKMO/NEMO_4.0_GO8_package_text_diagnostics/src/OCE/ICB – NEMO

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0_GO8_package_text_diagnostics/src/OCE/ICB/icblbc.F90 @ 10948

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

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

Download in other formats: