Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

icblbc.F90 @ 12555

Last change on this file since 12555 was 12555, checked in by charris, 4 years ago

Changes from GO6 package branch (GMED ticket 450):

svn merge -r 11035:11101 svn+ssh://charris@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/UKMO/dev_r5518_GO6_package

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

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

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

Context Navigation

source: branches/UKMO/dev_r5518_GO6_starthour_obsoper/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90 @ 12555

Download in other formats: