Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mpp_update_domains2D.h @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago
Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).
File size: 55.8 KB

Line
1	subroutine MPP_UPDATE_DOMAINS_2D_( field, domain, flags )
2	!updates data domain of 2D field whose computational domains have been computed
3	MPP_TYPE_, intent(inout) :: field(:,:)
4	type(domain2D), intent(in) :: domain
5	integer, intent(in), optional :: flags
6	MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
7	#ifdef use_CRI_pointers
8	pointer( ptr, field3D )
9	ptr = LOC(field)
10	call mpp_update_domains( field3D, domain, flags )
11	#else
12	field3D = RESHAPE( field, SHAPE(field3D) )
13	call mpp_update_domains( field3D, domain, flags )
14	field = RESHAPE( field3D, SHAPE(field) )
15	#endif
16	return
17	end subroutine MPP_UPDATE_DOMAINS_2D_
18
19	subroutine MPP_UPDATE_DOMAINS_4D_( field, domain, flags )
20	!updates data domain of 4D field whose computational domains have been computed
21	MPP_TYPE_, intent(inout) :: field(:,:,:,:)
22	type(domain2D), intent(in) :: domain
23	integer, intent(in), optional :: flags
24	MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
25	#ifdef use_CRI_pointers
26	pointer( ptr, field3D )
27	ptr = LOC(field)
28	call mpp_update_domains( field3D, domain, flags )
29	#else
30	field3D = RESHAPE( field, SHAPE(field3D) )
31	call mpp_update_domains( field3D, domain, flags )
32	field = RESHAPE( field3D, SHAPE(field) )
33	#endif
34	return
35	end subroutine MPP_UPDATE_DOMAINS_4D_
36
37	subroutine MPP_UPDATE_DOMAINS_5D_( field, domain, flags )
38	!updates data domain of 5D field whose computational domains have been computed
39	MPP_TYPE_, intent(inout) :: field(:,:,:,:,:)
40	type(domain2D), intent(in) :: domain
41	integer, intent(in), optional :: flags
42	MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)size(field,4)size(field,5))
43	#ifdef use_CRI_pointers
44	pointer( ptr, field3D )
45	ptr = LOC(field)
46	call mpp_update_domains( field3D, domain, flags )
47	#else
48	field3D = RESHAPE( field, SHAPE(field3D) )
49	call mpp_update_domains( field3D, domain, flags )
50	field = RESHAPE( field3D, SHAPE(field) )
51	#endif
52	return
53	end subroutine MPP_UPDATE_DOMAINS_5D_
54
55	subroutine MPP_UPDATE_DOMAINS_3D_( field, domain, flags )
56	!updates data domain of 3D field whose computational domains have been computed
57	type(domain2D), intent(in) :: domain
58	MPP_TYPE_, intent(inout) :: field(domain%x%data%begin:,domain%y%data%begin:,:)
59	integer, intent(in), optional :: flags
60	integer :: update_flags
61	!equate to mpp_domains_stack
62	integer :: wordlen !#words of MPP_TYPE_ fit in 1 word of mpp_domains_stack
63	MPP_TYPE_ :: buffer(size(mpp_domains_stack))
64	#ifdef use_CRI_pointers
65	pointer( ptr, buffer )
66	#endif
67	integer :: buffer_pos
68	integer :: i, j, k, m, n
69	integer :: is, ie, js, je, ke
70	!receive domains saved here for unpacking
71	!for non-blocking version, could be recomputed
72	integer, dimension(8) :: isr, ier, jsr, jer
73	integer :: to_pe, from_pe, list, pos, msgsize
74	logical :: recv_e, recv_se, recv_s, recv_sw, recv_w, recv_nw, recv_n, recv_ne
75	logical :: send_e, send_se, send_s, send_sw, send_w, send_nw, send_n, send_ne
76	logical :: folded
77	character(len=8) :: text
78
79	update_flags = XUPDATE+YUPDATE !default
80	if( PRESENT(flags) )update_flags = flags
81	recv_w = BTEST(update_flags,WEST)
82	recv_e = BTEST(update_flags,EAST)
83	recv_s = BTEST(update_flags,SOUTH)
84	recv_n = BTEST(update_flags,NORTH)
85	recv_ne = recv_e .AND. recv_n
86	recv_se = recv_e .AND. recv_s
87	recv_sw = recv_w .AND. recv_s
88	recv_nw = recv_w .AND. recv_n
89	send_w = recv_e
90	send_e = recv_w
91	send_s = recv_n
92	send_n = recv_s
93	send_ne = send_e .AND. send_n
94	send_se = send_e .AND. send_s
95	send_sw = send_w .AND. send_s
96	send_nw = send_w .AND. send_n
97	if( recv_w .AND. BTEST(domain%fold,WEST) .AND. BTEST(grid_offset_type,EAST) ) &
98	call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
99	if( recv_s .AND. BTEST(domain%fold,SOUTH) .AND. BTEST(grid_offset_type,NORTH) ) &
100	call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
101	if( recv_e .AND. BTEST(domain%fold,EAST) .AND. BTEST(grid_offset_type,WEST) ) &
102	call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
103	if( recv_n .AND. BTEST(domain%fold,NORTH) .AND. BTEST(grid_offset_type,SOUTH) ) &
104	call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
105
106
107	n = size(domain%list)
108	ke = size(field,3)
109	buffer_pos = 0 !this initialization goes away if update_domains becomes non-blocking
110	#ifdef use_CRI_pointers
111	ptr = LOC(mpp_domains_stack)
112	wordlen = size(transfer(buffer(1),mpp_domains_stack))
113	#endif
114	!send
115	do list = 0,n-1
116	m = mod( domain%pos+list, n )
117	if( .NOT.domain%list(m)%overlap )cycle
118	call mpp_clock_begin(pack_clock)
119	to_pe = domain%list(m)%pe
120	pos = buffer_pos
121	if( send_w .AND. domain%list(m)%send_w%overlap )then
122	is = domain%list(m)%send_w%is; ie = domain%list(m)%send_w%ie
123	js = domain%list(m)%send_w%js; je = domain%list(m)%send_w%je
124	if( grid_offset_type.NE.AGRID )then
125	is = domain%list(m)%send_w_off%is; ie = domain%list(m)%send_w_off%ie
126	js = domain%list(m)%send_w_off%js; je = domain%list(m)%send_w_off%je
127	end if
128	call mpp_clock_begin(pack_loop_clock)
129	do k = 1,ke
130	do j = js,je
131	do i = is,ie
132	pos = pos + 1
133	buffer(pos) = field(i,j,k)
134	end do
135	end do
136	end do
137	call mpp_clock_end(pack_loop_clock)
138	end if
139	if( send_nw .AND. domain%list(m)%send_nw%overlap )then
140	is = domain%list(m)%send_nw%is; ie = domain%list(m)%send_nw%ie
141	js = domain%list(m)%send_nw%js; je = domain%list(m)%send_nw%je
142	if( grid_offset_type.NE.AGRID )then
143	is = domain%list(m)%send_nw_off%is; ie = domain%list(m)%send_nw_off%ie
144	js = domain%list(m)%send_nw_off%js; je = domain%list(m)%send_nw_off%je
145	end if
146	call mpp_clock_begin(pack_loop_clock)
147	do k = 1,ke
148	do j = js,je
149	do i = is,ie
150	pos = pos + 1
151	buffer(pos) = field(i,j,k)
152	end do
153	end do
154	end do
155	call mpp_clock_end(pack_loop_clock)
156	end if
157	if( send_n .AND. domain%list(m)%send_n%overlap )then
158	is = domain%list(m)%send_n%is; ie = domain%list(m)%send_n%ie
159	js = domain%list(m)%send_n%js; je = domain%list(m)%send_n%je
160	if( grid_offset_type.NE.AGRID )then
161	is = domain%list(m)%send_n_off%is; ie = domain%list(m)%send_n_off%ie
162	js = domain%list(m)%send_n_off%js; je = domain%list(m)%send_n_off%je
163	end if
164	call mpp_clock_begin(pack_loop_clock)
165	do k = 1,ke
166	do j = js,je
167	do i = is,ie
168	pos = pos + 1
169	buffer(pos) = field(i,j,k)
170	end do
171	end do
172	end do
173	call mpp_clock_end(pack_loop_clock)
174	end if
175	if( send_ne .AND. domain%list(m)%send_ne%overlap )then
176	is = domain%list(m)%send_ne%is; ie = domain%list(m)%send_ne%ie
177	js = domain%list(m)%send_ne%js; je = domain%list(m)%send_ne%je
178	if( grid_offset_type.NE.AGRID )then
179	is = domain%list(m)%send_ne_off%is; ie = domain%list(m)%send_ne_off%ie
180	js = domain%list(m)%send_ne_off%js; je = domain%list(m)%send_ne_off%je
181	end if
182	call mpp_clock_begin(pack_loop_clock)
183	do k = 1,ke
184	do j = js,je
185	do i = is,ie
186	pos = pos + 1
187	buffer(pos) = field(i,j,k)
188	end do
189	end do
190	end do
191	call mpp_clock_end(pack_loop_clock)
192	end if
193	if( send_e .AND. domain%list(m)%send_e%overlap )then
194	is = domain%list(m)%send_e%is; ie = domain%list(m)%send_e%ie
195	js = domain%list(m)%send_e%js; je = domain%list(m)%send_e%je
196	if( grid_offset_type.NE.AGRID )then
197	is = domain%list(m)%send_e_off%is; ie = domain%list(m)%send_e_off%ie
198	js = domain%list(m)%send_e_off%js; je = domain%list(m)%send_e_off%je
199	end if
200	call mpp_clock_begin(pack_loop_clock)
201	do k = 1,ke
202	do j = js,je
203	do i = is,ie
204	pos = pos + 1
205	buffer(pos) = field(i,j,k)
206	end do
207	end do
208	end do
209	call mpp_clock_end(pack_loop_clock)
210	end if
211	if( send_se .AND. domain%list(m)%send_se%overlap )then
212	is = domain%list(m)%send_se%is; ie = domain%list(m)%send_se%ie
213	js = domain%list(m)%send_se%js; je = domain%list(m)%send_se%je
214	if( grid_offset_type.NE.AGRID )then
215	is = domain%list(m)%send_se_off%is; ie = domain%list(m)%send_se_off%ie
216	js = domain%list(m)%send_se_off%js; je = domain%list(m)%send_se_off%je
217	end if
218	call mpp_clock_begin(pack_loop_clock)
219	do k = 1,ke
220	do j = js,je
221	do i = is,ie
222	pos = pos + 1
223	buffer(pos) = field(i,j,k)
224	end do
225	end do
226	end do
227	call mpp_clock_end(pack_loop_clock)
228	end if
229	if( send_s .AND. domain%list(m)%send_s%overlap )then
230	is = domain%list(m)%send_s%is; ie = domain%list(m)%send_s%ie
231	js = domain%list(m)%send_s%js; je = domain%list(m)%send_s%je
232	if( grid_offset_type.NE.AGRID )then
233	is = domain%list(m)%send_s_off%is; ie = domain%list(m)%send_s_off%ie
234	js = domain%list(m)%send_s_off%js; je = domain%list(m)%send_s_off%je
235	end if
236	call mpp_clock_begin(pack_loop_clock)
237	do k = 1,ke
238	do j = js,je
239	do i = is,ie
240	pos = pos + 1
241	buffer(pos) = field(i,j,k)
242	end do
243	end do
244	end do
245	call mpp_clock_end(pack_loop_clock)
246	end if
247	if( send_sw .AND. domain%list(m)%send_sw%overlap )then
248	is = domain%list(m)%send_sw%is; ie = domain%list(m)%send_sw%ie
249	js = domain%list(m)%send_sw%js; je = domain%list(m)%send_sw%je
250	if( grid_offset_type.NE.AGRID )then
251	is = domain%list(m)%send_sw_off%is; ie = domain%list(m)%send_sw_off%ie
252	js = domain%list(m)%send_sw_off%js; je = domain%list(m)%send_sw_off%je
253	end if
254	call mpp_clock_begin(pack_loop_clock)
255	do k = 1,ke
256	do j = js,je
257	do i = is,ie
258	pos = pos + 1
259	buffer(pos) = field(i,j,k)
260	end do
261	end do
262	end do
263	call mpp_clock_end(pack_loop_clock)
264	end if
265	call mpp_clock_end(pack_clock)
266	call mpp_clock_begin(send_clock)
267	msgsize = pos - buffer_pos
268	print *,'msgsize ',msgsize
269	if( msgsize.GT.0 )then
270	print *,'mpp_domains_stack_hwm ',mpp_domains_stack_hwm
271	print ,'poswordlen ',pos*wordlen
272	print ,'max ',max( mpp_domains_stack_hwm, poswordlen )
273	print *,'mpp_domains_stack_size ',mpp_domains_stack_size
274	mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos*wordlen )
275	if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
276	write( text,'(i8)' )mpp_domains_stack_hwm
277	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: mpp_domains1_stack overflow, call mpp_domains_set_stack_size(' &
278	//trim(text)//') from all PEs.' )
279	end if
280	call mpp_send( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, to_pe )
281	buffer_pos = pos
282	end if
283	call mpp_clock_end(send_clock)
284	end do
285
286	!recv
287	do list = 0,n-1
288	m = mod( domain%pos+n-list, n )
289	if( .NOT.domain%list(m)%overlap )cycle
290	call mpp_clock_begin(recv_clock)
291	from_pe = domain%list(m)%pe
292	msgsize = 0
293	if( recv_e .AND. domain%list(m)%recv_e%overlap )then
294	is = domain%list(m)%recv_e%is; ie = domain%list(m)%recv_e%ie
295	js = domain%list(m)%recv_e%js; je = domain%list(m)%recv_e%je
296	if( grid_offset_type.NE.AGRID )then
297	is = domain%list(m)%recv_e_off%is; ie = domain%list(m)%recv_e_off%ie
298	js = domain%list(m)%recv_e_off%js; je = domain%list(m)%recv_e_off%je
299	end if
300	msgsize = msgsize + (ie-is+1)(je-js+1)ke
301	end if
302	if( recv_se .AND. domain%list(m)%recv_se%overlap )then
303	is = domain%list(m)%recv_se%is; ie = domain%list(m)%recv_se%ie
304	js = domain%list(m)%recv_se%js; je = domain%list(m)%recv_se%je
305	if( grid_offset_type.NE.AGRID )then
306	is = domain%list(m)%recv_se_off%is; ie = domain%list(m)%recv_se_off%ie
307	js = domain%list(m)%recv_se_off%js; je = domain%list(m)%recv_se_off%je
308	end if
309	msgsize = msgsize + (ie-is+1)(je-js+1)ke
310	end if
311	if( recv_s .AND. domain%list(m)%recv_s%overlap )then
312	is = domain%list(m)%recv_s%is; ie = domain%list(m)%recv_s%ie
313	js = domain%list(m)%recv_s%js; je = domain%list(m)%recv_s%je
314	if( grid_offset_type.NE.AGRID )then
315	is = domain%list(m)%recv_s_off%is; ie = domain%list(m)%recv_s_off%ie
316	js = domain%list(m)%recv_s_off%js; je = domain%list(m)%recv_s_off%je
317	end if
318	msgsize = msgsize + (ie-is+1)(je-js+1)ke
319	end if
320	if( recv_sw .AND. domain%list(m)%recv_sw%overlap )then
321	is = domain%list(m)%recv_sw%is; ie = domain%list(m)%recv_sw%ie
322	js = domain%list(m)%recv_sw%js; je = domain%list(m)%recv_sw%je
323	if( grid_offset_type.NE.AGRID )then
324	is = domain%list(m)%recv_sw_off%is; ie = domain%list(m)%recv_sw_off%ie
325	js = domain%list(m)%recv_sw_off%js; je = domain%list(m)%recv_sw_off%je
326	end if
327	msgsize = msgsize + (ie-is+1)(je-js+1)ke
328	end if
329	if( recv_w .AND. domain%list(m)%recv_w%overlap )then
330	is = domain%list(m)%recv_w%is; ie = domain%list(m)%recv_w%ie
331	js = domain%list(m)%recv_w%js; je = domain%list(m)%recv_w%je
332	if( grid_offset_type.NE.AGRID )then
333	is = domain%list(m)%recv_w_off%is; ie = domain%list(m)%recv_w_off%ie
334	js = domain%list(m)%recv_w_off%js; je = domain%list(m)%recv_w_off%je
335	end if
336	msgsize = msgsize + (ie-is+1)(je-js+1)ke
337	end if
338	if( recv_nw .AND. domain%list(m)%recv_nw%overlap )then
339	is = domain%list(m)%recv_nw%is; ie = domain%list(m)%recv_nw%ie
340	js = domain%list(m)%recv_nw%js; je = domain%list(m)%recv_nw%je
341	if( grid_offset_type.NE.AGRID )then
342	is = domain%list(m)%recv_nw_off%is; ie = domain%list(m)%recv_nw_off%ie
343	js = domain%list(m)%recv_nw_off%js; je = domain%list(m)%recv_nw_off%je
344	end if
345	msgsize = msgsize + (ie-is+1)(je-js+1)ke
346	end if
347	if( recv_n .AND. domain%list(m)%recv_n%overlap )then
348	is = domain%list(m)%recv_n%is; ie = domain%list(m)%recv_n%ie
349	js = domain%list(m)%recv_n%js; je = domain%list(m)%recv_n%je
350	if( grid_offset_type.NE.AGRID )then
351	is = domain%list(m)%recv_n_off%is; ie = domain%list(m)%recv_n_off%ie
352	js = domain%list(m)%recv_n_off%js; je = domain%list(m)%recv_n_off%je
353	end if
354	msgsize = msgsize + (ie-is+1)(je-js+1)ke
355	end if
356	if( recv_ne .AND. domain%list(m)%recv_ne%overlap )then
357	is = domain%list(m)%recv_ne%is; ie = domain%list(m)%recv_ne%ie
358	js = domain%list(m)%recv_ne%js; je = domain%list(m)%recv_ne%je
359	if( grid_offset_type.NE.AGRID )then
360	is = domain%list(m)%recv_ne_off%is; ie = domain%list(m)%recv_ne_off%ie
361	js = domain%list(m)%recv_ne_off%js; je = domain%list(m)%recv_ne_off%je
362	end if
363	msgsize = msgsize + (ie-is+1)(je-js+1)ke
364	end if
365	if( msgsize.GT.0 )then
366	print *,'mpp_domains_stack_hwm ',mpp_domains_stack_hwm
367	print ,'buffer_pos+msgsize)wordlen ',(buffer_pos+msgsize)*wordlen
368	print ,'max ',max( mpp_domains_stack_hwm, poswordlen )
369	print *,'mpp_domains_stack_size ',mpp_domains_stack_size
370	mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
371	if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
372	write( text,'(i8)' )mpp_domains_stack_hwm
373	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: mpp_domains2_stack overflow, call mpp_domains_set_stack_size(' &
374	//trim(text)//') from all PEs.' )
375	end if
376	call mpp_recv( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, from_pe )
377	buffer_pos = buffer_pos + msgsize
378	end if
379	call mpp_clock_end(recv_clock)
380	end do
381
382	!unpack recv
383	!unpack halos in reverse order
384	do list = n-1,0,-1
385	m = mod( domain%pos+n-list, n )
386	if( .NOT.domain%list(m)%overlap )cycle
387	call mpp_clock_begin(unpk_clock)
388	from_pe = domain%list(m)%pe
389	pos = buffer_pos
390	if( recv_ne .AND. domain%list(m)%recv_ne%overlap )then
391	is = domain%list(m)%recv_ne%is; ie = domain%list(m)%recv_ne%ie
392	js = domain%list(m)%recv_ne%js; je = domain%list(m)%recv_ne%je
393	if( grid_offset_type.NE.AGRID )then
394	is = domain%list(m)%recv_ne_off%is; ie = domain%list(m)%recv_ne_off%ie
395	js = domain%list(m)%recv_ne_off%js; je = domain%list(m)%recv_ne_off%je
396	end if
397	msgsize = (ie-is+1)(je-js+1)ke
398	pos = buffer_pos - msgsize
399	buffer_pos = pos
400	if( domain%list(m)%recv_ne%folded )then
401	do k = 1,ke
402	do j = je,js,-1
403	do i = ie,is,-1
404	pos = pos + 1
405	field(i,j,k) = buffer(pos)
406	end do
407	end do
408	end do
409	else
410	do k = 1,ke
411	do j = js,je
412	do i = is,ie
413	pos = pos + 1
414	field(i,j,k) = buffer(pos)
415	end do
416	end do
417	end do
418	end if
419	end if
420	if( recv_n .AND. domain%list(m)%recv_n%overlap )then
421	is = domain%list(m)%recv_n%is; ie = domain%list(m)%recv_n%ie
422	js = domain%list(m)%recv_n%js; je = domain%list(m)%recv_n%je
423	if( grid_offset_type.NE.AGRID )then
424	is = domain%list(m)%recv_n_off%is; ie = domain%list(m)%recv_n_off%ie
425	js = domain%list(m)%recv_n_off%js; je = domain%list(m)%recv_n_off%je
426	end if
427	msgsize = (ie-is+1)(je-js+1)ke
428	pos = buffer_pos - msgsize
429	buffer_pos = pos
430	if( domain%list(m)%recv_n%folded )then
431	do k = 1,ke
432	do j = je,js,-1
433	do i = ie,is,-1
434	pos = pos + 1
435	field(i,j,k) = buffer(pos)
436	end do
437	end do
438	end do
439	else
440	do k = 1,ke
441	do j = js,je
442	do i = is,ie
443	pos = pos + 1
444	field(i,j,k) = buffer(pos)
445	end do
446	end do
447	end do
448	end if
449	end if
450	if( recv_nw .AND. domain%list(m)%recv_nw%overlap )then
451	is = domain%list(m)%recv_nw%is; ie = domain%list(m)%recv_nw%ie
452	js = domain%list(m)%recv_nw%js; je = domain%list(m)%recv_nw%je
453	if( grid_offset_type.NE.AGRID )then
454	is = domain%list(m)%recv_nw_off%is; ie = domain%list(m)%recv_nw_off%ie
455	js = domain%list(m)%recv_nw_off%js; je = domain%list(m)%recv_nw_off%je
456	end if
457	msgsize = (ie-is+1)(je-js+1)ke
458	pos = buffer_pos - msgsize
459	buffer_pos = pos
460	if( domain%list(m)%recv_nw%folded )then
461	do k = 1,ke
462	do j = je,js,-1
463	do i = ie,is,-1
464	pos = pos + 1
465	field(i,j,k) = buffer(pos)
466	end do
467	end do
468	end do
469	else
470	do k = 1,ke
471	do j = js,je
472	do i = is,ie
473	pos = pos + 1
474	field(i,j,k) = buffer(pos)
475	end do
476	end do
477	end do
478	end if
479	end if
480	if( recv_w .AND. domain%list(m)%recv_w%overlap )then
481	is = domain%list(m)%recv_w%is; ie = domain%list(m)%recv_w%ie
482	js = domain%list(m)%recv_w%js; je = domain%list(m)%recv_w%je
483	if( grid_offset_type.NE.AGRID )then
484	is = domain%list(m)%recv_w_off%is; ie = domain%list(m)%recv_w_off%ie
485	js = domain%list(m)%recv_w_off%js; je = domain%list(m)%recv_w_off%je
486	end if
487	msgsize = (ie-is+1)(je-js+1)ke
488	pos = buffer_pos - msgsize
489	buffer_pos = pos
490	if( domain%list(m)%recv_w%folded )then
491	do k = 1,ke
492	do j = je,js,-1
493	do i = ie,is,-1
494	pos = pos + 1
495	field(i,j,k) = buffer(pos)
496	end do
497	end do
498	end do
499	else
500	do k = 1,ke
501	do j = js,je
502	do i = is,ie
503	pos = pos + 1
504	field(i,j,k) = buffer(pos)
505	end do
506	end do
507	end do
508	end if
509	end if
510	if( recv_sw .AND. domain%list(m)%recv_sw%overlap )then
511	is = domain%list(m)%recv_sw%is; ie = domain%list(m)%recv_sw%ie
512	js = domain%list(m)%recv_sw%js; je = domain%list(m)%recv_sw%je
513	if( grid_offset_type.NE.AGRID )then
514	is = domain%list(m)%recv_sw_off%is; ie = domain%list(m)%recv_sw_off%ie
515	js = domain%list(m)%recv_sw_off%js; je = domain%list(m)%recv_sw_off%je
516	end if
517	msgsize = (ie-is+1)(je-js+1)ke
518	pos = buffer_pos - msgsize
519	buffer_pos = pos
520	if( domain%list(m)%recv_sw%folded )then
521	do k = 1,ke
522	do j = je,js,-1
523	do i = ie,is,-1
524	pos = pos + 1
525	field(i,j,k) = buffer(pos)
526	end do
527	end do
528	end do
529	else
530	do k = 1,ke
531	do j = js,je
532	do i = is,ie
533	pos = pos + 1
534	field(i,j,k) = buffer(pos)
535	end do
536	end do
537	end do
538	end if
539	end if
540	if( recv_s .AND. domain%list(m)%recv_s%overlap )then
541	is = domain%list(m)%recv_s%is; ie = domain%list(m)%recv_s%ie
542	js = domain%list(m)%recv_s%js; je = domain%list(m)%recv_s%je
543	if( grid_offset_type.NE.AGRID )then
544	is = domain%list(m)%recv_s_off%is; ie = domain%list(m)%recv_s_off%ie
545	js = domain%list(m)%recv_s_off%js; je = domain%list(m)%recv_s_off%je
546	end if
547	msgsize = (ie-is+1)(je-js+1)ke
548	pos = buffer_pos - msgsize
549	buffer_pos = pos
550	if( domain%list(m)%recv_s%folded )then
551	do k = 1,ke
552	do j = je,js,-1
553	do i = ie,is,-1
554	pos = pos + 1
555	field(i,j,k) = buffer(pos)
556	end do
557	end do
558	end do
559	else
560	do k = 1,ke
561	do j = js,je
562	do i = is,ie
563	pos = pos + 1
564	field(i,j,k) = buffer(pos)
565	end do
566	end do
567	end do
568	end if
569	end if
570	if( recv_se .AND. domain%list(m)%recv_se%overlap )then
571	is = domain%list(m)%recv_se%is; ie = domain%list(m)%recv_se%ie
572	js = domain%list(m)%recv_se%js; je = domain%list(m)%recv_se%je
573	if( grid_offset_type.NE.AGRID )then
574	is = domain%list(m)%recv_se_off%is; ie = domain%list(m)%recv_se_off%ie
575	js = domain%list(m)%recv_se_off%js; je = domain%list(m)%recv_se_off%je
576	end if
577	msgsize = (ie-is+1)(je-js+1)ke
578	pos = buffer_pos - msgsize
579	buffer_pos = pos
580	if( domain%list(m)%recv_se%folded )then
581	do k = 1,ke
582	do j = je,js,-1
583	do i = ie,is,-1
584	pos = pos + 1
585	field(i,j,k) = buffer(pos)
586	end do
587	end do
588	end do
589	else
590	do k = 1,ke
591	do j = js,je
592	do i = is,ie
593	pos = pos + 1
594	field(i,j,k) = buffer(pos)
595	end do
596	end do
597	end do
598	end if
599	end if
600	if( recv_e .AND. domain%list(m)%recv_e%overlap )then
601	is = domain%list(m)%recv_e%is; ie = domain%list(m)%recv_e%ie
602	js = domain%list(m)%recv_e%js; je = domain%list(m)%recv_e%je
603	if( grid_offset_type.NE.AGRID )then
604	is = domain%list(m)%recv_e_off%is; ie = domain%list(m)%recv_e_off%ie
605	js = domain%list(m)%recv_e_off%js; je = domain%list(m)%recv_e_off%je
606	end if
607	msgsize = (ie-is+1)(je-js+1)ke
608	pos = buffer_pos - msgsize
609	buffer_pos = pos
610	if( domain%list(m)%recv_e%folded )then
611	do k = 1,ke
612	do j = je,js,-1
613	do i = ie,is,-1
614	pos = pos + 1
615	field(i,j,k) = buffer(pos)
616	end do
617	end do
618	end do
619	else
620	do k = 1,ke
621	do j = js,je
622	do i = is,ie
623	pos = pos + 1
624	field(i,j,k) = buffer(pos)
625	end do
626	end do
627	end do
628	end if
629	end if
630	call mpp_clock_end(unpk_clock)
631	end do
632
633	call mpp_clock_begin(wait_clock)
634	call mpp_sync_self( domain%list(:)%pe )
635	call mpp_clock_end(wait_clock)
636	return
637	end subroutine MPP_UPDATE_DOMAINS_3D_
638
639	subroutine MPP_REDISTRIBUTE_2D_( domain_in, field_in, domain_out, field_out )
640	type(domain2D), intent(in) :: domain_in, domain_out
641	MPP_TYPE_, intent(in) :: field_in (:,:)
642	MPP_TYPE_, intent(out) :: field_out(:,:)
643	MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),1)
644	MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),1)
645	#ifdef use_CRI_pointers
646	pointer( ptr_in, field3D_in )
647	pointer( ptr_out, field3D_out )
648	ptr_in = LOC(field_in )
649	ptr_out = LOC(field_out)
650	call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
651	#else
652	field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
653	call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
654	field_out = RESHAPE( field3D_out, SHAPE(field_out) )
655	#endif
656	return
657	end subroutine MPP_REDISTRIBUTE_2D_
658
659	subroutine MPP_REDISTRIBUTE_3D_( domain_in, field_in, domain_out, field_out )
660	type(domain2D), intent(in) :: domain_in, domain_out
661	! MPP_TYPE_, intent(in) :: field_in ( domain_in%x%data%begin:, domain_in%y%data%begin:,:)
662	! MPP_TYPE_, intent(out) :: field_out(domain_out%x%data%begin:,domain_out%y%data%begin:,:)
663	MPP_TYPE_, intent(in) :: field_in (:,:,:)
664	MPP_TYPE_, intent(out) :: field_out(:,:,:)
665	integer :: is, ie, js, je, ke, isc, iec, jsc, jec
666	integer :: i, j, k
667	integer :: list, m, n, pos, msgsize
668	integer :: to_pe, from_pe
669	! MPP_TYPE_, dimension(domain_in%x%compute%sizedomain_in%y%compute%sizesize(field_in,3)) :: send_buf, recv_buf
670	MPP_TYPE_ :: buffer(size(mpp_domains_stack))
671	#ifdef use_CRI_pointers
672	pointer( ptr, buffer )
673	#endif
674	integer :: buffer_pos, wordlen
675	character(len=8) :: text
676
677	! ke = size(field_in,3)
678	! if( ke.NE.size(field_out,3) )call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mismatch between field_in and field_out.' )
679	! if( UBOUND(field_in,1).NE.domain_in%x%data%end .OR. &
680	! UBOUND(field_in,2).NE.domain_in%y%data%end ) &
681	! call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_in must be on data domain of domain_in.' )
682	! if( UBOUND(field_out,1).NE.domain_out%x%data%end .OR. &
683	! UBOUND(field_out,2).NE.domain_out%y%data%end ) &
684	! call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_out must be on data domain of domain_out.' )
685
686	!fix ke
687	ke = 0
688	if( domain_in%pe.NE.NULL_PE )ke = size(field_in,3)
689	if( domain_out%pe.NE.NULL_PE )then
690	if( ke.NE.0 .AND. ke.NE.size(field_out,3) ) &
691	call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mismatch between field_in and field_out.' )
692	ke = size(field_out,3)
693	end if
694	if( ke.EQ.0 )call mpp_error( FATAL, 'MPP_REDISTRIBUTE: either domain_in or domain_out must be native.' )
695	!check sizes
696	if( domain_in%pe.NE.NULL_PE )then
697	if( size(field_in,1).NE.domain_in%x%data%size .OR. size(field_in,2).NE.domain_in%y%data%size ) &
698	call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_in must be on data domain of domain_in.' )
699	end if
700	if( domain_out%pe.NE.NULL_PE )then
701	if( size(field_out,1).NE.domain_out%x%data%size .OR. size(field_out,2).NE.domain_out%y%data%size ) &
702	call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_out must be on data domain of domain_out.' )
703	end if
704
705	buffer_pos = 0
706	#ifdef use_CRI_pointers
707	ptr = LOC(mpp_domains_stack)
708	wordlen = size(TRANSFER(buffer(1),mpp_domains_stack))
709	#endif
710	!send
711	call mpp_get_compute_domain( domain_in, isc, iec, jsc, jec )
712	n = size(domain_out%list)
713	do list = 0,n-1
714	m = mod( domain_out%pos+list+n, n )
715	to_pe = domain_out%list(m)%pe
716	call mpp_get_compute_domain( domain_out%list(m), is, ie, js, je )
717	is = max(is,isc); ie = min(ie,iec)
718	js = max(js,jsc); je = min(je,jec)
719	if( ie.GE.is .AND. je.GE.js )then
720	msgsize = (ie-is+1)(je-js+1)ke
721	mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
722	if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
723	write( text,'(i8)' )mpp_domains_stack_hwm
724	call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
725	//trim(text)//') from all PEs.' )
726	end if
727	pos = buffer_pos
728	do k = 1,ke
729	do j = js-domain_in%y%data%begin+1,je-domain_in%y%data%begin+1
730	do i = is-domain_in%x%data%begin+1,ie-domain_in%x%data%begin+1
731	pos = pos+1
732	buffer(pos) = field_in(i,j,k)
733	end do
734	end do
735	end do
736	if( debug )write( stderr(),* )'PE', pe, ' to PE ', to_pe, 'is,ie,js,je=', is, ie, js, je
737	call mpp_send( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, to_pe )
738	buffer_pos = pos
739	end if
740	end do
741	!recv
742	call mpp_get_compute_domain( domain_out, isc, iec, jsc, jec )
743	n = size(domain_in%list)
744	do list = 0,n-1
745	m = mod( domain_in%pos+n-list, n )
746	from_pe = domain_in%list(m)%pe
747	call mpp_get_compute_domain( domain_in%list(m), is, ie, js, je )
748	is = max(is,isc); ie = min(ie,iec)
749	js = max(js,jsc); je = min(je,jec)
750	if( ie.GE.is .AND. je.GE.js )then
751	msgsize = (ie-is+1)(je-js+1)ke
752	mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
753	if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
754	write( text,'(i8)' )mpp_domains_stack_hwm
755	call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
756	//trim(text)//') from all PEs.' )
757	end if
758	if( debug )write( stderr(),* )'PE', pe, ' from PE ', from_pe, 'is,ie,js,je=', is, ie, js, je
759	call mpp_recv( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, from_pe )
760	pos = buffer_pos
761	do k = 1,ke
762	do j = js-domain_out%y%data%begin+1,je-domain_out%y%data%begin+1
763	do i = is-domain_out%x%data%begin+1,ie-domain_out%x%data%begin+1
764	pos = pos+1
765	field_out(i,j,k) = buffer(pos)
766	end do
767	end do
768	end do
769	buffer_pos = pos
770	end if
771	end do
772
773	! call mpp_sync_self( domain_in%list(:)%pe )
774	call mpp_sync_self()
775	return
776	end subroutine MPP_REDISTRIBUTE_3D_
777
778	subroutine MPP_REDISTRIBUTE_4D_( domain_in, field_in, domain_out, field_out )
779	type(domain2D), intent(in) :: domain_in, domain_out
780	MPP_TYPE_, intent(in) :: field_in (:,:,:,:)
781	MPP_TYPE_, intent(out) :: field_out(:,:,:,:)
782	MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),size(field_in ,3)*size(field_in ,4))
783	MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),size(field_out,3)*size(field_out,4))
784	#ifdef use_CRI_pointers
785	pointer( ptr_in, field3D_in )
786	pointer( ptr_out, field3D_out )
787	ptr_in = LOC(field_in )
788	ptr_out = LOC(field_out)
789	call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
790	#else
791	field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
792	call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
793	field_out = RESHAPE( field3D_out, SHAPE(field_out) )
794	#endif
795	return
796	end subroutine MPP_REDISTRIBUTE_4D_
797
798	subroutine MPP_REDISTRIBUTE_5D_( domain_in, field_in, domain_out, field_out )
799	type(domain2D), intent(in) :: domain_in, domain_out
800	MPP_TYPE_, intent(in) :: field_in (:,:,:,:,:)
801	MPP_TYPE_, intent(out) :: field_out(:,:,:,:,:)
802	MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),size(field_in ,3)size(field_in ,4)size(field_in ,5))
803	MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),size(field_out,3)size(field_out,4)size(field_out,5))
804	#ifdef use_CRI_pointers
805	pointer( ptr_in, field3D_in )
806	pointer( ptr_out, field3D_out )
807	ptr_in = LOC(field_in )
808	ptr_out = LOC(field_out)
809	call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
810	#else
811	field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
812	call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
813	field_out = RESHAPE( field3D_out, SHAPE(field_out) )
814	#endif
815	return
816	end subroutine MPP_REDISTRIBUTE_5D_
817	#ifdef VECTOR_FIELD_
818	!VECTOR_FIELD_ is set to false for MPP_TYPE_ integer or logical.
819	!vector fields
820	subroutine MPP_UPDATE_DOMAINS_2D_V_( fieldx, fieldy, domain, flags, gridtype )
821	!updates data domain of 2D field whose computational domains have been computed
822	MPP_TYPE_, intent(inout), dimension(:,:) :: fieldx, fieldy
823	type(domain2D), intent(inout) :: domain
824	integer, intent(in), optional :: flags, gridtype
825	MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1)
826	MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1)
827	#ifdef use_CRI_pointers
828	pointer( ptrx, field3Dx )
829	pointer( ptry, field3Dy )
830	ptrx = LOC(fieldx)
831	ptry = LOC(fieldy)
832	call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
833	#else
834	field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
835	field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
836	call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
837	fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
838	fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
839	#endif
840	return
841	end subroutine MPP_UPDATE_DOMAINS_2D_V_
842
843	subroutine MPP_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype )
844	!updates data domain of 3D field whose computational domains have been computed
845	type(domain2D), intent(inout) :: domain
846	MPP_TYPE_, intent(inout), dimension(domain%x%data%begin:,domain%y%data%begin:,:) :: fieldx, fieldy
847	integer, intent(in), optional :: flags, gridtype
848	integer :: update_flags
849	integer :: i,j,k,n, is, ie, js, je, ke, pos
850	integer :: ioff, joff
851	MPP_TYPE_ :: buffer(size(mpp_domains_stack))
852	#ifdef use_CRI_pointers
853	pointer( ptr, buffer )
854	MPP_TYPE_ :: field(size(fieldx,1),size(fieldx,2),2*size(fieldx,3))
855	pointer( ptrf, field )
856	#endif
857	integer :: buffer_pos, msgsize, wordlen
858	character(len=8) :: text
859
860	!gridtype
861	grid_offset_type = AGRID
862	if( PRESENT(gridtype) )then
863	if( gridtype.NE.AGRID .AND. &
864	gridtype.NE.BGRID_NE .AND. gridtype.NE.BGRID_SW .AND. &
865	gridtype.NE.CGRID_NE .AND. gridtype.NE.CGRID_SW ) &
866	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: gridtype must be one of AGRID\|BGRID_NE\|BGRID_SW\|CGRID_NE\|CGRID_SW.' )
867	!grid_offset_type used by update domains to determine shifts.
868	grid_offset_type = gridtype
869	call compute_overlaps(domain)
870	if( grid_offset_type.NE.domain%gridtype ) &
871	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: gridtype cannot be changed during run.' )
872	end if
873	!need to add code for EWS boundaries
874	if( BTEST(domain%fold,WEST) .AND. BTEST(update_flags,WEST) ) &
875	call mpp_error( FATAL, 'velocity stencil not yet active for WEST fold, contact author.' )
876	if( BTEST(domain%fold,EAST) .AND. BTEST(update_flags,EAST) ) &
877	call mpp_error( FATAL, 'velocity stencil not yet active for EAST fold, contact author.' )
878	if( BTEST(domain%fold,SOUTH) .AND. BTEST(update_flags,SOUTH) ) &
879	call mpp_error( FATAL, 'velocity stencil not yet active for SOUTH fold, contact author.' )
880
881	#ifdef use_CRI_pointers
882	!optimization for BGRID when fieldx and fieldy are contiguous
883	ptrf = LOC(fieldx)
884	if( LOC(field(1,1,size(fieldx,3)+1)).EQ.LOC(fieldy) .AND. &
885	( domain%gridtype.EQ.BGRID_NE .OR. domain%gridtype.EQ.BGRID_SW ) )then
886	call mpp_update_domains( field, domain, flags )
887	else
888	call mpp_update_domains( fieldx, domain, flags )
889	call mpp_update_domains( fieldy, domain, flags )
890	end if
891	#else
892	call mpp_update_domains( fieldx, domain, flags )
893	call mpp_update_domains( fieldy, domain, flags )
894	#endif
895
896	#ifdef use_CRI_pointers
897	ptr = LOC(mpp_domains_stack)
898	#endif
899	wordlen = size(TRANSFER(buffer(1),mpp_domains_stack))
900	buffer_pos = 0
901	!for all gridtypes
902	update_flags = XUPDATE+YUPDATE !default
903	if( PRESENT(flags) )update_flags = flags
904	ke = size(fieldx,3)
905	call mpp_get_global_domain( domain, xsize=ioff, ysize=joff )
906	!northern boundary fold
907	if( BTEST(domain%fold,NORTH) .AND. BTEST(update_flags,NORTH) )then
908	js = domain%y%global%end + 1
909	je = domain%y%data%end
910	if( je.GE.js )then
911	!on offset grids, we need to move data leftward by one point
912	pos = domain%x%pos - 1 !the one on your left
913	if( pos.GE.0 )then
914	is = domain%x%list(pos)%data%end+1; ie=is
915	else if( domain%x%cyclic )then
916	pos = pos + size(domain%x%list)
917	is = domain%x%list(pos)%data%end+1 - ioff; ie=is
918	else
919	is=1; ie=0
920	end if
921	n = buffer_pos
922	if( ie.EQ.is )then
923	msgsize = (je-js+1)ke2 !only half this on CGRID actually
924	mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
925	if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
926	write( text,'(i8)' )mpp_domains_stack_hwm
927	call mpp_error( FATAL, 'MPP_UPDATE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
928	//trim(text)//') from all PEs.' )
929	end if
930	select case(grid_offset_type)
931	case(BGRID_NE)
932	do k = 1,ke
933	do j = js,je
934	n = n + 2
935	buffer(n-1) = fieldx(is,j,k)
936	buffer(n ) = fieldy(is,j,k)
937	end do
938	end do
939	call mpp_send( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
940	buffer_pos = buffer_pos + n
941	case(CGRID_NE)
942	do k = 1,ke
943	do j = js,je
944	n = n + 1
945	buffer(n) = fieldx(is,j,k)
946	end do
947	end do
948	call mpp_send( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
949	buffer_pos = buffer_pos + n
950	end select
951	!receive data at x%data%end
952	pos = domain%x%pos + 1 !the one on your right
953	if( pos.LT.size(domain%x%list) )then
954	n = (je-js+1)*ke
955	else if( domain%x%cyclic )then
956	pos = pos - size(domain%x%list)
957	n = (je-js+1)*ke
958	else
959	n = 0
960	end if
961	if( n.GT.0 )then
962	mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+n)*wordlen )
963	if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
964	write( text,'(i8)' )mpp_domains_stack_hwm
965	call mpp_error( FATAL, 'MPP_UPDATE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
966	//trim(text)//') from all PEs.' )
967	end if
968	select case(grid_offset_type)
969	case(BGRID_NE)
970	do k = 1,ke
971	do j = js,je
972	do i = domain%x%data%begin,domain%x%data%end-1
973	fieldx(i,j,k) = fieldx(i+1,j,k)
974	fieldy(i,j,k) = fieldy(i+1,j,k)
975	end do
976	end do
977	end do
978	n = n*2
979	call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
980	i = domain%x%data%end
981	n = buffer_pos
982	do k = 1,ke
983	do j = js,je
984	n = n + 2
985	fieldx(i,j,k) = buffer(n-1)
986	fieldy(i,j,k) = buffer(n )
987	end do
988	end do
989	case(CGRID_NE)
990	do k = 1,ke
991	do j = js,je
992	do i = domain%x%data%begin,domain%x%data%end-1
993	fieldx(i,j,k) = fieldx(i+1,j,k)
994	fieldy(i,j,k) = fieldy(i+1,j,k)
995	end do
996	end do
997	end do
998	call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
999	i = domain%x%data%end
1000	n = buffer_pos
1001	do k = 1,ke
1002	do j = js,je
1003	n = n + 1
1004	fieldx(i,j,k) = buffer(n)
1005	end do
1006	end do
1007	end select
1008	end if
1009	end if
1010	!flip the sign
1011	is = domain%x%data%begin
1012	ie = domain%x%data%end
1013	do k = 1,ke
1014	do j = js,je
1015	do i = is,ie
1016	fieldx(i,j,k) = -fieldx(i,j,k)
1017	fieldy(i,j,k) = -fieldy(i,j,k)
1018	end do
1019	end do
1020	end do
1021	end if
1022	!eliminate redundant vector data at fold
1023	j = domain%y%global%end
1024	if( domain%y%data%begin.LE.j .AND. j.LE.domain%y%data%end )then !fold is within domain
1025	!ship left-half data to right half: on BGRID_NE the x%data%end point is not in mirror domain and must be done separately.
1026	if( domain%x%pos.LT.(size(domain%x%list)+1)/2 )then
1027	is = domain%x%data%begin
1028	ie = min(domain%x%data%end,(domain%x%global%begin+domain%x%global%end)/2)
1029	n = buffer_pos
1030	select case(grid_offset_type)
1031	case(BGRID_NE)
1032	do k = 1,ke
1033	do i = is,ie-1
1034	n = n + 2
1035	buffer(n-1) = fieldx(i,j,k)
1036	buffer(n) = fieldy(i,j,k)
1037	end do
1038	end do
1039	call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
1040	buffer_pos = n
1041	case(CGRID_NE)
1042	do k = 1,ke
1043	do i = is,ie
1044	n = n + 1
1045	buffer(n) = fieldy(i,j,k)
1046	end do
1047	end do
1048	call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
1049	buffer_pos = n
1050	end select
1051	end if
1052	if( domain%x%pos.GE.size(domain%x%list)/2 )then
1053	is = max(domain%x%data%begin,(domain%x%global%begin+domain%x%global%end)/2+1)
1054	ie = domain%x%data%end
1055	select case(grid_offset_type)
1056	case(BGRID_NE)
1057	n = (ie-is+1)ke2
1058	call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
1059	n = buffer_pos
1060	!get all values except at x%data%end
1061	do k = 1,ke
1062	do i = ie-1,is,-1
1063	n = n + 2
1064	fieldx(i,j,k) = -buffer(n-1)
1065	fieldy(i,j,k) = -buffer(n)
1066	end do
1067	end do
1068	!now get the value at domain%x%data%end
1069	pos = domain%x%pos - 1
1070	if( pos.GE.size(domain%x%list)/2 )then
1071	i = domain%x%list(pos)%data%end
1072	buffer_pos = n
1073	do k = 1,ke
1074	n = n + 2
1075	buffer(n-1) = fieldx(i,j,k)
1076	buffer(n ) = fieldy(i,j,k)
1077	end do
1078	call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(pos)%pe )
1079	buffer_pos = n
1080	end if
1081	pos = domain%x%pos + 1
1082	if( pos.LT.size(domain%x%list) )then
1083	n = ke*2
1084	call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
1085	n = buffer_pos
1086	i = domain%x%data%end
1087	do k = 1,ke
1088	n = n + 2
1089	fieldx(i,j,k) = buffer(n-1)
1090	fieldy(i,j,k) = buffer(n )
1091	end do
1092	end if
1093	case(CGRID_NE)
1094	n = (ie-is+1)*ke
1095	call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
1096	n = buffer_pos
1097	do k = 1,ke
1098	do i = ie,is,-1
1099	n = n + 1
1100	fieldy(i,j,k) = -buffer(n)
1101	end do
1102	end do
1103	end select
1104	end if
1105	!poles set to 0: BGRID only
1106	if( grid_offset_type.EQ.BGRID_NE )then
1107	do i = domain%x%global%begin-1,domain%x%global%end,(domain%x%global%begin+domain%x%global%end)/2
1108	if( domain%x%data%begin.LE.i .AND. i.LE.domain%x%data%end )then
1109	do k = 1,ke
1110	fieldx(i,j,k) = 0.
1111	fieldy(i,j,k) = 0.
1112	end do
1113	end if
1114	end do
1115	end if
1116	!these last three code blocks correct an error where the data in your halo coming from other half may have the wrong sign
1117	!off west edge
1118	select case(grid_offset_type)
1119	case(BGRID_NE)
1120	is = domain%x%global%begin - 1
1121	if( is.GT.domain%x%data%begin )then
1122	if( 2*is-domain%x%data%begin.GT.domain%x%data%end ) &
1123	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE west edge ubound error.' )
1124	do k = 1,ke
1125	do i = domain%x%data%begin,is-1
1126	fieldx(i,j,k) = fieldx(2*is-i,j,k)
1127	fieldy(i,j,k) = fieldy(2*is-i,j,k)
1128	end do
1129	end do
1130	end if
1131	case(CGRID_NE)
1132	is = domain%x%global%begin
1133	if( is.GT.domain%x%data%begin )then
1134	if( 2*is-domain%x%data%begin-1.GT.domain%x%data%end ) &
1135	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE west edge ubound error.' )
1136	do k = 1,ke
1137	do i = domain%x%data%begin,is-1
1138	fieldy(i,j,k) = fieldy(2*is-i-1,j,k)
1139	end do
1140	end do
1141	end if
1142	end select
1143	!right of midpoint
1144	is = (domain%x%global%begin+domain%x%global%end)/2
1145	if( domain%x%compute%begin.LE.is .AND. is.LT.domain%x%data%end )then
1146	select case(grid_offset_type)
1147	case(BGRID_NE)
1148	ie = domain%x%data%end
1149	if( 2*is-ie.LT.domain%x%data%begin )ie = ie - 1
1150	if( 2*is-ie.LT.domain%x%data%begin ) &
1151	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE midpoint lbound error.' )
1152	do k = 1,ke
1153	do i = is+1,ie
1154	fieldx(i,j,k) = -fieldx(2*is-i,j,k)
1155	fieldy(i,j,k) = -fieldy(2*is-i,j,k)
1156	end do
1157	end do
1158	case(CGRID_NE)
1159	if( 2*is-domain%x%data%end+1.LT.domain%x%data%begin ) &
1160	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE midpoint lbound error.' )
1161	do k = 1,ke
1162	do i = is+1,domain%x%data%end
1163	fieldy(i,j,k) = -fieldy(2*is-i+1,j,k)
1164	end do
1165	end do
1166	end select
1167	end if
1168	!off east edge
1169	is = domain%x%global%end
1170	if( is.LT.domain%x%data%end )then
1171	select case(grid_offset_type)
1172	case(BGRID_NE)
1173	if( 2*is-domain%x%data%end.LT.domain%x%data%begin ) &
1174	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE east edge lbound error.' )
1175	do k = 1,ke
1176	do i = is+1,domain%x%data%end
1177	fieldx(i,j,k) = fieldx(2*is-i,j,k)
1178	fieldy(i,j,k) = fieldy(2*is-i,j,k)
1179	end do
1180	end do
1181	case(CGRID_NE)
1182	if( 2*is-domain%x%data%end+1.LT.domain%x%data%begin ) &
1183	call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE east edge lbound error.' )
1184	do k = 1,ke
1185	do i = is+1,domain%x%data%end
1186	fieldy(i,j,k) = fieldy(2*is-i+1,j,k)
1187	end do
1188	end do
1189	end select
1190	end if
1191	end if
1192	end if
1193
1194	grid_offset_type = AGRID !reset
1195	call mpp_sync_self()
1196	return
1197	end subroutine MPP_UPDATE_DOMAINS_3D_V_
1198
1199	subroutine MPP_UPDATE_DOMAINS_4D_V_( fieldx, fieldy, domain, flags, gridtype )
1200	!updates data domain of 4D field whose computational domains have been computed
1201	MPP_TYPE_, intent(inout), dimension(:,:,:,:) :: fieldx, fieldy
1202	type(domain2D), intent(inout) :: domain
1203	integer, intent(in), optional :: flags, gridtype
1204	MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4))
1205	MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4))
1206	#ifdef use_CRI_pointers
1207	pointer( ptrx, field3Dx )
1208	pointer( ptry, field3Dy )
1209	ptrx = LOC(fieldx)
1210	ptry = LOC(fieldy)
1211	call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
1212	#else
1213	field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
1214	field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
1215	call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
1216	fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
1217	fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
1218	#endif
1219	return
1220	end subroutine MPP_UPDATE_DOMAINS_4D_V_
1221
1222	subroutine MPP_UPDATE_DOMAINS_5D_V_( fieldx, fieldy, domain, flags, gridtype )
1223	!updates data domain of 5D field whose computational domains have been computed
1224	MPP_TYPE_, intent(inout), dimension(:,:,:,:,:) :: fieldx, fieldy
1225	type(domain2D), intent(inout) :: domain
1226	integer, intent(in), optional :: flags, gridtype
1227	MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)size(fieldx,4)size(fieldx,5))
1228	MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)size(fieldy,4)size(fieldy,5))
1229	#ifdef use_CRI_pointers
1230	pointer( ptrx, field3Dx )
1231	pointer( ptry, field3Dy )
1232	ptrx = LOC(fieldx)
1233	ptry = LOC(fieldy)
1234	call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
1235	#else
1236	field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
1237	field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
1238	call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
1239	fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
1240	fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
1241	#endif
1242	return
1243	end subroutine MPP_UPDATE_DOMAINS_5D_V_
1244	#endif /* VECTOR_FIELD_ */

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

Context Navigation

source: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_update_domains2D.h @ 1677

Download in other formats: