Context Navigation

module_dm.F @ 2774

Last change on this file since 2774 was 2774, checked in by aslmd, 2 years ago
fix WRF handling of double precision, important for interface with physics
File size: 154.1 KB

Line
1	!WRF:PACKAGE:RSL
2	!
3	MODULE module_dm
4
5	USE module_machine
6	USE module_wrf_error
7	USE module_driver_constants
8	USE module_comm_dm
9	IMPLICIT NONE
10
11	#if ( NMM_CORE == 1 ) \|\| defined( WRF_CHEM )
12	INTEGER, PARAMETER :: max_halo_width = 6
13	#else
14	INTEGER, PARAMETER :: max_halo_width = 6 ! 5
15	#endif
16
17	INTEGER :: ips_save, ipe_save, jps_save, jpe_save, itrace
18
19	INTEGER ntasks, ntasks_y, ntasks_x, mytask, mytask_x, mytask_y
20	INTEGER local_communicator, local_communicator_periodic, local_iocommunicator
21	INTEGER local_communicator_x, local_communicator_y ! subcommunicators for rows and cols of mesh
22	LOGICAL :: dm_debug_flag = .FALSE.
23
24	INTERFACE wrf_dm_maxval
25	#if (RWORDSIZE == 8)
26	MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer
27	#else
28	MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision
29	#endif
30	END INTERFACE
31
32	INTERFACE wrf_dm_minval ! gopal's doing
33	#if (RWORDSIZE == 8)
34	MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer
35	#else
36	MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision
37	#endif
38	END INTERFACE
39
40	CONTAINS
41
42
43	SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N )
44	IMPLICIT NONE
45	INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N
46	MINI = 2*P
47	MINM = 1
48	MINN = P
49	DO M = 1, P
50	IF ( MOD( P, M ) .EQ. 0 ) THEN
51	N = P / M
52	IF ( ABS(M-N) .LT. MINI &
53	.AND. M .GE. PROCMIN_M &
54	.AND. N .GE. PROCMIN_N &
55	) THEN
56	MINI = ABS(M-N)
57	MINM = M
58	MINN = N
59	ENDIF
60	ENDIF
61	ENDDO
62	IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN
63	WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH. STOPPING.'
64	CALL wrf_message ( TRIM ( wrf_err_message ) )
65	WRITE(0,*)' PROCMIN_M ', PROCMIN_M
66	WRITE( wrf_err_message , * )' PROCMIN_M ', PROCMIN_M
67	CALL wrf_message ( TRIM ( wrf_err_message ) )
68	WRITE( wrf_err_message , * )' PROCMIN_N ', PROCMIN_N
69	CALL wrf_message ( TRIM ( wrf_err_message ) )
70	WRITE( wrf_err_message , * )' P ', P
71	CALL wrf_message ( TRIM ( wrf_err_message ) )
72	WRITE( wrf_err_message , * )' MINM ', MINM
73	CALL wrf_message ( TRIM ( wrf_err_message ) )
74	WRITE( wrf_err_message , * )' MINN ', MINN
75	CALL wrf_message ( TRIM ( wrf_err_message ) )
76	CALL wrf_error_fatal ( 'module_dm: mpaspect' )
77	ENDIF
78	RETURN
79	END SUBROUTINE MPASPECT
80
81	SUBROUTINE wrf_dm_initialize
82	USE module_configure
83	IMPLICIT NONE
84	#ifndef STUBMPI
85	INCLUDE 'mpif.h'
86	INTEGER :: local_comm, local_comm2, new_local_comm, group, newgroup, p, p1, ierr
87	INTEGER, ALLOCATABLE, DIMENSION(:) :: ranks
88	INTEGER comdup
89	INTEGER, DIMENSION(2) :: dims, coords
90	LOGICAL, DIMENSION(2) :: isperiodic
91	LOGICAL :: reorder_mesh
92
93	CALL wrf_get_dm_communicator ( local_comm )
94	CALL mpi_comm_size( local_comm, ntasks, ierr )
95	CALL nl_get_nproc_x ( 1, ntasks_x )
96	CALL nl_get_nproc_y ( 1, ntasks_y )
97	CALL nl_get_reorder_mesh( 1, reorder_mesh )
98
99	! check if user has specified in the namelist
100	IF ( ntasks_x .GT. 0 .OR. ntasks_y .GT. 0 ) THEN
101	! if only ntasks_x is specified then make it 1-d decomp in i
102	IF ( ntasks_x .GT. 0 .AND. ntasks_y .EQ. -1 ) THEN
103	ntasks_y = ntasks / ntasks_x
104	! if only ntasks_y is specified then make it 1-d decomp in j
105	ELSE IF ( ntasks_x .EQ. -1 .AND. ntasks_y .GT. 0 ) THEN
106	ntasks_x = ntasks / ntasks_y
107	ENDIF
108	! make sure user knows what they're doing
109	IF ( ntasks_x * ntasks_y .NE. ntasks ) THEN
110	WRITE( wrf_err_message , * )'WRF_DM_INITIALIZE (RSL_LITE): nproc_x * nproc_y in namelist ne ',ntasks
111	CALL wrf_error_fatal ( wrf_err_message )
112	ENDIF
113	ELSE
114	! When neither is specified, work out mesh with MPASPECT
115	! Pass nproc_ln and nproc_nt so that number of procs in
116	! i-dim (nproc_ln) is equal or lesser.
117	CALL mpaspect ( ntasks, ntasks_x, ntasks_y, 1, 1 )
118	ENDIF
119	WRITE( wrf_err_message , * )'Ntasks in X ',ntasks_x,', ntasks in Y ',ntasks_y
120	CALL wrf_message( wrf_err_message )
121
122	CALL mpi_comm_rank( local_comm, mytask, ierr )
123	! extra code to reorder the communicator 20051212jm
124	IF ( reorder_mesh ) THEN
125	ALLOCATE (ranks(ntasks))
126	CALL mpi_comm_dup ( local_comm , local_comm2, ierr )
127	CALL mpi_comm_group ( local_comm2, group, ierr )
128	DO p1=1,ntasks
129	p = p1 - 1
130	ranks(p1) = mod( p , ntasks_x ) * ntasks_y + p / ntasks_x
131	ENDDO
132	CALL mpi_group_incl( group, ntasks, ranks, newgroup, ierr )
133	DEALLOCATE (ranks)
134	CALL mpi_comm_create( local_comm2, newgroup, new_local_comm , ierr )
135	ELSE
136	new_local_comm = local_comm
137	ENDIF
138	! end extra code to reorder the communicator 20051212jm
139	dims(1) = ntasks_y ! rows
140	dims(2) = ntasks_x ! columns
141	isperiodic(1) = .false.
142	isperiodic(2) = .false.
143	CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator, ierr )
144	dims(1) = ntasks_y ! rows
145	dims(2) = ntasks_x ! columns
146	isperiodic(1) = .true.
147	isperiodic(2) = .true.
148	CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator_periodic, ierr )
149	! debug
150	CALL mpi_comm_rank( local_communicator_periodic, mytask, ierr )
151	CALL mpi_cart_coords( local_communicator_periodic, mytask, 2, coords, ierr )
152	! write(0,*)'periodic coords ',mytask, coords
153
154	CALL mpi_comm_rank( local_communicator, mytask, ierr )
155	CALL mpi_cart_coords( local_communicator, mytask, 2, coords, ierr )
156	! write(0,*)'non periodic coords ',mytask, coords
157	mytask_x = coords(2) ! col task (x)
158	mytask_y = coords(1) ! row task (y)
159	CALL nl_set_nproc_x ( 1, ntasks_x )
160	CALL nl_set_nproc_y ( 1, ntasks_y )
161
162	! 20061228 set up subcommunicators for processors in X, Y coords of mesh
163	! note that local_comm_x has all the processors in a row (X=0:nproc_x-1);
164	! in other words, local_comm_x has all the processes with the same rank in Y
165	CALL MPI_Comm_dup( new_local_comm, comdup, ierr )
166	IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_dup fails in 20061228 mod')
167	CALL MPI_Comm_split(comdup,mytask_y,mytask,local_communicator_x,ierr)
168	IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for x in 20061228 mod')
169	CALL MPI_Comm_split(comdup,mytask_x,mytask,local_communicator_y,ierr)
170	IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for y in 20061228 mod')
171	! end 20061228
172	CALL wrf_set_dm_communicator ( local_communicator )
173	#else
174	ntasks = 1
175	ntasks_x = 1
176	ntasks_y = 1
177	mytask = 0
178	mytask_x = 0
179	mytask_y = 0
180	#endif
181
182	RETURN
183	END SUBROUTINE wrf_dm_initialize
184
185	SUBROUTINE get_dm_max_halo_width( id, width )
186	IMPLICIT NONE
187	INTEGER, INTENT(IN) :: id
188	INTEGER, INTENT(OUT) :: width
189	IF ( id .EQ. 1 ) THEN ! this is coarse domain
190	width = max_halo_width
191	ELSE
192	width = max_halo_width + 3
193	ENDIF
194	RETURN
195	END SUBROUTINE get_dm_max_halo_width
196
197	SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, &
198	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
199	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
200	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
201	sp1x , ep1x , sm1x , em1x , &
202	sp2x , ep2x , sm2x , em2x , &
203	sp3x , ep3x , sm3x , em3x , &
204	sp1y , ep1y , sm1y , em1y , &
205	sp2y , ep2y , sm2y , em2y , &
206	sp3y , ep3y , sm3y , em3y , &
207	bdx , bdy )
208
209	USE module_domain, ONLY : domain, head_grid, find_grid_by_id
210	USE module_machine
211
212	IMPLICIT NONE
213	INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
214	INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
215	sm1 , em1 , sm2 , em2 , sm3 , em3
216	INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
217	sm1x , em1x , sm2x , em2x , sm3x , em3x
218	INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
219	sm1y , em1y , sm2y , em2y , sm3y , em3y
220	INTEGER, INTENT(IN) :: id, parent_id
221	TYPE(domain),POINTER :: parent
222
223	! Local variables
224	INTEGER :: ids, ide, jds, jde, kds, kde
225	INTEGER :: ims, ime, jms, jme, kms, kme
226	INTEGER :: ips, ipe, jps, jpe, kps, kpe
227	INTEGER :: imsx, imex, jmsx, jmex, kmsx, kmex
228	INTEGER :: ipsx, ipex, jpsx, jpex, kpsx, kpex
229	INTEGER :: imsy, imey, jmsy, jmey, kmsy, kmey
230	INTEGER :: ipsy, ipey, jpsy, jpey, kpsy, kpey
231
232	INTEGER :: c_sd1 , c_ed1 , c_sd2 , c_ed2 , c_sd3 , c_ed3
233	INTEGER :: c_sp1 , c_ep1 , c_sp2 , c_ep2 , c_sp3 , c_ep3 , &
234	c_sm1 , c_em1 , c_sm2 , c_em2 , c_sm3 , c_em3
235	INTEGER :: c_sp1x , c_ep1x , c_sp2x , c_ep2x , c_sp3x , c_ep3x , &
236	c_sm1x , c_em1x , c_sm2x , c_em2x , c_sm3x , c_em3x
237	INTEGER :: c_sp1y , c_ep1y , c_sp2y , c_ep2y , c_sp3y , c_ep3y , &
238	c_sm1y , c_em1y , c_sm2y , c_em2y , c_sm3y , c_em3y
239
240	INTEGER :: c_ids, c_ide, c_jds, c_jde, c_kds, c_kde
241	INTEGER :: c_ims, c_ime, c_jms, c_jme, c_kms, c_kme
242	INTEGER :: c_ips, c_ipe, c_jps, c_jpe, c_kps, c_kpe
243
244	INTEGER :: idim , jdim , kdim , rem , a, b
245	INTEGER :: i, j, ni, nj, Px, Py, P
246
247	INTEGER :: parent_grid_ratio, i_parent_start, j_parent_start
248	INTEGER :: shw
249	INTEGER :: idim_cd, jdim_cd, ierr
250	INTEGER :: max_dom
251
252	TYPE(domain), POINTER :: intermediate_grid
253	TYPE(domain), POINTER :: nest_grid
254	CHARACTER*256 :: mess
255
256	INTEGER parent_max_halo_width
257	INTEGER thisdomain_max_halo_width
258
259	SELECT CASE ( model_data_order )
260	! need to finish other cases
261	CASE ( DATA_ORDER_ZXY )
262	ids = sd2 ; ide = ed2
263	jds = sd3 ; jde = ed3
264	kds = sd1 ; kde = ed1
265	CASE ( DATA_ORDER_XYZ )
266	ids = sd1 ; ide = ed1
267	jds = sd2 ; jde = ed2
268	kds = sd3 ; kde = ed3
269	CASE ( DATA_ORDER_XZY )
270	ids = sd1 ; ide = ed1
271	jds = sd3 ; jde = ed3
272	kds = sd2 ; kde = ed2
273	CASE ( DATA_ORDER_YXZ)
274	ids = sd2 ; ide = ed2
275	jds = sd1 ; jde = ed1
276	kds = sd3 ; kde = ed3
277	END SELECT
278
279	CALL nl_get_max_dom( 1 , max_dom )
280
281	CALL get_dm_max_halo_width( id , thisdomain_max_halo_width )
282	IF ( id .GT. 1 ) THEN
283	CALL get_dm_max_halo_width( parent%id , parent_max_halo_width )
284	ENDIF
285
286	CALL compute_memory_dims_rsl_lite ( id, thisdomain_max_halo_width, 0 , bdx, bdy, &
287	ids, ide, jds, jde, kds, kde, &
288	ims, ime, jms, jme, kms, kme, &
289	imsx, imex, jmsx, jmex, kmsx, kmex, &
290	imsy, imey, jmsy, jmey, kmsy, kmey, &
291	ips, ipe, jps, jpe, kps, kpe, &
292	ipsx, ipex, jpsx, jpex, kpsx, kpex, &
293	ipsy, ipey, jpsy, jpey, kpsy, kpey )
294
295	! ensure that the every parent domain point has a full set of nested points under it
296	! even at the borders. Do this by making sure the number of nest points is a multiple of
297	! the nesting ratio. Note that this is important mostly to the intermediate domain, which
298	! is the subject of the scatter gather comms with the parent
299
300	IF ( id .GT. 1 ) THEN
301	CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
302	if ( mod(ime,parent_grid_ratio) .NE. 0 ) ime = ime + parent_grid_ratio - mod(ime,parent_grid_ratio)
303	if ( mod(jme,parent_grid_ratio) .NE. 0 ) jme = jme + parent_grid_ratio - mod(jme,parent_grid_ratio)
304	ENDIF
305
306	SELECT CASE ( model_data_order )
307	CASE ( DATA_ORDER_ZXY )
308	sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
309	sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
310	sp1 = kps ; ep1 = kpe ; sm1 = kms ; em1 = kme
311	sp2x = ipsx ; ep2x = ipex ; sm2x = imsx ; em2x = imex
312	sp3x = jpsx ; ep3x = jpex ; sm3x = jmsx ; em3x = jmex
313	sp1x = kpsx ; ep1x = kpex ; sm1x = kmsx ; em1x = kmex
314	sp2y = ipsy ; ep2y = ipey ; sm2y = imsy ; em2y = imey
315	sp3y = jpsy ; ep3y = jpey ; sm3y = jmsy ; em3y = jmey
316	sp1y = kpsy ; ep1y = kpey ; sm1y = kmsy ; em1y = kmey
317	CASE ( DATA_ORDER_ZYX )
318	sp3 = ips ; ep3 = ipe ; sm3 = ims ; em3 = ime
319	sp2 = jps ; ep2 = jpe ; sm2 = jms ; em2 = jme
320	sp1 = kps ; ep1 = kpe ; sm1 = kms ; em1 = kme
321	sp3x = ipsx ; ep3x = ipex ; sm3x = imsx ; em3x = imex
322	sp2x = jpsx ; ep2x = jpex ; sm2x = jmsx ; em2x = jmex
323	sp1x = kpsx ; ep1x = kpex ; sm1x = kmsx ; em1x = kmex
324	sp3y = ipsy ; ep3y = ipey ; sm3y = imsy ; em3y = imey
325	sp2y = jpsy ; ep2y = jpey ; sm2y = jmsy ; em2y = jmey
326	sp1y = kpsy ; ep1y = kpey ; sm1y = kmsy ; em1y = kmey
327	CASE ( DATA_ORDER_XYZ )
328	sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
329	sp2 = jps ; ep2 = jpe ; sm2 = jms ; em2 = jme
330	sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
331	sp1x = ipsx ; ep1x = ipex ; sm1x = imsx ; em1x = imex
332	sp2x = jpsx ; ep2x = jpex ; sm2x = jmsx ; em2x = jmex
333	sp3x = kpsx ; ep3x = kpex ; sm3x = kmsx ; em3x = kmex
334	sp1y = ipsy ; ep1y = ipey ; sm1y = imsy ; em1y = imey
335	sp2y = jpsy ; ep2y = jpey ; sm2y = jmsy ; em2y = jmey
336	sp3y = kpsy ; ep3y = kpey ; sm3y = kmsy ; em3y = kmey
337	CASE ( DATA_ORDER_YXZ)
338	sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
339	sp1 = jps ; ep1 = jpe ; sm1 = jms ; em1 = jme
340	sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
341	sp2x = ipsx ; ep2x = ipex ; sm2x = imsx ; em2x = imex
342	sp1x = jpsx ; ep1x = jpex ; sm1x = jmsx ; em1x = jmex
343	sp3x = kpsx ; ep3x = kpex ; sm3x = kmsx ; em3x = kmex
344	sp2y = ipsy ; ep2y = ipey ; sm2y = imsy ; em2y = imey
345	sp1y = jpsy ; ep1y = jpey ; sm1y = jmsy ; em1y = jmey
346	sp3y = kpsy ; ep3y = kpey ; sm3y = kmsy ; em3y = kmey
347	CASE ( DATA_ORDER_XZY )
348	sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
349	sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
350	sp2 = kps ; ep2 = kpe ; sm2 = kms ; em2 = kme
351	sp1x = ipsx ; ep1x = ipex ; sm1x = imsx ; em1x = imex
352	sp3x = jpsx ; ep3x = jpex ; sm3x = jmsx ; em3x = jmex
353	sp2x = kpsx ; ep2x = kpex ; sm2x = kmsx ; em2x = kmex
354	sp1y = ipsy ; ep1y = ipey ; sm1y = imsy ; em1y = imey
355	sp3y = jpsy ; ep3y = jpey ; sm3y = jmsy ; em3y = jmey
356	sp2y = kpsy ; ep2y = kpey ; sm2y = kmsy ; em2y = kmey
357	CASE ( DATA_ORDER_YZX )
358	sp3 = ips ; ep3 = ipe ; sm3 = ims ; em3 = ime
359	sp1 = jps ; ep1 = jpe ; sm1 = jms ; em1 = jme
360	sp2 = kps ; ep2 = kpe ; sm2 = kms ; em2 = kme
361	sp3x = ipsx ; ep3x = ipex ; sm3x = imsx ; em3x = imex
362	sp1x = jpsx ; ep1x = jpex ; sm1x = jmsx ; em1x = jmex
363	sp2x = kpsx ; ep2x = kpex ; sm2x = kmsx ; em2x = kmex
364	sp3y = ipsy ; ep3y = ipey ; sm3y = imsy ; em3y = imey
365	sp1y = jpsy ; ep1y = jpey ; sm1y = jmsy ; em1y = jmey
366	sp2y = kpsy ; ep2y = kpey ; sm2y = kmsy ; em2y = kmey
367	END SELECT
368
369	IF ( id.EQ.1 ) THEN
370	WRITE(wrf_err_message,)'************************************'
371	CALL wrf_message( TRIM(wrf_err_message) )
372	WRITE(wrf_err_message,*)'Parent domain'
373	CALL wrf_message( TRIM(wrf_err_message) )
374	WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
375	CALL wrf_message( TRIM(wrf_err_message) )
376	WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
377	CALL wrf_message( TRIM(wrf_err_message) )
378	WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
379	CALL wrf_message( TRIM(wrf_err_message) )
380	WRITE(wrf_err_message,)'************************************'
381	CALL wrf_message( TRIM(wrf_err_message) )
382	ENDIF
383
384	IF ( id .GT. 1 ) THEN
385
386	CALL nl_get_shw( id, shw )
387	CALL nl_get_i_parent_start( id , i_parent_start )
388	CALL nl_get_j_parent_start( id , j_parent_start )
389	CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
390
391	SELECT CASE ( model_data_order )
392	CASE ( DATA_ORDER_ZXY )
393	idim = ed2-sd2+1
394	jdim = ed3-sd3+1
395	kdim = ed1-sd1+1
396	c_kds = sd1 ; c_kde = ed1
397	CASE ( DATA_ORDER_ZYX )
398	idim = ed3-sd3+1
399	jdim = ed2-sd2+1
400	kdim = ed1-sd1+1
401	c_kds = sd1 ; c_kde = ed1
402	CASE ( DATA_ORDER_XYZ )
403	idim = ed1-sd1+1
404	jdim = ed2-sd2+1
405	kdim = ed3-sd3+1
406	c_kds = sd3 ; c_kde = ed3
407	CASE ( DATA_ORDER_YXZ)
408	idim = ed2-sd2+1
409	jdim = ed1-sd1+1
410	kdim = ed3-sd3+1
411	c_kds = sd3 ; c_kde = ed3
412	CASE ( DATA_ORDER_XZY )
413	idim = ed1-sd1+1
414	jdim = ed3-sd3+1
415	kdim = ed2-sd2+1
416	c_kds = sd2 ; c_kde = ed2
417	CASE ( DATA_ORDER_YZX )
418	idim = ed3-sd3+1
419	jdim = ed1-sd1+1
420	kdim = ed2-sd2+1
421	c_kds = sd2 ; c_kde = ed2
422	END SELECT
423
424	idim_cd = idim / parent_grid_ratio + 1 + 2*shw + 1
425	jdim_cd = jdim / parent_grid_ratio + 1 + 2*shw + 1
426
427	c_ids = i_parent_start-shw ; c_ide = c_ids + idim_cd - 1
428	c_jds = j_parent_start-shw ; c_jde = c_jds + jdim_cd - 1
429
430	! we want the intermediate domain to be decomposed the
431	! the same as the underlying nest. So try this:
432
433	c_ips = -1
434	nj = ( c_jds - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
435	ierr = 0
436	DO i = c_ids, c_ide
437	ni = ( i - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
438	CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
439	thisdomain_max_halo_width, thisdomain_max_halo_width, ierr )
440	IF ( Px .EQ. mytask_x ) THEN
441	c_ipe = i
442	IF ( c_ips .EQ. -1 ) c_ips = i
443	ENDIF
444	ENDDO
445	IF ( ierr .NE. 0 ) THEN
446	CALL tfp_message(__FILE__,__LINE__)
447	ENDIF
448	IF (c_ips .EQ. -1 ) THEN
449	c_ipe = -1
450	c_ips = 0
451	ENDIF
452
453	c_jps = -1
454	ni = ( c_ids - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
455	ierr = 0
456	DO j = c_jds, c_jde
457	nj = ( j - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
458	CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
459	thisdomain_max_halo_width, thisdomain_max_halo_width, ierr )
460
461
462	IF ( Py .EQ. mytask_y ) THEN
463	c_jpe = j
464	IF ( c_jps .EQ. -1 ) c_jps = j
465	ENDIF
466	ENDDO
467	IF ( ierr .NE. 0 ) THEN
468	CALL tfp_message(__FILE__,__LINE__)
469	ENDIF
470	IF (c_jps .EQ. -1 ) THEN
471	c_jpe = -1
472	c_jps = 0
473	ENDIF
474
475	IF ( c_jps < c_jpe .AND. c_ips < c_ipe ) THEN
476	! extend the patch dimensions out shw along edges of domain
477	IF ( mytask_x .EQ. 0 ) THEN
478	c_ips = c_ips - shw
479	ENDIF
480	IF ( mytask_x .EQ. ntasks_x-1 ) THEN
481	c_ipe = c_ipe + shw
482	ENDIF
483	c_ims = max( c_ips - max(shw,thisdomain_max_halo_width), c_ids - bdx ) - 1
484	c_ime = min( c_ipe + max(shw,thisdomain_max_halo_width), c_ide + bdx ) + 1
485
486	! handle j dims
487	! extend the patch dimensions out shw along edges of domain
488	IF ( mytask_y .EQ. 0 ) THEN
489	c_jps = c_jps - shw
490	ENDIF
491	IF ( mytask_y .EQ. ntasks_y-1 ) THEN
492	c_jpe = c_jpe + shw
493	ENDIF
494	c_jms = max( c_jps - max(shw,thisdomain_max_halo_width), c_jds - bdx ) - 1
495	c_jme = min( c_jpe + max(shw,thisdomain_max_halo_width), c_jde + bdx ) + 1
496	! handle k dims
497	ELSE
498	c_ims = 0
499	c_ime = 0
500	c_jms = 0
501	c_jme = 0
502	ENDIF
503	c_kps = 1
504	c_kpe = c_kde
505	c_kms = 1
506	c_kme = c_kde
507
508	WRITE(wrf_err_message,)'************************************'
509	CALL wrf_message( TRIM(wrf_err_message) )
510	WRITE(wrf_err_message,*)'Nesting domain'
511	CALL wrf_message( TRIM(wrf_err_message) )
512	WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
513	CALL wrf_message( TRIM(wrf_err_message) )
514	WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
515	CALL wrf_message( TRIM(wrf_err_message) )
516	WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
517	CALL wrf_message( TRIM(wrf_err_message) )
518	WRITE(wrf_err_message,*)'INTERMEDIATE domain'
519	CALL wrf_message( TRIM(wrf_err_message) )
520	WRITE(wrf_err_message,*)'ids,ide,jds,jde ',c_ids,c_ide,c_jds,c_jde
521	CALL wrf_message( TRIM(wrf_err_message) )
522	WRITE(wrf_err_message,*)'ims,ime,jms,jme ',c_ims,c_ime,c_jms,c_jme
523	CALL wrf_message( TRIM(wrf_err_message) )
524	WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',c_ips,c_ipe,c_jps,c_jpe
525	CALL wrf_message( TRIM(wrf_err_message) )
526	WRITE(wrf_err_message,)'************************************'
527	CALL wrf_message( TRIM(wrf_err_message) )
528
529	SELECT CASE ( model_data_order )
530	CASE ( DATA_ORDER_ZXY )
531	c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
532	c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
533	c_sd1 = c_kds ; c_ed1 = c_kde ; c_sp1 = c_kps ; c_ep1 = c_kpe ; c_sm1 = c_kms ; c_em1 = c_kme
534	CASE ( DATA_ORDER_ZYX )
535	c_sd3 = c_ids ; c_ed3 = c_ide ; c_sp3 = c_ips ; c_ep3 = c_ipe ; c_sm3 = c_ims ; c_em3 = c_ime
536	c_sd2 = c_jds ; c_ed2 = c_jde ; c_sp2 = c_jps ; c_ep2 = c_jpe ; c_sm2 = c_jms ; c_em2 = c_jme
537	c_sd1 = c_kds ; c_ed1 = c_kde ; c_sp1 = c_kps ; c_ep1 = c_kpe ; c_sm1 = c_kms ; c_em1 = c_kme
538	CASE ( DATA_ORDER_XYZ )
539	c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
540	c_sd2 = c_jds ; c_ed2 = c_jde ; c_sp2 = c_jps ; c_ep2 = c_jpe ; c_sm2 = c_jms ; c_em2 = c_jme
541	c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
542	CASE ( DATA_ORDER_YXZ)
543	c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
544	c_sd1 = c_jds ; c_ed1 = c_jde ; c_sp1 = c_jps ; c_ep1 = c_jpe ; c_sm1 = c_jms ; c_em1 = c_jme
545	c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
546	CASE ( DATA_ORDER_XZY )
547	c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
548	c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
549	c_sd2 = c_kds ; c_ed2 = c_kde ; c_sp2 = c_kps ; c_ep2 = c_kpe ; c_sm2 = c_kms ; c_em2 = c_kme
550	CASE ( DATA_ORDER_YZX )
551	c_sd3 = c_ids ; c_ed3 = c_ide ; c_sp3 = c_ips ; c_ep3 = c_ipe ; c_sm3 = c_ims ; c_em3 = c_ime
552	c_sd1 = c_jds ; c_ed1 = c_jde ; c_sp1 = c_jps ; c_ep1 = c_jpe ; c_sm1 = c_jms ; c_em1 = c_jme
553	c_sd2 = c_kds ; c_ed2 = c_kde ; c_sp2 = c_kps ; c_ep2 = c_kpe ; c_sm2 = c_kms ; c_em2 = c_kme
554	END SELECT
555
556	ALLOCATE ( intermediate_grid )
557	ALLOCATE ( intermediate_grid%parents( max_parents ) )
558	ALLOCATE ( intermediate_grid%nests( max_nests ) )
559
560	NULLIFY( intermediate_grid%sibling )
561	DO i = 1, max_nests
562	NULLIFY( intermediate_grid%nests(i)%ptr )
563	ENDDO
564	NULLIFY (intermediate_grid%next)
565	NULLIFY (intermediate_grid%same_level)
566	NULLIFY (intermediate_grid%i_start)
567	NULLIFY (intermediate_grid%j_start)
568	NULLIFY (intermediate_grid%i_end)
569	NULLIFY (intermediate_grid%j_end)
570	intermediate_grid%id = id ! these must be the same. Other parts of code depend on it (see gen_comms.c)
571	intermediate_grid%num_nests = 0
572	intermediate_grid%num_siblings = 0
573	intermediate_grid%num_parents = 1
574	intermediate_grid%max_tiles = 0
575	intermediate_grid%num_tiles_spec = 0
576	CALL find_grid_by_id ( id, head_grid, nest_grid )
577
578	nest_grid%intermediate_grid => intermediate_grid ! nest grid now has a pointer to this baby
579	intermediate_grid%parents(1)%ptr => nest_grid ! the intermediate grid considers nest its parent
580	intermediate_grid%num_parents = 1
581
582	c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
583	c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
584
585	intermediate_grid%sm31x = c_sm1x
586	intermediate_grid%em31x = c_em1x
587	intermediate_grid%sm32x = c_sm2x
588	intermediate_grid%em32x = c_em2x
589	intermediate_grid%sm33x = c_sm3x
590	intermediate_grid%em33x = c_em3x
591	intermediate_grid%sm31y = c_sm1y
592	intermediate_grid%em31y = c_em1y
593	intermediate_grid%sm32y = c_sm2y
594	intermediate_grid%em32y = c_em2y
595	intermediate_grid%sm33y = c_sm3y
596	intermediate_grid%em33y = c_em3y
597
598	#if defined(SGIALTIX) && (! defined(MOVE_NESTS) )
599	! allocate space for the intermediate domain
600	CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2 , .TRUE., & ! use same id as nest
601	c_sd1, c_ed1, c_sd2, c_ed2, c_sd3, c_ed3, &
602	c_sm1, c_em1, c_sm2, c_em2, c_sm3, c_em3, &
603	c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, & ! x-xpose
604	c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y ) ! y-xpose
605	#endif
606	intermediate_grid%sd31 = c_sd1
607	intermediate_grid%ed31 = c_ed1
608	intermediate_grid%sp31 = c_sp1
609	intermediate_grid%ep31 = c_ep1
610	intermediate_grid%sm31 = c_sm1
611	intermediate_grid%em31 = c_em1
612	intermediate_grid%sd32 = c_sd2
613	intermediate_grid%ed32 = c_ed2
614	intermediate_grid%sp32 = c_sp2
615	intermediate_grid%ep32 = c_ep2
616	intermediate_grid%sm32 = c_sm2
617	intermediate_grid%em32 = c_em2
618	intermediate_grid%sd33 = c_sd3
619	intermediate_grid%ed33 = c_ed3
620	intermediate_grid%sp33 = c_sp3
621	intermediate_grid%ep33 = c_ep3
622	intermediate_grid%sm33 = c_sm3
623	intermediate_grid%em33 = c_em3
624
625	CALL med_add_config_info_to_grid ( intermediate_grid )
626
627	intermediate_grid%dx = parent%dx
628	intermediate_grid%dy = parent%dy
629	intermediate_grid%dt = parent%dt
630	ENDIF
631
632	RETURN
633	END SUBROUTINE patch_domain_rsl_lite
634
635	SUBROUTINE compute_memory_dims_rsl_lite ( &
636	id , maxhalowidth , &
637	shw , bdx, bdy , &
638	ids, ide, jds, jde, kds, kde, &
639	ims, ime, jms, jme, kms, kme, &
640	imsx, imex, jmsx, jmex, kmsx, kmex, &
641	imsy, imey, jmsy, jmey, kmsy, kmey, &
642	ips, ipe, jps, jpe, kps, kpe, &
643	ipsx, ipex, jpsx, jpex, kpsx, kpex, &
644	ipsy, ipey, jpsy, jpey, kpsy, kpey )
645
646	USE module_machine
647	IMPLICIT NONE
648	INTEGER, INTENT(IN) :: id , maxhalowidth
649	INTEGER, INTENT(IN) :: shw, bdx, bdy
650	INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
651	INTEGER, INTENT(OUT) :: ims, ime, jms, jme, kms, kme
652	INTEGER, INTENT(OUT) :: imsx, imex, jmsx, jmex, kmsx, kmex
653	INTEGER, INTENT(OUT) :: imsy, imey, jmsy, jmey, kmsy, kmey
654	INTEGER, INTENT(OUT) :: ips, ipe, jps, jpe, kps, kpe
655	INTEGER, INTENT(OUT) :: ipsx, ipex, jpsx, jpex, kpsx, kpex
656	INTEGER, INTENT(OUT) :: ipsy, ipey, jpsy, jpey, kpsy, kpey
657
658	INTEGER Px, Py, P, i, j, k, ierr
659
660	#if ( ! NMM_CORE == 1 )
661
662	! xy decomposition
663
664	ips = -1
665	j = jds
666	ierr = 0
667	DO i = ids, ide
668	CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
669	maxhalowidth, maxhalowidth, ierr )
670	IF ( Px .EQ. mytask_x ) THEN
671	ipe = i
672	IF ( ips .EQ. -1 ) ips = i
673	ENDIF
674	ENDDO
675	IF ( ierr .NE. 0 ) THEN
676	CALL tfp_message(__FILE__,__LINE__)
677	ENDIF
678	! handle setting the memory dimensions where there are no X elements assigned to this proc
679	IF (ips .EQ. -1 ) THEN
680	ipe = -1
681	ips = 0
682	ENDIF
683	jps = -1
684	i = ids
685	ierr = 0
686	DO j = jds, jde
687	CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
688	maxhalowidth, maxhalowidth, ierr )
689	IF ( Py .EQ. mytask_y ) THEN
690	jpe = j
691	IF ( jps .EQ. -1 ) jps = j
692	ENDIF
693	ENDDO
694	IF ( ierr .NE. 0 ) THEN
695	CALL tfp_message(__FILE__,__LINE__)
696	ENDIF
697	! handle setting the memory dimensions where there are no Y elements assigned to this proc
698	IF (jps .EQ. -1 ) THEN
699	jpe = -1
700	jps = 0
701	ENDIF
702
703	!begin: wig; 12-Mar-2008
704	! This appears redundant with the conditionals above, but we get cases with only
705	! one of the directions being set to "missing" when turning off extra processors.
706	! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
707	IF (ipe .EQ. -1 .or. jpe .EQ. -1) THEN
708	ipe = -1
709	ips = 0
710	jpe = -1
711	jps = 0
712	ENDIF
713	!end: wig; 12-Mar-2008
714
715	!
716	! description of transpose decomposition strategy for RSL LITE. 20061231jm
717	!
718	! Here is the tranpose scheme that is implemented for RSL_LITE. Upper-case
719	! XY corresponds to the dimension of the processor mesh, lower-case xyz
720	! corresponds to grid dimension.
721	!
722	! xy zy zx
723	!
724	! XxYy <--> XzYy <--> XzYx <- note x decomposed over Y procs
725	! ^ ^
726	! \| \|
727	! +------------------+ <- this edge is costly; see below
728	!
729	! The aim is to avoid all-to-all communication over whole
730	! communicator. Instead, when possible, use a transpose scheme that requires
731	! all-to-all within dimensional communicators; that is, communicators
732	! defined for the processes in a rank or column of the processor mesh. Note,
733	! however, it is not possible to create a ring of transposes between
734	! xy-yz-xz decompositions without at least one of the edges in the ring
735	! being fully all-to-all (in other words, one of the tranpose edges must
736	! rotate and not just transpose a plane of the model grid within the
737	! processor mesh). The issue is then, where should we put this costly edge
738	! in the tranpose scheme we chose? To avoid being completely arbitrary,
739	! we chose a scheme most natural for models that use parallel spectral
740	! transforms, where the costly edge is the one that goes from the xz to
741	! the xy decomposition. (May be implemented as just a two step transpose
742	! back through yz).
743	!
744	! Additional notational convention, below. The 'x' or 'y' appended to the
745	! dimension start or end variable refers to which grid dimension is all
746	! on-processor in the given decomposition. That is ipsx and ipex are the
747	! start and end for the i-dimension in the zy decomposition where x is
748	! on-processor. ('z' is assumed for xy decomposition and not appended to
749	! the ips, ipe, etc. variable names).
750	!
751
752	! XzYy decomposition
753
754	kpsx = -1
755	j = jds ;
756	ierr = 0
757	DO k = kds, kde
758	CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
759	1, maxhalowidth, ierr )
760	IF ( Px .EQ. mytask_x ) THEN
761	kpex = k
762	IF ( kpsx .EQ. -1 ) kpsx = k
763	ENDIF
764	ENDDO
765	IF ( ierr .NE. 0 ) THEN
766	CALL tfp_message(__FILE__,__LINE__)
767	ENDIF
768
769	! handle case where no levels are assigned to this process
770	! no iterations. Do same for I and J. Need to handle memory alloc below.
771	IF (kpsx .EQ. -1 ) THEN
772	kpex = -1
773	kpsx = 0
774	ENDIF
775
776	jpsx = -1
777	k = kds ;
778	ierr = 0
779	DO j = jds, jde
780	CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
781	1, maxhalowidth, ierr )
782	IF ( Py .EQ. mytask_y ) THEN
783	jpex = j
784	IF ( jpsx .EQ. -1 ) jpsx = j
785	ENDIF
786	ENDDO
787	IF ( ierr .NE. 0 ) THEN
788	CALL tfp_message(__FILE__,__LINE__)
789	ENDIF
790	IF (jpsx .EQ. -1 ) THEN
791	jpex = -1
792	jpsx = 0
793	ENDIF
794
795	!begin: wig; 12-Mar-2008
796	! This appears redundant with the conditionals above, but we get cases with only
797	! one of the directions being set to "missing" when turning off extra processors.
798	! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
799	IF (ipex .EQ. -1 .or. jpex .EQ. -1) THEN
800	ipex = -1
801	ipsx = 0
802	jpex = -1
803	jpsx = 0
804	ENDIF
805	!end: wig; 12-Mar-2008
806
807	! XzYx decomposition (note, x grid dim is decomposed over Y processor dim)
808
809	kpsy = kpsx ! same as above
810	kpey = kpex ! same as above
811
812	ipsy = -1
813	k = kds ;
814	ierr = 0
815	DO i = ids, ide
816	CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, &
817	maxhalowidth, 1, ierr ) ! x and y for proc mesh reversed
818	IF ( Py .EQ. mytask_y ) THEN
819	ipey = i
820	IF ( ipsy .EQ. -1 ) ipsy = i
821	ENDIF
822	ENDDO
823	IF ( ierr .NE. 0 ) THEN
824	CALL tfp_message(__FILE__,__LINE__)
825	ENDIF
826	IF (ipsy .EQ. -1 ) THEN
827	ipey = -1
828	ipsy = 0
829	ENDIF
830
831
832	#else
833
834	! In case of NMM CORE, the domain only ever runs from ids..ide-1 and jds..jde-1 so
835	! adjust decomposition to reflect. 20051020 JM
836	ips = -1
837	j = jds
838	ierr = 0
839	DO i = ids, ide-1
840	CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
841	maxhalowidth, maxhalowidth , ierr )
842	IF ( Px .EQ. mytask_x ) THEN
843	ipe = i
844	IF ( Px .EQ. ntasks_x-1 ) ipe = ipe + 1
845	IF ( ips .EQ. -1 ) ips = i
846	ENDIF
847	ENDDO
848	IF ( ierr .NE. 0 ) THEN
849	CALL tfp_message(__FILE__,__LINE__)
850	ENDIF
851	jps = -1
852	i = ids ;
853	ierr = 0
854	DO j = jds, jde-1
855	CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
856	maxhalowidth , maxhalowidth , ierr )
857	IF ( Py .EQ. mytask_y ) THEN
858	jpe = j
859	IF ( Py .EQ. ntasks_y-1 ) jpe = jpe + 1
860	IF ( jps .EQ. -1 ) jps = j
861	ENDIF
862	ENDDO
863	IF ( ierr .NE. 0 ) THEN
864	CALL tfp_message(__FILE__,__LINE__)
865	ENDIF
866	#endif
867
868	! extend the patch dimensions out shw along edges of domain
869	IF ( ips < ipe .and. jps < jpe ) THEN !wig; 11-Mar-2008
870	IF ( mytask_x .EQ. 0 ) THEN
871	ips = ips - shw
872	ipsy = ipsy - shw
873	ENDIF
874	IF ( mytask_x .EQ. ntasks_x-1 ) THEN
875	ipe = ipe + shw
876	ipey = ipey + shw
877	ENDIF
878	IF ( mytask_y .EQ. 0 ) THEN
879	jps = jps - shw
880	jpsx = jpsx - shw
881	ENDIF
882	IF ( mytask_y .EQ. ntasks_y-1 ) THEN
883	jpe = jpe + shw
884	jpex = jpex + shw
885	ENDIF
886	ENDIF !wig; 11-Mar-2008
887
888	kps = 1
889	kpe = kde-kds+1
890
891	kms = 1
892	kme = kpe
893	kmsx = kpsx
894	kmex = kpex
895	kmsy = kpsy
896	kmey = kpey
897
898	! handle setting the memory dimensions where there are no levels assigned to this proc
899	IF ( kpsx .EQ. 0 .AND. kpex .EQ. -1 ) THEN
900	kmsx = 0
901	kmex = 0
902	ENDIF
903	IF ( kpsy .EQ. 0 .AND. kpey .EQ. -1 ) THEN
904	kmsy = 0
905	kmey = 0
906	ENDIF
907
908	IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
909	ims = 0
910	ime = 0
911	ELSE
912	ims = max( ips - max(shw,maxhalowidth), ids - bdx ) - 1
913	ime = min( ipe + max(shw,maxhalowidth), ide + bdx ) + 1
914	ENDIF
915	imsx = ids
916	imex = ide
917	ipsx = imsx
918	ipex = imex
919	! handle setting the memory dimensions where there are no Y elements assigned to this proc
920	IF ( ipsy .EQ. 0 .AND. ipey .EQ. -1 ) THEN
921	imsy = 0
922	imey = 0
923	ELSE
924	imsy = ipsy
925	imey = ipey
926	ENDIF
927
928	IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
929	jms = 0
930	jme = 0
931	ELSE
932	jms = max( jps - max(shw,maxhalowidth), jds - bdy ) - 1
933	jme = min( jpe + max(shw,maxhalowidth), jde + bdy ) + 1
934	ENDIF
935	jmsx = jpsx
936	jmex = jpex
937	jmsy = jds
938	jmey = jde
939	! handle setting the memory dimensions where there are no X elements assigned to this proc
940	IF ( jpsx .EQ. 0 .AND. jpex .EQ. -1 ) THEN
941	jmsx = 0
942	jmex = 0
943	ELSE
944	jpsy = jmsy
945	jpey = jmey
946	ENDIF
947
948	END SUBROUTINE compute_memory_dims_rsl_lite
949
950	! internal, used below for switching the argument to MPI calls
951	! if reals are being autopromoted to doubles in the build of WRF
952	INTEGER function getrealmpitype()
953	#ifndef STUBMPI
954	IMPLICIT NONE
955	INCLUDE 'mpif.h'
956	INTEGER rtypesize, dtypesize, ierr
957	CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
958	CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
959	IF ( RWORDSIZE .EQ. rtypesize ) THEN
960	getrealmpitype = MPI_REAL
961	ELSE IF ( RWORDSIZE .EQ. dtypesize ) THEN
962	getrealmpitype = MPI_DOUBLE_PRECISION
963	ELSE
964	CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' )
965	ENDIF
966	#else
967	! required dummy initialization for function that is never called
968	getrealmpitype = 1
969	#endif
970	RETURN
971	END FUNCTION getrealmpitype
972
973	REAL FUNCTION wrf_dm_max_real ( inval )
974	IMPLICIT NONE
975	#ifndef STUBMPI
976	INCLUDE 'mpif.h'
977	REAL inval, retval
978	INTEGER ierr
979	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MAX, local_communicator, ierr )
980	wrf_dm_max_real = retval
981	#else
982	REAL inval
983	wrf_dm_max_real = inval
984	#endif
985	END FUNCTION wrf_dm_max_real
986
987	REAL FUNCTION wrf_dm_min_real ( inval )
988	IMPLICIT NONE
989	#ifndef STUBMPI
990	INCLUDE 'mpif.h'
991	REAL inval, retval
992	INTEGER ierr
993	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MIN, local_communicator, ierr )
994	wrf_dm_min_real = retval
995	#else
996	REAL inval
997	wrf_dm_min_real = inval
998	#endif
999	END FUNCTION wrf_dm_min_real
1000
1001	SUBROUTINE wrf_dm_min_reals ( inval, retval, n )
1002	IMPLICIT NONE
1003	INTEGER n
1004	REAL inval(*)
1005	REAL retval(*)
1006	#ifndef STUBMPI
1007	INCLUDE 'mpif.h'
1008	INTEGER ierr
1009	CALL mpi_allreduce ( inval, retval , n, getrealmpitype(), MPI_MIN, local_communicator, ierr )
1010	#else
1011	retval(1:n) = inval(1:n)
1012	#endif
1013	END SUBROUTINE wrf_dm_min_reals
1014
1015	REAL FUNCTION wrf_dm_sum_real ( inval )
1016	IMPLICIT NONE
1017	#ifndef STUBMPI
1018	INCLUDE 'mpif.h'
1019	REAL inval, retval
1020	INTEGER ierr
1021	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_SUM, local_communicator, ierr )
1022	wrf_dm_sum_real = retval
1023	#else
1024	REAL inval
1025	wrf_dm_sum_real = inval
1026	#endif
1027	END FUNCTION wrf_dm_sum_real
1028
1029	SUBROUTINE wrf_dm_sum_reals (inval, retval)
1030	IMPLICIT NONE
1031	REAL, INTENT(IN) :: inval(:)
1032	REAL, INTENT(OUT) :: retval(:)
1033	#ifndef STUBMPI
1034	INCLUDE 'mpif.h'
1035	INTEGER ierr
1036	CALL mpi_allreduce ( inval, retval, SIZE(inval), getrealmpitype(), MPI_SUM, local_communicator, ierr )
1037	#else
1038	retval = inval
1039	#endif
1040	END SUBROUTINE wrf_dm_sum_reals
1041
1042	INTEGER FUNCTION wrf_dm_sum_integer ( inval )
1043	IMPLICIT NONE
1044	#ifndef STUBMPI
1045	INCLUDE 'mpif.h'
1046	INTEGER inval, retval
1047	INTEGER ierr
1048	CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, local_communicator, ierr )
1049	wrf_dm_sum_integer = retval
1050	#else
1051	INTEGER inval
1052	wrf_dm_sum_integer = inval
1053	#endif
1054	END FUNCTION wrf_dm_sum_integer
1055
1056	SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
1057	IMPLICIT NONE
1058	#ifndef STUBMPI
1059	INCLUDE 'mpif.h'
1060	REAL val, val_all( ntasks )
1061	INTEGER idex, jdex, ierr
1062	INTEGER dex(2)
1063	INTEGER dex_all (2,ntasks)
1064	INTEGER i
1065
1066	dex(1) = idex ; dex(2) = jdex
1067	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
1068	CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), local_communicator, ierr )
1069	val = val_all(1)
1070	idex = dex_all(1,1) ; jdex = dex_all(2,1)
1071	DO i = 2, ntasks
1072	IF ( val_all(i) .GT. val ) THEN
1073	val = val_all(i)
1074	idex = dex_all(1,i)
1075	jdex = dex_all(2,i)
1076	ENDIF
1077	ENDDO
1078	#else
1079	REAL val
1080	INTEGER idex, jdex, ierr
1081	#endif
1082	END SUBROUTINE wrf_dm_maxval_real
1083
1084	#if (RWORDSIZE == 4)
1085	SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
1086	IMPLICIT NONE
1087	# ifndef STUBMPI
1088	INCLUDE 'mpif.h'
1089	DOUBLE PRECISION val, val_all( ntasks )
1090	INTEGER idex, jdex, ierr
1091	INTEGER dex(2)
1092	INTEGER dex_all (2,ntasks)
1093	INTEGER i
1094
1095	dex(1) = idex ; dex(2) = jdex
1096	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
1097	CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, local_communicator, ierr )
1098	val = val_all(1)
1099	idex = dex_all(1,1) ; jdex = dex_all(2,1)
1100	DO i = 2, ntasks
1101	IF ( val_all(i) .GT. val ) THEN
1102	val = val_all(i)
1103	idex = dex_all(1,i)
1104	jdex = dex_all(2,i)
1105	ENDIF
1106	ENDDO
1107	# else
1108	DOUBLE PRECISION val
1109	INTEGER idex, jdex, ierr
1110	# endif
1111	END SUBROUTINE wrf_dm_maxval_doubleprecision
1112	#endif
1113
1114	SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
1115	IMPLICIT NONE
1116	#ifndef STUBMPI
1117	INCLUDE 'mpif.h'
1118	INTEGER val, val_all( ntasks )
1119	INTEGER idex, jdex, ierr
1120	INTEGER dex(2)
1121	INTEGER dex_all (2,ntasks)
1122	INTEGER i
1123
1124	dex(1) = idex ; dex(2) = jdex
1125	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
1126	CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, local_communicator, ierr )
1127	val = val_all(1)
1128	idex = dex_all(1,1) ; jdex = dex_all(2,1)
1129	DO i = 2, ntasks
1130	IF ( val_all(i) .GT. val ) THEN
1131	val = val_all(i)
1132	idex = dex_all(1,i)
1133	jdex = dex_all(2,i)
1134	ENDIF
1135	ENDDO
1136	#else
1137	INTEGER val
1138	INTEGER idex, jdex
1139	#endif
1140	END SUBROUTINE wrf_dm_maxval_integer
1141
1142	! For HWRF some additional computation is required. This is gopal's doing
1143
1144	SUBROUTINE wrf_dm_minval_real ( val, idex, jdex )
1145	IMPLICIT NONE
1146	REAL val, val_all( ntasks )
1147	INTEGER idex, jdex, ierr
1148	INTEGER dex(2)
1149	INTEGER dex_all (2,ntasks)
1150	! <DESCRIPTION>
1151	! Collective operation. Each processor calls passing a local value and its index; on return
1152	! all processors are passed back the maximum of all values passed and its index.
1153	!
1154	! </DESCRIPTION>
1155	INTEGER i, comm
1156	#ifndef STUBMPI
1157	INCLUDE 'mpif.h'
1158
1159	CALL wrf_get_dm_communicator ( comm )
1160	dex(1) = idex ; dex(2) = jdex
1161	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
1162	CALL mpi_allgather ( val, 1, MPI_REAL, val_all , 1, MPI_REAL, comm, ierr )
1163	val = val_all(1)
1164	idex = dex_all(1,1) ; jdex = dex_all(2,1)
1165	DO i = 2, ntasks
1166	IF ( val_all(i) .LT. val ) THEN
1167	val = val_all(i)
1168	idex = dex_all(1,i)
1169	jdex = dex_all(2,i)
1170	ENDIF
1171	ENDDO
1172	#endif
1173	END SUBROUTINE wrf_dm_minval_real
1174
1175	#if (RWORDSIZE == 4)
1176	SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex )
1177	IMPLICIT NONE
1178	DOUBLE PRECISION val, val_all( ntasks )
1179	INTEGER idex, jdex, ierr
1180	INTEGER dex(2)
1181	INTEGER dex_all (2,ntasks)
1182	! <DESCRIPTION>
1183	! Collective operation. Each processor calls passing a local value and its index; on return
1184	! all processors are passed back the maximum of all values passed and its index.
1185	!
1186	! </DESCRIPTION>
1187	INTEGER i, comm
1188	#ifndef STUBMPI
1189	INCLUDE 'mpif.h'
1190
1191	CALL wrf_get_dm_communicator ( comm )
1192	dex(1) = idex ; dex(2) = jdex
1193	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
1194	CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
1195	val = val_all(1)
1196	idex = dex_all(1,1) ; jdex = dex_all(2,1)
1197	DO i = 2, ntasks
1198	IF ( val_all(i) .LT. val ) THEN
1199	val = val_all(i)
1200	idex = dex_all(1,i)
1201	jdex = dex_all(2,i)
1202	ENDIF
1203	ENDDO
1204	#endif
1205	END SUBROUTINE wrf_dm_minval_doubleprecision
1206	#endif
1207
1208	SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex )
1209	IMPLICIT NONE
1210	INTEGER val, val_all( ntasks )
1211	INTEGER idex, jdex, ierr
1212	INTEGER dex(2)
1213	INTEGER dex_all (2,ntasks)
1214	! <DESCRIPTION>
1215	! Collective operation. Each processor calls passing a local value and its index; on return
1216	! all processors are passed back the maximum of all values passed and its index.
1217	!
1218	! </DESCRIPTION>
1219	INTEGER i, comm
1220	#ifndef STUBMPI
1221	INCLUDE 'mpif.h'
1222
1223	CALL wrf_get_dm_communicator ( comm )
1224	dex(1) = idex ; dex(2) = jdex
1225	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
1226	CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
1227	val = val_all(1)
1228	idex = dex_all(1,1) ; jdex = dex_all(2,1)
1229	DO i = 2, ntasks
1230	IF ( val_all(i) .LT. val ) THEN
1231	val = val_all(i)
1232	idex = dex_all(1,i)
1233	jdex = dex_all(2,i)
1234	ENDIF
1235	ENDDO
1236	#endif
1237	END SUBROUTINE wrf_dm_minval_integer ! End of gopal's doing
1238
1239	SUBROUTINE split_communicator
1240	#ifndef STUBMPI
1241	IMPLICIT NONE
1242	INCLUDE 'mpif.h'
1243	LOGICAL mpi_inited
1244	INTEGER mpi_comm_here, mpi_comm_local, comdup, mytask, ntasks, ierr, io_status
1245	# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
1246	INTEGER thread_support_provided, thread_support_requested
1247	#endif
1248	INTEGER i, j
1249	INTEGER, ALLOCATABLE :: icolor(:)
1250	INTEGER tasks_per_split
1251	NAMELIST /namelist_split/ tasks_per_split
1252
1253	CALL MPI_INITIALIZED( mpi_inited, ierr )
1254	IF ( .NOT. mpi_inited ) THEN
1255	# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
1256	thread_support_requested = MPI_THREAD_FUNNELED
1257	CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr )
1258	IF ( thread_support_provided .lt. thread_support_requested ) THEN
1259	CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support")
1260	ENDIF
1261	# else
1262	CALL mpi_init ( ierr )
1263	# endif
1264	CALL wrf_set_dm_communicator( MPI_COMM_WORLD )
1265	CALL wrf_termio_dup
1266	ENDIF
1267	CALL wrf_get_dm_communicator( mpi_comm_here )
1268
1269	CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ;
1270	CALL mpi_comm_size ( mpi_comm_here, ntasks, ierr ) ;
1271	#if (DA_CORE == 1)
1272	CALL mpi_comm_split( MPI_COMM_WORLD , 4 , 1 , mpi_comm_local, ierr )
1273	CALL wrf_set_dm_communicator( mpi_comm_local )
1274	CALL wrf_termio_dup
1275	CALL wrf_get_dm_communicator( mpi_comm_here )
1276	#endif
1277
1278	IF ( mytask .EQ. 0 ) THEN
1279	OPEN ( unit=27, file="namelist.input", form="formatted", status="old" )
1280	tasks_per_split = ntasks
1281	READ ( 27 , NML = namelist_split, IOSTAT=io_status )
1282	CLOSE ( 27 )
1283	ENDIF
1284	CALL mpi_bcast( io_status, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
1285	IF ( io_status .NE. 0 ) THEN
1286	RETURN ! just ignore and return
1287	ENDIF
1288	CALL mpi_bcast( tasks_per_split, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
1289	IF ( tasks_per_split .GT. ntasks .OR. tasks_per_split .LE. 0 ) RETURN
1290	IF ( mod( ntasks, tasks_per_split ) .NE. 0 ) THEN
1291	CALL wrf_message( 'WARNING: tasks_per_split does not evenly divide ntasks. Some tasks will be wasted.' )
1292	ENDIF
1293
1294	ALLOCATE( icolor(ntasks) )
1295	j = 0
1296	DO WHILE ( j .LT. ntasks / tasks_per_split )
1297	DO i = 1, tasks_per_split
1298	icolor( i + j * tasks_per_split ) = j
1299	ENDDO
1300	j = j + 1
1301	ENDDO
1302
1303	CALL MPI_Comm_dup(mpi_comm_here,comdup,ierr)
1304	CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr)
1305	CALL wrf_set_dm_communicator( mpi_comm_local )
1306
1307	DEALLOCATE( icolor )
1308	#endif
1309	END SUBROUTINE split_communicator
1310
1311	SUBROUTINE init_module_dm
1312	#ifndef STUBMPI
1313	IMPLICIT NONE
1314	INTEGER mpi_comm_local, ierr, mytask, nproc
1315	INCLUDE 'mpif.h'
1316	LOGICAL mpi_inited
1317	CALL mpi_initialized( mpi_inited, ierr )
1318	IF ( .NOT. mpi_inited ) THEN
1319	! If MPI has not been initialized then initialize it and
1320	! make comm_world the communicator
1321	! Otherwise, something else (e.g. quilt-io) has already
1322	! initialized MPI, so just grab the communicator that
1323	! should already be stored and use that.
1324	CALL mpi_init ( ierr )
1325	CALL wrf_termio_dup
1326	CALL wrf_set_dm_communicator ( MPI_COMM_WORLD )
1327	ENDIF
1328	CALL wrf_get_dm_communicator( mpi_comm_local )
1329	#endif
1330	END SUBROUTINE init_module_dm
1331
1332	! stub
1333	SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
1334	USE module_domain, ONLY : domain
1335	IMPLICIT NONE
1336	TYPE (domain), INTENT(INOUT) :: parent, nest
1337	INTEGER, INTENT(IN) :: dx,dy
1338	RETURN
1339	END SUBROUTINE wrf_dm_move_nest
1340
1341	!------------------------------------------------------------------------------
1342	SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, &
1343	mp_local_uobmask, &
1344	mp_local_vobmask, &
1345	mp_local_cobmask, errf )
1346
1347	!------------------------------------------------------------------------------
1348	! PURPOSE: Do MPI allgatherv operation across processors to get the
1349	! errors at each observation point on all processors.
1350	!
1351	!------------------------------------------------------------------------------
1352
1353	INTEGER, INTENT(IN) :: nsta ! Observation index.
1354	INTEGER, INTENT(IN) :: nerrf ! Number of error fields.
1355	INTEGER, INTENT(IN) :: niobf ! Number of observations.
1356	LOGICAL, INTENT(IN) :: MP_LOCAL_UOBMASK(NIOBF)
1357	LOGICAL, INTENT(IN) :: MP_LOCAL_VOBMASK(NIOBF)
1358	LOGICAL, INTENT(IN) :: MP_LOCAL_COBMASK(NIOBF)
1359	REAL, INTENT(INOUT) :: errf(nerrf, niobf)
1360
1361	#ifndef STUBMPI
1362	INCLUDE 'mpif.h'
1363
1364	! Local declarations
1365	integer i, n, nlocal_dot, nlocal_crs
1366	REAL UVT_BUFFER(NIOBF) ! Buffer for holding U, V, or T
1367	REAL QRK_BUFFER(NIOBF) ! Buffer for holding Q or RKO
1368	REAL SFP_BUFFER(NIOBF) ! Buffer for holding Surface pressure
1369	INTEGER N_BUFFER(NIOBF)
1370	REAL FULL_BUFFER(NIOBF)
1371	INTEGER IFULL_BUFFER(NIOBF)
1372	INTEGER IDISPLACEMENT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
1373	INTEGER ICOUNT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
1374
1375	INTEGER :: MPI_COMM_COMP ! MPI group communicator
1376	INTEGER :: NPROCS ! Number of processors
1377	INTEGER :: IERR ! Error code from MPI routines
1378
1379	! Get communicator for MPI operations.
1380	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
1381
1382	! Get rank of monitor processor and broadcast to others.
1383	CALL MPI_COMM_SIZE( MPI_COMM_COMP, NPROCS, IERR )
1384
1385	! DO THE U FIELD
1386	NLOCAL_DOT = 0
1387	DO N = 1, NSTA
1388	IF ( MP_LOCAL_UOBMASK(N) ) THEN ! USE U-POINT MASK
1389	NLOCAL_DOT = NLOCAL_DOT + 1
1390	UVT_BUFFER(NLOCAL_DOT) = ERRF(1,N) ! U WIND COMPONENT
1391	SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N) ! SURFACE PRESSURE
1392	QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N) ! RKO
1393	N_BUFFER(NLOCAL_DOT) = N
1394	ENDIF
1395	ENDDO
1396	CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
1397	ICOUNT,1,MPI_INTEGER, &
1398	MPI_COMM_COMP,IERR)
1399	I = 1
1400
1401	IDISPLACEMENT(1) = 0
1402	DO I = 2, NPROCS
1403	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
1404	ENDDO
1405	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
1406	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1407	MPI_INTEGER, MPI_COMM_COMP, IERR)
1408	! U
1409	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
1410	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1411	MPI_REAL, MPI_COMM_COMP, IERR)
1412	DO N = 1, NSTA
1413	ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1414	ENDDO
1415	! SURF PRESS AT U-POINTS
1416	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
1417	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1418	MPI_REAL, MPI_COMM_COMP, IERR)
1419	DO N = 1, NSTA
1420	ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1421	ENDDO
1422	! RKO
1423	CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL, &
1424	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1425	MPI_REAL, MPI_COMM_COMP, IERR)
1426	DO N = 1, NSTA
1427	ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1428	ENDDO
1429
1430	! DO THE V FIELD
1431	NLOCAL_DOT = 0
1432	DO N = 1, NSTA
1433	IF ( MP_LOCAL_VOBMASK(N) ) THEN ! USE V-POINT MASK
1434	NLOCAL_DOT = NLOCAL_DOT + 1
1435	UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N) ! V WIND COMPONENT
1436	SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N) ! SURFACE PRESSURE
1437	N_BUFFER(NLOCAL_DOT) = N
1438	ENDIF
1439	ENDDO
1440	CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
1441	ICOUNT,1,MPI_INTEGER, &
1442	MPI_COMM_COMP,IERR)
1443	I = 1
1444
1445	IDISPLACEMENT(1) = 0
1446	DO I = 2, NPROCS
1447	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
1448	ENDDO
1449	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
1450	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1451	MPI_INTEGER, MPI_COMM_COMP, IERR)
1452	! V
1453	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
1454	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1455	MPI_REAL, MPI_COMM_COMP, IERR)
1456	DO N = 1, NSTA
1457	ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1458	ENDDO
1459	! SURF PRESS AT V-POINTS
1460	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
1461	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1462	MPI_REAL, MPI_COMM_COMP, IERR)
1463	DO N = 1, NSTA
1464	ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1465	ENDDO
1466
1467	! DO THE CROSS FIELDS, T AND Q
1468	NLOCAL_CRS = 0
1469	DO N = 1, NSTA
1470	IF ( MP_LOCAL_COBMASK(N) ) THEN ! USE MASS-POINT MASK
1471	NLOCAL_CRS = NLOCAL_CRS + 1
1472	UVT_BUFFER(NLOCAL_CRS) = ERRF(3,N) ! TEMPERATURE
1473	QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N) ! MOISTURE
1474	SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N) ! SURFACE PRESSURE
1475	N_BUFFER(NLOCAL_CRS) = N
1476	ENDIF
1477	ENDDO
1478	CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, &
1479	ICOUNT,1,MPI_INTEGER, &
1480	MPI_COMM_COMP,IERR)
1481	IDISPLACEMENT(1) = 0
1482	DO I = 2, NPROCS
1483	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
1484	ENDDO
1485	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER, &
1486	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1487	MPI_INTEGER, MPI_COMM_COMP, IERR)
1488	! T
1489	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_CRS, MPI_REAL, &
1490	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1491	MPI_REAL, MPI_COMM_COMP, IERR)
1492
1493	DO N = 1, NSTA
1494	ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1495	ENDDO
1496	! Q
1497	CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL, &
1498	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1499	MPI_REAL, MPI_COMM_COMP, IERR)
1500	DO N = 1, NSTA
1501	ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1502	ENDDO
1503	! SURF PRESS AT MASS POINTS
1504	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL, &
1505	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1506	MPI_REAL, MPI_COMM_COMP, IERR)
1507	DO N = 1, NSTA
1508	ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1509	ENDDO
1510	#endif
1511	END SUBROUTINE get_full_obs_vector
1512
1513
1514
1515	SUBROUTINE wrf_dm_maxtile_real ( val , tile)
1516	IMPLICIT NONE
1517	REAL val, val_all( ntasks )
1518	INTEGER tile
1519	INTEGER ierr
1520
1521	! <DESCRIPTION>
1522	! Collective operation. Each processor calls passing a local value and its index; on return
1523	! all processors are passed back the maximum of all values passed and its tile number.
1524	!
1525	! </DESCRIPTION>
1526	INTEGER i, comm
1527	#ifndef STUBMPI
1528	INCLUDE 'mpif.h'
1529
1530	CALL wrf_get_dm_communicator ( comm )
1531	CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
1532	val = val_all(1)
1533	tile = 1
1534	DO i = 2, ntasks
1535	IF ( val_all(i) .GT. val ) THEN
1536	tile = i
1537	val = val_all(i)
1538	ENDIF
1539	ENDDO
1540	#endif
1541	END SUBROUTINE wrf_dm_maxtile_real
1542
1543
1544	SUBROUTINE wrf_dm_mintile_real ( val , tile)
1545	IMPLICIT NONE
1546	REAL val, val_all( ntasks )
1547	INTEGER tile
1548	INTEGER ierr
1549
1550	! <DESCRIPTION>
1551	! Collective operation. Each processor calls passing a local value and its index; on return
1552	! all processors are passed back the minimum of all values passed and its tile number.
1553	!
1554	! </DESCRIPTION>
1555	INTEGER i, comm
1556	#ifndef STUBMPI
1557	INCLUDE 'mpif.h'
1558
1559	CALL wrf_get_dm_communicator ( comm )
1560	CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
1561	val = val_all(1)
1562	tile = 1
1563	DO i = 2, ntasks
1564	IF ( val_all(i) .LT. val ) THEN
1565	tile = i
1566	val = val_all(i)
1567	ENDIF
1568	ENDDO
1569	#endif
1570	END SUBROUTINE wrf_dm_mintile_real
1571
1572
1573	SUBROUTINE wrf_dm_mintile_double ( val , tile)
1574	IMPLICIT NONE
1575	DOUBLE PRECISION val, val_all( ntasks )
1576	INTEGER tile
1577	INTEGER ierr
1578
1579	! <DESCRIPTION>
1580	! Collective operation. Each processor calls passing a local value and its index; on return
1581	! all processors are passed back the minimum of all values passed and its tile number.
1582	!
1583	! </DESCRIPTION>
1584	INTEGER i, comm
1585	#ifndef STUBMPI
1586	INCLUDE 'mpif.h'
1587
1588	CALL wrf_get_dm_communicator ( comm )
1589	CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
1590	val = val_all(1)
1591	tile = 1
1592	DO i = 2, ntasks
1593	IF ( val_all(i) .LT. val ) THEN
1594	tile = i
1595	val = val_all(i)
1596	ENDIF
1597	ENDDO
1598	#endif
1599	END SUBROUTINE wrf_dm_mintile_double
1600
1601
1602	SUBROUTINE wrf_dm_tile_val_int ( val , tile)
1603	IMPLICIT NONE
1604	INTEGER val, val_all( ntasks )
1605	INTEGER tile
1606	INTEGER ierr
1607
1608	! <DESCRIPTION>
1609	! Collective operation. Get value from input tile.
1610	!
1611	! </DESCRIPTION>
1612	INTEGER i, comm
1613	#ifndef STUBMPI
1614	INCLUDE 'mpif.h'
1615
1616	CALL wrf_get_dm_communicator ( comm )
1617	CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
1618	val = val_all(tile)
1619	#endif
1620	END SUBROUTINE wrf_dm_tile_val_int
1621
1622	SUBROUTINE wrf_get_hostname ( str )
1623	CHARACTER() str
1624	CHARACTER tmp(512)
1625	INTEGER i , n, cs
1626	CALL rsl_lite_get_hostname( tmp, 512, n, cs )
1627	DO i = 1, n
1628	str(i:i) = tmp(i)
1629	ENDDO
1630	RETURN
1631	END SUBROUTINE wrf_get_hostname
1632
1633	SUBROUTINE wrf_get_hostid ( hostid )
1634	INTEGER hostid
1635	CHARACTER tmp(512)
1636	INTEGER i, sz, n, cs
1637	CALL rsl_lite_get_hostname( tmp, 512, n, cs )
1638	hostid = cs
1639	RETURN
1640	END SUBROUTINE wrf_get_hostid
1641
1642	END MODULE module_dm
1643
1644	!=========================================================================
1645	! wrf_dm_patch_domain has to be outside the module because it is called
1646	! by a routine in module_domain but depends on module domain
1647
1648	SUBROUTINE wrf_dm_patch_domain ( id , domdesc , parent_id , parent_domdesc , &
1649	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
1650	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
1651	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
1652	sp1x , ep1x , sm1x , em1x , &
1653	sp2x , ep2x , sm2x , em2x , &
1654	sp3x , ep3x , sm3x , em3x , &
1655	sp1y , ep1y , sm1y , em1y , &
1656	sp2y , ep2y , sm2y , em2y , &
1657	sp3y , ep3y , sm3y , em3y , &
1658	bdx , bdy )
1659	USE module_domain, ONLY : domain, head_grid, find_grid_by_id
1660	USE module_dm
1661	IMPLICIT NONE
1662
1663	INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
1664	INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
1665	sm1 , em1 , sm2 , em2 , sm3 , em3
1666	INTEGER :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
1667	sm1x , em1x , sm2x , em2x , sm3x , em3x
1668	INTEGER :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
1669	sm1y , em1y , sm2y , em2y , sm3y , em3y
1670	INTEGER, INTENT(INOUT):: id , domdesc , parent_id , parent_domdesc
1671
1672	TYPE(domain), POINTER :: parent
1673	TYPE(domain), POINTER :: grid_ptr
1674
1675	! this is necessary because we cannot pass parent directly into
1676	! wrf_dm_patch_domain because creating the correct interface definitions
1677	! would generate a circular USE reference between module_domain and module_dm
1678	! see comment this date in module_domain for more information. JM 20020416
1679
1680	NULLIFY( parent )
1681	grid_ptr => head_grid
1682	CALL find_grid_by_id( parent_id , grid_ptr , parent )
1683
1684	CALL patch_domain_rsl_lite ( id , parent, parent_id , &
1685	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
1686	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
1687	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
1688	sp1x , ep1x , sm1x , em1x , &
1689	sp2x , ep2x , sm2x , em2x , &
1690	sp3x , ep3x , sm3x , em3x , &
1691	sp1y , ep1y , sm1y , em1y , &
1692	sp2y , ep2y , sm2y , em2y , &
1693	sp3y , ep3y , sm3y , em3y , &
1694	bdx , bdy )
1695
1696	RETURN
1697	END SUBROUTINE wrf_dm_patch_domain
1698
1699	SUBROUTINE wrf_termio_dup
1700	IMPLICIT NONE
1701	INTEGER mytask, ntasks
1702	#ifndef STUBMPI
1703	INTEGER ierr
1704	INCLUDE 'mpif.h'
1705	CALL mpi_comm_size(MPI_COMM_WORLD, ntasks, ierr )
1706	CALL mpi_comm_rank(MPI_COMM_WORLD, mytask, ierr )
1707	write(0,*)'starting wrf task ',mytask,' of ',ntasks
1708	CALL rsl_error_dup1( mytask )
1709	#else
1710	mytask = 0
1711	ntasks = 1
1712	#endif
1713	END SUBROUTINE wrf_termio_dup
1714
1715	SUBROUTINE wrf_get_myproc( myproc )
1716	USE module_dm , ONLY : mytask
1717	IMPLICIT NONE
1718	INTEGER myproc
1719	myproc = mytask
1720	RETURN
1721	END SUBROUTINE wrf_get_myproc
1722
1723	SUBROUTINE wrf_get_nproc( nproc )
1724	USE module_dm , ONLY : ntasks
1725	IMPLICIT NONE
1726	INTEGER nproc
1727	nproc = ntasks
1728	RETURN
1729	END SUBROUTINE wrf_get_nproc
1730
1731	SUBROUTINE wrf_get_nprocx( nprocx )
1732	USE module_dm , ONLY : ntasks_x
1733	IMPLICIT NONE
1734	INTEGER nprocx
1735	nprocx = ntasks_x
1736	RETURN
1737	END SUBROUTINE wrf_get_nprocx
1738
1739	SUBROUTINE wrf_get_nprocy( nprocy )
1740	USE module_dm , ONLY : ntasks_y
1741	IMPLICIT NONE
1742	INTEGER nprocy
1743	nprocy = ntasks_y
1744	RETURN
1745	END SUBROUTINE wrf_get_nprocy
1746
1747	SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
1748	USE module_dm , ONLY : local_communicator
1749	IMPLICIT NONE
1750	#ifndef STUBMPI
1751	INCLUDE 'mpif.h'
1752	#endif
1753	INTEGER size
1754	#ifndef NEC
1755	INTEGER*1 BUF(size)
1756	#else
1757	CHARACTER*1 BUF(size)
1758	#endif
1759	#ifndef STUBMPI
1760	CALL BYTE_BCAST ( buf , size, local_communicator )
1761	#endif
1762	RETURN
1763	END SUBROUTINE wrf_dm_bcast_bytes
1764
1765	SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
1766	IMPLICIT NONE
1767	INTEGER n1
1768	! <DESCRIPTION>
1769	! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
1770	!
1771	! </DESCRIPTION>
1772	CHARACTER() buf
1773	#ifndef STUBMPI
1774	INTEGER ibuf(256),i,n
1775	CHARACTER*256 tstr
1776	n = n1
1777	! Root task is required to have the correct value of N1, other tasks
1778	! might not have the correct value.
1779	CALL wrf_dm_bcast_integer( n , 1 )
1780	IF (n .GT. 256) n = 256
1781	IF (n .GT. 0 ) then
1782	DO i = 1, n
1783	ibuf(I) = ichar(buf(I:I))
1784	ENDDO
1785	CALL wrf_dm_bcast_integer( ibuf, n )
1786	buf = ''
1787	DO i = 1, n
1788	buf(i:i) = char(ibuf(i))
1789	ENDDO
1790	ENDIF
1791	#endif
1792	RETURN
1793	END SUBROUTINE wrf_dm_bcast_string
1794
1795	SUBROUTINE wrf_dm_bcast_integer( BUF, N1 )
1796	IMPLICIT NONE
1797	INTEGER n1
1798	INTEGER buf(*)
1799	CALL wrf_dm_bcast_bytes ( BUF , N1 * IWORDSIZE )
1800	RETURN
1801	END SUBROUTINE wrf_dm_bcast_integer
1802
1803	SUBROUTINE wrf_dm_bcast_double( BUF, N1 )
1804	IMPLICIT NONE
1805	INTEGER n1
1806	! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
1807	! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
1808	! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
1809	! since we were not indexing the globbuf and Field arrays it does not matter
1810	REAL buf(*)
1811	CALL wrf_dm_bcast_bytes ( BUF , N1 * DWORDSIZE )
1812	RETURN
1813	END SUBROUTINE wrf_dm_bcast_double
1814
1815	SUBROUTINE wrf_dm_bcast_real( BUF, N1 )
1816	IMPLICIT NONE
1817	INTEGER n1
1818	REAL buf(*)
1819	CALL wrf_dm_bcast_bytes ( BUF , N1 * RWORDSIZE )
1820	RETURN
1821	END SUBROUTINE wrf_dm_bcast_real
1822
1823	SUBROUTINE wrf_dm_bcast_logical( BUF, N1 )
1824	IMPLICIT NONE
1825	INTEGER n1
1826	LOGICAL buf(*)
1827	CALL wrf_dm_bcast_bytes ( BUF , N1 * LWORDSIZE )
1828	RETURN
1829	END SUBROUTINE wrf_dm_bcast_logical
1830
1831	SUBROUTINE write_68( grid, v , s , &
1832	ids, ide, jds, jde, kds, kde, &
1833	ims, ime, jms, jme, kms, kme, &
1834	its, ite, jts, jte, kts, kte )
1835	USE module_domain, ONLY : domain
1836	IMPLICIT NONE
1837	TYPE(domain) , INTENT (INOUT) :: grid
1838	CHARACTER () s
1839	INTEGER ids, ide, jds, jde, kds, kde, &
1840	ims, ime, jms, jme, kms, kme, &
1841	its, ite, jts, jte, kts, kte
1842	REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) :: v
1843
1844	INTEGER i,j,k,ierr
1845
1846	logical, external :: wrf_dm_on_monitor
1847	real globbuf( ids:ide, kds:kde, jds:jde )
1848	character*3 ord, stag
1849
1850	if ( kds == kde ) then
1851	ord = 'xy'
1852	stag = 'xy'
1853	CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
1854	ids, ide, jds, jde, kds, kde, &
1855	ims, ime, jms, jme, kms, kme, &
1856	its, ite, jts, jte, kts, kte )
1857	else
1858
1859	stag = 'xyz'
1860	ord = 'xzy'
1861	CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
1862	ids, ide, kds, kde, jds, jde, &
1863	ims, ime, kms, kme, jms, jme, &
1864	its, ite, kts, kte, jts, jte )
1865	endif
1866
1867
1868	if ( wrf_dm_on_monitor() ) THEN
1869	WRITE(68,*) ide-ids+1, jde-jds+1 , s
1870	DO j = jds, jde
1871	DO i = ids, ide
1872	WRITE(68,*) globbuf(i,1,j)
1873	ENDDO
1874	ENDDO
1875	endif
1876
1877	RETURN
1878	END
1879
1880	SUBROUTINE wrf_abort
1881	IMPLICIT NONE
1882	#ifndef STUBMPI
1883	INCLUDE 'mpif.h'
1884	INTEGER ierr
1885	CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
1886	#else
1887	STOP
1888	#endif
1889	END SUBROUTINE wrf_abort
1890
1891	SUBROUTINE wrf_dm_shutdown
1892	IMPLICIT NONE
1893	#ifndef STUBMPI
1894	INTEGER ierr
1895	CALL MPI_FINALIZE( ierr )
1896	#endif
1897	RETURN
1898	END SUBROUTINE wrf_dm_shutdown
1899
1900	LOGICAL FUNCTION wrf_dm_on_monitor()
1901	! USE module_dm
1902	IMPLICIT NONE
1903	#ifndef STUBMPI
1904	INCLUDE 'mpif.h'
1905	INTEGER tsk, ierr, mpi_comm_local
1906	CALL wrf_get_dm_communicator( mpi_comm_local )
1907	CALL mpi_comm_rank ( mpi_comm_local, tsk , ierr )
1908	wrf_dm_on_monitor = tsk .EQ. 0
1909	#else
1910	wrf_dm_on_monitor = .TRUE.
1911	#endif
1912	RETURN
1913	END FUNCTION wrf_dm_on_monitor
1914
1915	INTEGER FUNCTION wrf_dm_monitor_rank()
1916	! USE module_dm
1917	IMPLICIT NONE
1918	wrf_dm_monitor_rank = 0
1919	RETURN
1920	END FUNCTION wrf_dm_monitor_rank
1921
1922	SUBROUTINE wrf_get_dm_communicator ( communicator )
1923	USE module_dm , ONLY : local_communicator
1924	IMPLICIT NONE
1925	INTEGER , INTENT(OUT) :: communicator
1926	communicator = local_communicator
1927	RETURN
1928	END SUBROUTINE wrf_get_dm_communicator
1929
1930	SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
1931	USE module_dm , ONLY : local_iocommunicator
1932	IMPLICIT NONE
1933	INTEGER , INTENT(OUT) :: iocommunicator
1934	iocommunicator = local_iocommunicator
1935	RETURN
1936	END SUBROUTINE wrf_get_dm_iocommunicator
1937
1938	SUBROUTINE wrf_set_dm_communicator ( communicator )
1939	USE module_dm , ONLY : local_communicator
1940	IMPLICIT NONE
1941	INTEGER , INTENT(IN) :: communicator
1942	local_communicator = communicator
1943	RETURN
1944	END SUBROUTINE wrf_set_dm_communicator
1945
1946	SUBROUTINE wrf_set_dm_iocommunicator ( iocommunicator )
1947	USE module_dm , ONLY : local_iocommunicator
1948	IMPLICIT NONE
1949	INTEGER , INTENT(IN) :: iocommunicator
1950	local_iocommunicator = iocommunicator
1951	RETURN
1952	END SUBROUTINE wrf_set_dm_iocommunicator
1953
1954
1955	!!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1956
1957	SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,stagger,ordering,&
1958	DS1,DE1,DS2,DE2,DS3,DE3,&
1959	MS1,ME1,MS2,ME2,MS3,ME3,&
1960	PS1,PE1,PS2,PE2,PS3,PE3 )
1961	IMPLICIT NONE
1962	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1963	MS1,ME1,MS2,ME2,MS3,ME3,&
1964	PS1,PE1,PS2,PE2,PS3,PE3
1965	CHARACTER () stagger,ordering
1966	INTEGER fid,domdesc
1967	REAL globbuf(*)
1968	REAL buf(*)
1969
1970	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,RWORDSIZE,&
1971	DS1,DE1,DS2,DE2,DS3,DE3,&
1972	MS1,ME1,MS2,ME2,MS3,ME3,&
1973	PS1,PE1,PS2,PE2,PS3,PE3 )
1974
1975	RETURN
1976	END SUBROUTINE wrf_patch_to_global_real
1977
1978	SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,stagger,ordering,&
1979	DS1,DE1,DS2,DE2,DS3,DE3,&
1980	MS1,ME1,MS2,ME2,MS3,ME3,&
1981	PS1,PE1,PS2,PE2,PS3,PE3 )
1982	IMPLICIT NONE
1983	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1984	MS1,ME1,MS2,ME2,MS3,ME3,&
1985	PS1,PE1,PS2,PE2,PS3,PE3
1986	CHARACTER () stagger,ordering
1987	INTEGER fid,domdesc
1988	! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
1989	! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
1990	! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
1991	! since we were not indexing the globbuf and Field arrays it does not matter
1992	REAL globbuf(*)
1993	REAL buf(*)
1994
1995	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,DWORDSIZE,&
1996	DS1,DE1,DS2,DE2,DS3,DE3,&
1997	MS1,ME1,MS2,ME2,MS3,ME3,&
1998	PS1,PE1,PS2,PE2,PS3,PE3 )
1999
2000	RETURN
2001	END SUBROUTINE wrf_patch_to_global_double
2002
2003
2004	SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,stagger,ordering,&
2005	DS1,DE1,DS2,DE2,DS3,DE3,&
2006	MS1,ME1,MS2,ME2,MS3,ME3,&
2007	PS1,PE1,PS2,PE2,PS3,PE3 )
2008	IMPLICIT NONE
2009	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2010	MS1,ME1,MS2,ME2,MS3,ME3,&
2011	PS1,PE1,PS2,PE2,PS3,PE3
2012	CHARACTER () stagger,ordering
2013	INTEGER fid,domdesc
2014	INTEGER globbuf(*)
2015	INTEGER buf(*)
2016
2017	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,IWORDSIZE,&
2018	DS1,DE1,DS2,DE2,DS3,DE3,&
2019	MS1,ME1,MS2,ME2,MS3,ME3,&
2020	PS1,PE1,PS2,PE2,PS3,PE3 )
2021
2022	RETURN
2023	END SUBROUTINE wrf_patch_to_global_integer
2024
2025
2026	SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,stagger,ordering,&
2027	DS1,DE1,DS2,DE2,DS3,DE3,&
2028	MS1,ME1,MS2,ME2,MS3,ME3,&
2029	PS1,PE1,PS2,PE2,PS3,PE3 )
2030	IMPLICIT NONE
2031	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2032	MS1,ME1,MS2,ME2,MS3,ME3,&
2033	PS1,PE1,PS2,PE2,PS3,PE3
2034	CHARACTER () stagger,ordering
2035	INTEGER fid,domdesc
2036	LOGICAL globbuf(*)
2037	LOGICAL buf(*)
2038
2039	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,LWORDSIZE,&
2040	DS1,DE1,DS2,DE2,DS3,DE3,&
2041	MS1,ME1,MS2,ME2,MS3,ME3,&
2042	PS1,PE1,PS2,PE2,PS3,PE3 )
2043
2044	RETURN
2045	END SUBROUTINE wrf_patch_to_global_logical
2046
2047	#ifdef DEREF_KLUDGE
2048	# define FRSTELEM (1)
2049	#else
2050	# define FRSTELEM
2051	#endif
2052
2053	SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,typesize,&
2054	DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2055	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2056	PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
2057	USE module_driver_constants
2058	USE module_timing
2059	USE module_wrf_error
2060	USE module_dm
2061	IMPLICIT NONE
2062	INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2063	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2064	PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
2065	CHARACTER () stagger,ordering
2066	INTEGER domdesc,typesize,ierr
2067	REAL globbuf(*)
2068	REAL buf(*)
2069	#ifndef STUBMPI
2070	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2071	MS1,ME1,MS2,ME2,MS3,ME3,&
2072	PS1,PE1,PS2,PE2,PS3,PE3
2073	INTEGER ids,ide,jds,jde,kds,kde,&
2074	ims,ime,jms,jme,kms,kme,&
2075	ips,ipe,jps,jpe,kps,kpe
2076	LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
2077
2078	INTEGER i, j, k, ndim
2079	INTEGER Patch(3,2), Gpatch(3,2,ntasks)
2080	! allocated further down, after the D indices are potentially recalculated for staggering
2081	REAL, ALLOCATABLE :: tmpbuf( : )
2082	REAL locbuf( (PE1a-PS1a+1)(PE2a-PS2a+1)(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
2083
2084	DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
2085	MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
2086	PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
2087
2088	SELECT CASE ( TRIM(ordering) )
2089	CASE ( 'xy', 'yx' )
2090	ndim = 2
2091	CASE DEFAULT
2092	ndim = 3 ! where appropriate
2093	END SELECT
2094
2095	SELECT CASE ( TRIM(ordering) )
2096	CASE ( 'xyz','xy' )
2097	! the non-staggered variables come in at one-less than
2098	! domain dimensions, but code wants full domain spec, so
2099	! adjust if not staggered
2100	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2101	IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
2102	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2103	CASE ( 'yxz','yx' )
2104	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2105	IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
2106	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2107	CASE ( 'zxy' )
2108	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2109	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2110	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
2111	CASE ( 'xzy' )
2112	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2113	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2114	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
2115	CASE DEFAULT
2116	END SELECT
2117
2118	! moved to here to be after the potential recalculations of D dims
2119	IF ( wrf_dm_on_monitor() ) THEN
2120	ALLOCATE ( tmpbuf ( (DE1-DS1+1)(DE2-DS2+1)(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
2121	ELSE
2122	ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
2123	ENDIF
2124	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_patch_to_global_generic')
2125
2126	Patch(1,1) = ps1 ; Patch(1,2) = pe1 ! use patch dims
2127	Patch(2,1) = ps2 ; Patch(2,2) = pe2
2128	Patch(3,1) = ps3 ; Patch(3,2) = pe3
2129
2130	IF ( typesize .EQ. RWORDSIZE ) THEN
2131	CALL just_patch_r ( buf , locbuf , size(locbuf), &
2132	PS1, PE1, PS2, PE2, PS3, PE3 , &
2133	MS1, ME1, MS2, ME2, MS3, ME3 )
2134	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2135	CALL just_patch_i ( buf , locbuf , size(locbuf), &
2136	PS1, PE1, PS2, PE2, PS3, PE3 , &
2137	MS1, ME1, MS2, ME2, MS3, ME3 )
2138	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2139	CALL just_patch_d ( buf , locbuf , size(locbuf), &
2140	PS1, PE1, PS2, PE2, PS3, PE3 , &
2141	MS1, ME1, MS2, ME2, MS3, ME3 )
2142	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2143	CALL just_patch_l ( buf , locbuf , size(locbuf), &
2144	PS1, PE1, PS2, PE2, PS3, PE3 , &
2145	MS1, ME1, MS2, ME2, MS3, ME3 )
2146	ENDIF
2147
2148	! defined in external/io_quilt
2149	CALL collect_on_comm0 ( local_communicator , IWORDSIZE , &
2150	Patch , 6 , &
2151	GPatch , 6*ntasks )
2152
2153	CALL collect_on_comm0 ( local_communicator , typesize , &
2154	locbuf , (pe1-ps1+1)(pe2-ps2+1)(pe3-ps3+1), &
2155	tmpbuf FRSTELEM , (de1-ds1+1)(de2-ds2+1)(de3-ds3+1) )
2156
2157	ndim = len(TRIM(ordering))
2158
2159	IF ( wrf_at_debug_level(500) ) THEN
2160	CALL start_timing
2161	ENDIF
2162
2163	IF ( ndim .GE. 2 .AND. wrf_dm_on_monitor() ) THEN
2164
2165	IF ( typesize .EQ. RWORDSIZE ) THEN
2166	CALL patch_2_outbuf_r ( tmpbuf FRSTELEM , globbuf , &
2167	DS1, DE1, DS2, DE2, DS3, DE3 , &
2168	GPATCH )
2169	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2170	CALL patch_2_outbuf_i ( tmpbuf FRSTELEM , globbuf , &
2171	DS1, DE1, DS2, DE2, DS3, DE3 , &
2172	GPATCH )
2173	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2174	CALL patch_2_outbuf_d ( tmpbuf FRSTELEM , globbuf , &
2175	DS1, DE1, DS2, DE2, DS3, DE3 , &
2176	GPATCH )
2177	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2178	CALL patch_2_outbuf_l ( tmpbuf FRSTELEM , globbuf , &
2179	DS1, DE1, DS2, DE2, DS3, DE3 , &
2180	GPATCH )
2181	ENDIF
2182
2183	ENDIF
2184
2185	IF ( wrf_at_debug_level(500) ) THEN
2186	CALL end_timing('wrf_patch_to_global_generic')
2187	ENDIF
2188	DEALLOCATE( tmpbuf )
2189	#endif
2190	RETURN
2191	END SUBROUTINE wrf_patch_to_global_generic
2192
2193	SUBROUTINE just_patch_i ( inbuf , outbuf, noutbuf, &
2194	PS1,PE1,PS2,PE2,PS3,PE3, &
2195	MS1,ME1,MS2,ME2,MS3,ME3 )
2196	USE module_dm
2197	IMPLICIT NONE
2198	INTEGER , INTENT(IN) :: noutbuf
2199	INTEGER , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2200	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2201	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2202	INTEGER , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(IN) :: inbuf
2203	! Local
2204	INTEGER :: i,j,k,n , icurs
2205	icurs = 1
2206	DO k = PS3, PE3
2207	DO j = PS2, PE2
2208	DO i = PS1, PE1
2209	outbuf( icurs ) = inbuf( i, j, k )
2210	icurs = icurs + 1
2211	ENDDO
2212	ENDDO
2213	ENDDO
2214	RETURN
2215	END SUBROUTINE just_patch_i
2216
2217	SUBROUTINE just_patch_r ( inbuf , outbuf, noutbuf, &
2218	PS1,PE1,PS2,PE2,PS3,PE3, &
2219	MS1,ME1,MS2,ME2,MS3,ME3 )
2220	USE module_dm
2221	IMPLICIT NONE
2222	INTEGER , INTENT(IN) :: noutbuf
2223	REAL , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2224	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2225	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2226	REAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
2227	! Local
2228	INTEGER :: i,j,k , icurs
2229	icurs = 1
2230	DO k = PS3, PE3
2231	DO j = PS2, PE2
2232	DO i = PS1, PE1
2233	outbuf( icurs ) = inbuf( i, j, k )
2234	icurs = icurs + 1
2235	ENDDO
2236	ENDDO
2237	ENDDO
2238	RETURN
2239	END SUBROUTINE just_patch_r
2240
2241	SUBROUTINE just_patch_d ( inbuf , outbuf, noutbuf, &
2242	PS1,PE1,PS2,PE2,PS3,PE3, &
2243	MS1,ME1,MS2,ME2,MS3,ME3 )
2244	USE module_dm
2245	IMPLICIT NONE
2246	INTEGER , INTENT(IN) :: noutbuf
2247	DOUBLE PRECISION , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2248	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2249	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2250	DOUBLE PRECISION , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
2251	! Local
2252	INTEGER :: i,j,k,n , icurs
2253	icurs = 1
2254	DO k = PS3, PE3
2255	DO j = PS2, PE2
2256	DO i = PS1, PE1
2257	outbuf( icurs ) = inbuf( i, j, k )
2258	icurs = icurs + 1
2259	ENDDO
2260	ENDDO
2261	ENDDO
2262	RETURN
2263	END SUBROUTINE just_patch_d
2264
2265	SUBROUTINE just_patch_l ( inbuf , outbuf, noutbuf, &
2266	PS1,PE1,PS2,PE2,PS3,PE3, &
2267	MS1,ME1,MS2,ME2,MS3,ME3 )
2268	USE module_dm
2269	IMPLICIT NONE
2270	INTEGER , INTENT(IN) :: noutbuf
2271	LOGICAL , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2272	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2273	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2274	LOGICAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
2275	! Local
2276	INTEGER :: i,j,k,n , icurs
2277	icurs = 1
2278	DO k = PS3, PE3
2279	DO j = PS2, PE2
2280	DO i = PS1, PE1
2281	outbuf( icurs ) = inbuf( i, j, k )
2282	icurs = icurs + 1
2283	ENDDO
2284	ENDDO
2285	ENDDO
2286	RETURN
2287	END SUBROUTINE just_patch_l
2288
2289
2290	SUBROUTINE patch_2_outbuf_r( inbuf, outbuf, &
2291	DS1,DE1,DS2,DE2,DS3,DE3, &
2292	GPATCH )
2293	USE module_dm
2294	IMPLICIT NONE
2295	REAL , DIMENSION(*) , INTENT(IN) :: inbuf
2296	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2297	REAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2298	! Local
2299	INTEGER :: i,j,k,n , icurs
2300	icurs = 1
2301	DO n = 1, ntasks
2302	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2303	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2304	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2305	outbuf( i, j, k ) = inbuf( icurs )
2306	icurs = icurs + 1
2307	ENDDO
2308	ENDDO
2309	ENDDO
2310	ENDDO
2311
2312	RETURN
2313	END SUBROUTINE patch_2_outbuf_r
2314
2315	SUBROUTINE patch_2_outbuf_i( inbuf, outbuf, &
2316	DS1,DE1,DS2,DE2,DS3,DE3,&
2317	GPATCH )
2318	USE module_dm
2319	IMPLICIT NONE
2320	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
2321	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2322	INTEGER , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2323	! Local
2324	INTEGER :: i,j,k,n , icurs
2325	icurs = 1
2326	DO n = 1, ntasks
2327	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2328	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2329	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2330	outbuf( i, j, k ) = inbuf( icurs )
2331	icurs = icurs + 1
2332	ENDDO
2333	ENDDO
2334	ENDDO
2335	ENDDO
2336	RETURN
2337	END SUBROUTINE patch_2_outbuf_i
2338
2339	SUBROUTINE patch_2_outbuf_d( inbuf, outbuf, &
2340	DS1,DE1,DS2,DE2,DS3,DE3,&
2341	GPATCH )
2342	USE module_dm
2343	IMPLICIT NONE
2344	DOUBLE PRECISION , DIMENSION(*) , INTENT(IN) :: inbuf
2345	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2346	DOUBLE PRECISION , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2347	! Local
2348	INTEGER :: i,j,k,n , icurs
2349	icurs = 1
2350	DO n = 1, ntasks
2351	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2352	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2353	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2354	outbuf( i, j, k ) = inbuf( icurs )
2355	icurs = icurs + 1
2356	ENDDO
2357	ENDDO
2358	ENDDO
2359	ENDDO
2360	RETURN
2361	END SUBROUTINE patch_2_outbuf_d
2362
2363	SUBROUTINE patch_2_outbuf_l( inbuf, outbuf, &
2364	DS1,DE1,DS2,DE2,DS3,DE3,&
2365	GPATCH )
2366	USE module_dm
2367	IMPLICIT NONE
2368	LOGICAL , DIMENSION(*) , INTENT(IN) :: inbuf
2369	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2370	LOGICAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2371	! Local
2372	INTEGER :: i,j,k,n , icurs
2373	icurs = 1
2374	DO n = 1, ntasks
2375	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2376	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2377	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2378	outbuf( i, j, k ) = inbuf( icurs )
2379	icurs = icurs + 1
2380	ENDDO
2381	ENDDO
2382	ENDDO
2383	ENDDO
2384	RETURN
2385	END SUBROUTINE patch_2_outbuf_l
2386
2387	!!!!!!!!!!!!!!!!!!!!!!! GLOBAL TO PATCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2388
2389	SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
2390	DS1,DE1,DS2,DE2,DS3,DE3,&
2391	MS1,ME1,MS2,ME2,MS3,ME3,&
2392	PS1,PE1,PS2,PE2,PS3,PE3 )
2393	IMPLICIT NONE
2394	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2395	MS1,ME1,MS2,ME2,MS3,ME3,&
2396	PS1,PE1,PS2,PE2,PS3,PE3
2397	CHARACTER () stagger,ordering
2398	INTEGER fid,domdesc
2399	REAL globbuf(*)
2400	REAL buf(*)
2401
2402	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,RWORDSIZE,&
2403	DS1,DE1,DS2,DE2,DS3,DE3,&
2404	MS1,ME1,MS2,ME2,MS3,ME3,&
2405	PS1,PE1,PS2,PE2,PS3,PE3 )
2406	RETURN
2407	END SUBROUTINE wrf_global_to_patch_real
2408
2409	SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,stagger,ordering,&
2410	DS1,DE1,DS2,DE2,DS3,DE3,&
2411	MS1,ME1,MS2,ME2,MS3,ME3,&
2412	PS1,PE1,PS2,PE2,PS3,PE3 )
2413	IMPLICIT NONE
2414	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2415	MS1,ME1,MS2,ME2,MS3,ME3,&
2416	PS1,PE1,PS2,PE2,PS3,PE3
2417	CHARACTER () stagger,ordering
2418	INTEGER fid,domdesc
2419	! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
2420	! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
2421	! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
2422	! since we were not indexing the globbuf and Field arrays it does not matter
2423	REAL globbuf(*)
2424	REAL buf(*)
2425
2426	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,DWORDSIZE,&
2427	DS1,DE1,DS2,DE2,DS3,DE3,&
2428	MS1,ME1,MS2,ME2,MS3,ME3,&
2429	PS1,PE1,PS2,PE2,PS3,PE3 )
2430	RETURN
2431	END SUBROUTINE wrf_global_to_patch_double
2432
2433
2434	SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,stagger,ordering,&
2435	DS1,DE1,DS2,DE2,DS3,DE3,&
2436	MS1,ME1,MS2,ME2,MS3,ME3,&
2437	PS1,PE1,PS2,PE2,PS3,PE3 )
2438	IMPLICIT NONE
2439	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2440	MS1,ME1,MS2,ME2,MS3,ME3,&
2441	PS1,PE1,PS2,PE2,PS3,PE3
2442	CHARACTER () stagger,ordering
2443	INTEGER fid,domdesc
2444	INTEGER globbuf(*)
2445	INTEGER buf(*)
2446
2447	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,IWORDSIZE,&
2448	DS1,DE1,DS2,DE2,DS3,DE3,&
2449	MS1,ME1,MS2,ME2,MS3,ME3,&
2450	PS1,PE1,PS2,PE2,PS3,PE3 )
2451	RETURN
2452	END SUBROUTINE wrf_global_to_patch_integer
2453
2454	SUBROUTINE wrf_global_to_patch_logical (globbuf,buf,domdesc,stagger,ordering,&
2455	DS1,DE1,DS2,DE2,DS3,DE3,&
2456	MS1,ME1,MS2,ME2,MS3,ME3,&
2457	PS1,PE1,PS2,PE2,PS3,PE3 )
2458	IMPLICIT NONE
2459	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2460	MS1,ME1,MS2,ME2,MS3,ME3,&
2461	PS1,PE1,PS2,PE2,PS3,PE3
2462	CHARACTER () stagger,ordering
2463	INTEGER fid,domdesc
2464	LOGICAL globbuf(*)
2465	LOGICAL buf(*)
2466
2467	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,LWORDSIZE,&
2468	DS1,DE1,DS2,DE2,DS3,DE3,&
2469	MS1,ME1,MS2,ME2,MS3,ME3,&
2470	PS1,PE1,PS2,PE2,PS3,PE3 )
2471	RETURN
2472	END SUBROUTINE wrf_global_to_patch_logical
2473
2474	SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,typesize,&
2475	DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2476	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2477	PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
2478	USE module_dm
2479	USE module_driver_constants
2480	IMPLICIT NONE
2481	INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2482	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2483	PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
2484	CHARACTER () stagger,ordering
2485	INTEGER domdesc,typesize,ierr
2486	REAL globbuf(*)
2487	REAL buf(*)
2488	#ifndef STUBMPI
2489	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
2490	MS1,ME1,MS2,ME2,MS3,ME3,&
2491	PS1,PE1,PS2,PE2,PS3,PE3
2492	LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
2493
2494	INTEGER i,j,k,ord,ord2d,ndim
2495	INTEGER Patch(3,2), Gpatch(3,2,ntasks)
2496	REAL, ALLOCATABLE :: tmpbuf( : )
2497	REAL locbuf( (PE1a-PS1a+1)(PE2a-PS2a+1)(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
2498
2499	DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
2500	MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
2501	PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
2502
2503	SELECT CASE ( TRIM(ordering) )
2504	CASE ( 'xy', 'yx' )
2505	ndim = 2
2506	CASE DEFAULT
2507	ndim = 3 ! where appropriate
2508	END SELECT
2509
2510	SELECT CASE ( TRIM(ordering) )
2511	CASE ( 'xyz','xy' )
2512	! the non-staggered variables come in at one-less than
2513	! domain dimensions, but code wants full domain spec, so
2514	! adjust if not staggered
2515	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2516	IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
2517	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2518	CASE ( 'yxz','yx' )
2519	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2520	IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
2521	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2522	CASE ( 'zxy' )
2523	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2524	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2525	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
2526	CASE ( 'xzy' )
2527	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2528	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2529	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
2530	CASE DEFAULT
2531	END SELECT
2532
2533	! moved to here to be after the potential recalculations of D dims
2534	IF ( wrf_dm_on_monitor() ) THEN
2535	ALLOCATE ( tmpbuf ( (DE1-DS1+1)(DE2-DS2+1)(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
2536	ELSE
2537	ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
2538	ENDIF
2539	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_global_to_patch_generic')
2540
2541	Patch(1,1) = ps1 ; Patch(1,2) = pe1 ! use patch dims
2542	Patch(2,1) = ps2 ; Patch(2,2) = pe2
2543	Patch(3,1) = ps3 ; Patch(3,2) = pe3
2544
2545	! defined in external/io_quilt
2546	CALL collect_on_comm0 ( local_communicator , IWORDSIZE , &
2547	Patch , 6 , &
2548	GPatch , 6*ntasks )
2549	ndim = len(TRIM(ordering))
2550
2551	IF ( wrf_dm_on_monitor() .AND. ndim .GE. 2 ) THEN
2552	IF ( typesize .EQ. RWORDSIZE ) THEN
2553	CALL outbuf_2_patch_r ( globbuf , tmpbuf FRSTELEM , &
2554	DS1, DE1, DS2, DE2, DS3, DE3 , &
2555	MS1, ME1, MS2, ME2, MS3, ME3 , &
2556	GPATCH )
2557	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2558	CALL outbuf_2_patch_i ( globbuf , tmpbuf FRSTELEM , &
2559	DS1, DE1, DS2, DE2, DS3, DE3 , &
2560	GPATCH )
2561	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2562	CALL outbuf_2_patch_d ( globbuf , tmpbuf FRSTELEM , &
2563	DS1, DE1, DS2, DE2, DS3, DE3 , &
2564	GPATCH )
2565	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2566	CALL outbuf_2_patch_l ( globbuf , tmpbuf FRSTELEM , &
2567	DS1, DE1, DS2, DE2, DS3, DE3 , &
2568	GPATCH )
2569	ENDIF
2570	ENDIF
2571
2572	CALL dist_on_comm0 ( local_communicator , typesize , &
2573	tmpbuf FRSTELEM , (de1-ds1+1)(de2-ds2+1)(de3-ds3+1) , &
2574	locbuf , (pe1-ps1+1)(pe2-ps2+1)(pe3-ps3+1) )
2575
2576	IF ( typesize .EQ. RWORDSIZE ) THEN
2577	CALL all_sub_r ( locbuf , buf , &
2578	PS1, PE1, PS2, PE2, PS3, PE3 , &
2579	MS1, ME1, MS2, ME2, MS3, ME3 )
2580
2581	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2582	CALL all_sub_i ( locbuf , buf , &
2583	PS1, PE1, PS2, PE2, PS3, PE3 , &
2584	MS1, ME1, MS2, ME2, MS3, ME3 )
2585	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2586	CALL all_sub_d ( locbuf , buf , &
2587	PS1, PE1, PS2, PE2, PS3, PE3 , &
2588	MS1, ME1, MS2, ME2, MS3, ME3 )
2589	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2590	CALL all_sub_l ( locbuf , buf , &
2591	PS1, PE1, PS2, PE2, PS3, PE3 , &
2592	MS1, ME1, MS2, ME2, MS3, ME3 )
2593	ENDIF
2594
2595
2596	DEALLOCATE ( tmpbuf )
2597	#endif
2598	RETURN
2599	END SUBROUTINE wrf_global_to_patch_generic
2600
2601	SUBROUTINE all_sub_i ( inbuf , outbuf, &
2602	PS1,PE1,PS2,PE2,PS3,PE3, &
2603	MS1,ME1,MS2,ME2,MS3,ME3 )
2604	USE module_dm
2605	IMPLICIT NONE
2606	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
2607	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2608	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2609	INTEGER , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2610	! Local
2611	INTEGER :: i,j,k,n , icurs
2612	icurs = 1
2613	DO k = PS3, PE3
2614	DO j = PS2, PE2
2615	DO i = PS1, PE1
2616	outbuf( i, j, k ) = inbuf ( icurs )
2617	icurs = icurs + 1
2618	ENDDO
2619	ENDDO
2620	ENDDO
2621	RETURN
2622	END SUBROUTINE all_sub_i
2623
2624	SUBROUTINE all_sub_r ( inbuf , outbuf, &
2625	PS1,PE1,PS2,PE2,PS3,PE3, &
2626	MS1,ME1,MS2,ME2,MS3,ME3 )
2627	USE module_dm
2628	IMPLICIT NONE
2629	REAL , DIMENSION(*) , INTENT(IN) :: inbuf
2630	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2631	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2632	REAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2633	! Local
2634	INTEGER :: i,j,k,n , icurs
2635	icurs = 1
2636	DO k = PS3, PE3
2637	DO j = PS2, PE2
2638	DO i = PS1, PE1
2639	outbuf( i, j, k ) = inbuf ( icurs )
2640	icurs = icurs + 1
2641	ENDDO
2642	ENDDO
2643	ENDDO
2644
2645	RETURN
2646	END SUBROUTINE all_sub_r
2647
2648	SUBROUTINE all_sub_d ( inbuf , outbuf, &
2649	PS1,PE1,PS2,PE2,PS3,PE3, &
2650	MS1,ME1,MS2,ME2,MS3,ME3 )
2651	USE module_dm
2652	IMPLICIT NONE
2653	DOUBLE PRECISION , DIMENSION(*) , INTENT(IN) :: inbuf
2654	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2655	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2656	DOUBLE PRECISION , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2657	! Local
2658	INTEGER :: i,j,k,n , icurs
2659	icurs = 1
2660	DO k = PS3, PE3
2661	DO j = PS2, PE2
2662	DO i = PS1, PE1
2663	outbuf( i, j, k ) = inbuf ( icurs )
2664	icurs = icurs + 1
2665	ENDDO
2666	ENDDO
2667	ENDDO
2668	RETURN
2669	END SUBROUTINE all_sub_d
2670
2671	SUBROUTINE all_sub_l ( inbuf , outbuf, &
2672	PS1,PE1,PS2,PE2,PS3,PE3, &
2673	MS1,ME1,MS2,ME2,MS3,ME3 )
2674	USE module_dm
2675	IMPLICIT NONE
2676	LOGICAL , DIMENSION(*) , INTENT(IN) :: inbuf
2677	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2678	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2679	LOGICAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2680	! Local
2681	INTEGER :: i,j,k,n , icurs
2682	icurs = 1
2683	DO k = PS3, PE3
2684	DO j = PS2, PE2
2685	DO i = PS1, PE1
2686	outbuf( i, j, k ) = inbuf ( icurs )
2687	icurs = icurs + 1
2688	ENDDO
2689	ENDDO
2690	ENDDO
2691	RETURN
2692	END SUBROUTINE all_sub_l
2693
2694	SUBROUTINE outbuf_2_patch_r( inbuf, outbuf, &
2695	DS1,DE1,DS2,DE2,DS3,DE3, &
2696	MS1, ME1, MS2, ME2, MS3, ME3 , &
2697	GPATCH )
2698	USE module_dm
2699	IMPLICIT NONE
2700	REAL , DIMENSION(*) , INTENT(OUT) :: outbuf
2701	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2702	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2703	REAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2704	! Local
2705	INTEGER :: i,j,k,n , icurs
2706
2707	icurs = 1
2708	DO n = 1, ntasks
2709	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2710	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2711	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2712	outbuf( icurs ) = inbuf( i,j,k )
2713	icurs = icurs + 1
2714	ENDDO
2715	ENDDO
2716	ENDDO
2717	ENDDO
2718	RETURN
2719	END SUBROUTINE outbuf_2_patch_r
2720
2721	SUBROUTINE outbuf_2_patch_i( inbuf, outbuf, &
2722	DS1,DE1,DS2,DE2,DS3,DE3,&
2723	GPATCH )
2724	USE module_dm
2725	IMPLICIT NONE
2726	INTEGER , DIMENSION(*) , INTENT(OUT) :: outbuf
2727	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2728	INTEGER , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2729	! Local
2730	INTEGER :: i,j,k,n , icurs
2731	icurs = 1
2732	DO n = 1, ntasks
2733	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2734	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2735	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2736	outbuf( icurs ) = inbuf( i,j,k )
2737	icurs = icurs + 1
2738	ENDDO
2739	ENDDO
2740	ENDDO
2741	ENDDO
2742	RETURN
2743	END SUBROUTINE outbuf_2_patch_i
2744
2745	SUBROUTINE outbuf_2_patch_d( inbuf, outbuf, &
2746	DS1,DE1,DS2,DE2,DS3,DE3,&
2747	GPATCH )
2748	USE module_dm
2749	IMPLICIT NONE
2750	DOUBLE PRECISION , DIMENSION(*) , INTENT(OUT) :: outbuf
2751	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2752	DOUBLE PRECISION , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2753	! Local
2754	INTEGER :: i,j,k,n , icurs
2755	icurs = 1
2756	DO n = 1, ntasks
2757	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2758	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2759	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2760	outbuf( icurs ) = inbuf( i,j,k )
2761	icurs = icurs + 1
2762	ENDDO
2763	ENDDO
2764	ENDDO
2765	ENDDO
2766	RETURN
2767	END SUBROUTINE outbuf_2_patch_d
2768
2769	SUBROUTINE outbuf_2_patch_l( inbuf, outbuf, &
2770	DS1,DE1,DS2,DE2,DS3,DE3,&
2771	GPATCH )
2772	USE module_dm
2773	IMPLICIT NONE
2774	LOGICAL , DIMENSION(*) , INTENT(OUT) :: outbuf
2775	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2776	LOGICAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2777	! Local
2778	INTEGER :: i,j,k,n , icurs
2779	icurs = 1
2780	DO n = 1, ntasks
2781	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2782	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2783	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2784	outbuf( icurs ) = inbuf( i,j,k )
2785	icurs = icurs + 1
2786	ENDDO
2787	ENDDO
2788	ENDDO
2789	ENDDO
2790	RETURN
2791	END SUBROUTINE outbuf_2_patch_l
2792
2793
2794
2795	!------------------------------------------------------------------
2796
2797	#if ( EM_CORE == 1 )
2798
2799	!------------------------------------------------------------------
2800
2801	SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags &
2802	!
2803	#include "dummy_new_args.inc"
2804	!
2805	)
2806	USE module_state_description
2807	USE module_domain, ONLY : domain, get_ijk_from_grid
2808	USE module_configure, ONLY : grid_config_rec_type
2809	USE module_dm
2810	IMPLICIT NONE
2811	!
2812	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2813	TYPE(domain), POINTER :: ngrid
2814	#include <dummy_new_decl.inc>
2815	INTEGER nlev, msize
2816	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2817	TYPE (grid_config_rec_type) :: config_flags
2818	REAL xv(500)
2819	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2820	cims, cime, cjms, cjme, ckms, ckme, &
2821	cips, cipe, cjps, cjpe, ckps, ckpe
2822	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2823	nims, nime, njms, njme, nkms, nkme, &
2824	nips, nipe, njps, njpe, nkps, nkpe
2825	INTEGER :: ids, ide, jds, jde, kds, kde, &
2826	ims, ime, jms, jme, kms, kme, &
2827	ips, ipe, jps, jpe, kps, kpe
2828
2829	CALL get_ijk_from_grid ( grid , &
2830	cids, cide, cjds, cjde, ckds, ckde, &
2831	cims, cime, cjms, cjme, ckms, ckme, &
2832	cips, cipe, cjps, cjpe, ckps, ckpe )
2833	CALL get_ijk_from_grid ( ngrid , &
2834	nids, nide, njds, njde, nkds, nkde, &
2835	nims, nime, njms, njme, nkms, nkme, &
2836	nips, nipe, njps, njpe, nkps, nkpe )
2837
2838	nlev = ckde - ckds + 1
2839
2840	#include "nest_interpdown_unpack.inc"
2841
2842	CALL get_ijk_from_grid ( grid , &
2843	ids, ide, jds, jde, kds, kde, &
2844	ims, ime, jms, jme, kms, kme, &
2845	ips, ipe, jps, jpe, kps, kpe )
2846
2847	#include "HALO_FORCE_DOWN.inc"
2848
2849	! code here to interpolate the data into the nested domain
2850	# include "nest_forcedown_interp.inc"
2851
2852	RETURN
2853	END SUBROUTINE force_domain_em_part2
2854
2855	!------------------------------------------------------------------
2856
2857	SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags &
2858	!
2859	#include "dummy_new_args.inc"
2860	!
2861	)
2862	USE module_state_description
2863	USE module_domain, ONLY : domain, get_ijk_from_grid
2864	USE module_configure, ONLY : grid_config_rec_type
2865	USE module_dm
2866	USE module_timing
2867	IMPLICIT NONE
2868	!
2869	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2870	TYPE(domain), POINTER :: intermediate_grid
2871	TYPE(domain), POINTER :: ngrid
2872	#include <dummy_new_decl.inc>
2873	INTEGER nlev, msize
2874	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2875	INTEGER iparstrt,jparstrt,sw
2876	TYPE (grid_config_rec_type) :: config_flags
2877	REAL xv(500)
2878	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2879	cims, cime, cjms, cjme, ckms, ckme, &
2880	cips, cipe, cjps, cjpe, ckps, ckpe
2881	INTEGER :: iids, iide, ijds, ijde, ikds, ikde, &
2882	iims, iime, ijms, ijme, ikms, ikme, &
2883	iips, iipe, ijps, ijpe, ikps, ikpe
2884	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2885	nims, nime, njms, njme, nkms, nkme, &
2886	nips, nipe, njps, njpe, nkps, nkpe
2887
2888	INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
2889	INTEGER thisdomain_max_halo_width
2890	INTEGER local_comm, myproc, nproc
2891
2892	CALL wrf_get_dm_communicator ( local_comm )
2893	CALL wrf_get_myproc( myproc )
2894	CALL wrf_get_nproc( nproc )
2895
2896	CALL get_ijk_from_grid ( grid , &
2897	cids, cide, cjds, cjde, ckds, ckde, &
2898	cims, cime, cjms, cjme, ckms, ckme, &
2899	cips, cipe, cjps, cjpe, ckps, ckpe )
2900	CALL get_ijk_from_grid ( intermediate_grid , &
2901	iids, iide, ijds, ijde, ikds, ikde, &
2902	iims, iime, ijms, ijme, ikms, ikme, &
2903	iips, iipe, ijps, ijpe, ikps, ikpe )
2904	CALL get_ijk_from_grid ( ngrid , &
2905	nids, nide, njds, njde, nkds, nkde, &
2906	nims, nime, njms, njme, nkms, nkme, &
2907	nips, nipe, njps, njpe, nkps, nkpe )
2908
2909	CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
2910	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
2911	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
2912	CALL nl_get_shw ( intermediate_grid%id, sw )
2913	icoord = iparstrt - sw
2914	jcoord = jparstrt - sw
2915	idim_cd = iide - iids + 1
2916	jdim_cd = ijde - ijds + 1
2917
2918	nlev = ckde - ckds + 1
2919
2920	! get max_halo_width for parent. It may be smaller if it is moad
2921	CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
2922
2923	#include "nest_interpdown_pack.inc"
2924
2925	CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
2926
2927	RETURN
2928	END SUBROUTINE interp_domain_em_part1
2929
2930	!------------------------------------------------------------------
2931
2932	SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags &
2933	!
2934	#include "dummy_new_args.inc"
2935	!
2936	)
2937	USE module_state_description
2938	USE module_domain, ONLY : domain, get_ijk_from_grid
2939	USE module_configure, ONLY : grid_config_rec_type
2940	USE module_dm
2941	IMPLICIT NONE
2942	!
2943	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2944	TYPE(domain), POINTER :: ngrid
2945	#include <dummy_new_decl.inc>
2946	INTEGER nlev, msize
2947	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2948	TYPE (grid_config_rec_type) :: config_flags
2949	REAL xv(500)
2950	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2951	cims, cime, cjms, cjme, ckms, ckme, &
2952	cips, cipe, cjps, cjpe, ckps, ckpe
2953	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2954	nims, nime, njms, njme, nkms, nkme, &
2955	nips, nipe, njps, njpe, nkps, nkpe
2956	INTEGER :: ids, ide, jds, jde, kds, kde, &
2957	ims, ime, jms, jme, kms, kme, &
2958	ips, ipe, jps, jpe, kps, kpe
2959	INTEGER myproc
2960	INTEGER ierr
2961	INTEGER thisdomain_max_halo_width
2962
2963	CALL get_ijk_from_grid ( grid , &
2964	cids, cide, cjds, cjde, ckds, ckde, &
2965	cims, cime, cjms, cjme, ckms, ckme, &
2966	cips, cipe, cjps, cjpe, ckps, ckpe )
2967	CALL get_ijk_from_grid ( ngrid , &
2968	nids, nide, njds, njde, nkds, nkde, &
2969	nims, nime, njms, njme, nkms, nkme, &
2970	nips, nipe, njps, njpe, nkps, nkpe )
2971
2972	nlev = ckde - ckds + 1
2973
2974	CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
2975
2976	#include "nest_interpdown_unpack.inc"
2977
2978	CALL get_ijk_from_grid ( grid , &
2979	ids, ide, jds, jde, kds, kde, &
2980	ims, ime, jms, jme, kms, kme, &
2981	ips, ipe, jps, jpe, kps, kpe )
2982
2983	#include "HALO_INTERP_DOWN.inc"
2984
2985	# include "nest_interpdown_interp.inc"
2986
2987	RETURN
2988	END SUBROUTINE interp_domain_em_part2
2989
2990	!------------------------------------------------------------------
2991
2992	SUBROUTINE feedback_nest_prep ( grid, config_flags &
2993	!
2994	#include "dummy_new_args.inc"
2995	!
2996	)
2997	USE module_state_description
2998	USE module_domain, ONLY : domain, get_ijk_from_grid
2999	USE module_configure, ONLY : grid_config_rec_type
3000	USE module_dm
3001	IMPLICIT NONE
3002	!
3003	TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid")
3004	TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
3005	! soil temp, moisture, etc., has vertical dim
3006	! of soil categories
3007	#include <dummy_new_decl.inc>
3008
3009	INTEGER :: ids, ide, jds, jde, kds, kde, &
3010	ims, ime, jms, jme, kms, kme, &
3011	ips, ipe, jps, jpe, kps, kpe
3012
3013	INTEGER :: idum1, idum2
3014
3015
3016	CALL get_ijk_from_grid ( grid , &
3017	ids, ide, jds, jde, kds, kde, &
3018	ims, ime, jms, jme, kms, kme, &
3019	ips, ipe, jps, jpe, kps, kpe )
3020
3021	#ifdef DM_PARALLEL
3022	#include "HALO_INTERP_UP.inc"
3023	#endif
3024
3025	END SUBROUTINE feedback_nest_prep
3026
3027	!------------------------------------------------------------------
3028
3029	SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags &
3030	!
3031	#include "dummy_new_args.inc"
3032	!
3033	)
3034	USE module_state_description
3035	USE module_domain, ONLY : domain, get_ijk_from_grid
3036	USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
3037	USE module_dm
3038	IMPLICIT NONE
3039	!
3040	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3041	TYPE(domain), POINTER :: ngrid
3042	#include <dummy_new_decl.inc>
3043	INTEGER nlev, msize
3044	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3045	TYPE(domain), POINTER :: xgrid
3046	TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
3047	REAL xv(500)
3048	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3049	cims, cime, cjms, cjme, ckms, ckme, &
3050	cips, cipe, cjps, cjpe, ckps, ckpe
3051	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3052	nims, nime, njms, njme, nkms, nkme, &
3053	nips, nipe, njps, njpe, nkps, nkpe
3054	INTEGER local_comm, myproc, nproc, idum1, idum2
3055	INTEGER thisdomain_max_halo_width
3056
3057	INTERFACE
3058	SUBROUTINE feedback_nest_prep ( grid, config_flags &
3059	!
3060	#include "dummy_new_args.inc"
3061	!
3062	)
3063	USE module_state_description
3064	USE module_domain, ONLY : domain
3065	USE module_configure, ONLY : grid_config_rec_type
3066	!
3067	TYPE (grid_config_rec_type) :: config_flags
3068	TYPE(domain), TARGET :: grid
3069	#include <dummy_new_decl.inc>
3070	END SUBROUTINE feedback_nest_prep
3071	END INTERFACE
3072	!
3073
3074	CALL wrf_get_dm_communicator ( local_comm )
3075	CALL wrf_get_myproc( myproc )
3076	CALL wrf_get_nproc( nproc )
3077
3078	!
3079	! intermediate grid
3080	CALL get_ijk_from_grid ( grid , &
3081	cids, cide, cjds, cjde, ckds, ckde, &
3082	cims, cime, cjms, cjme, ckms, ckme, &
3083	cips, cipe, cjps, cjpe, ckps, ckpe )
3084	! nest grid
3085	CALL get_ijk_from_grid ( ngrid , &
3086	nids, nide, njds, njde, nkds, nkde, &
3087	nims, nime, njms, njme, nkms, nkme, &
3088	nips, nipe, njps, njpe, nkps, nkpe )
3089
3090	nlev = ckde - ckds + 1
3091
3092	ips_save = ngrid%i_parent_start ! used in feedback_domain_em_part2 below
3093	jps_save = ngrid%j_parent_start
3094	ipe_save = ngrid%i_parent_start + (nide-nids+1) / ngrid%parent_grid_ratio - 1
3095	jpe_save = ngrid%j_parent_start + (njde-njds+1) / ngrid%parent_grid_ratio - 1
3096
3097	! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
3098	! in a separate routine because the HALOs need the data to be dereference from the
3099	! grid data structure and, in this routine, the dereferenced fields are related to
3100	! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
3101	! domain, switch grid to point to ngrid, invoke feedback_nest_prep, then restore grid
3102	! to point to intermediate domain.
3103
3104	CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
3105	CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
3106	xgrid => grid
3107	grid => ngrid
3108
3109	CALL feedback_nest_prep ( grid, nconfig_flags &
3110	!
3111	#include "actual_new_args.inc"
3112	!
3113	)
3114
3115	! put things back so grid is intermediate grid
3116
3117	grid => xgrid
3118	CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
3119
3120	! "interp" (basically copy) ngrid onto intermediate grid
3121
3122	#include "nest_feedbackup_interp.inc"
3123
3124	RETURN
3125	END SUBROUTINE feedback_domain_em_part1
3126
3127	!------------------------------------------------------------------
3128
3129	SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags &
3130	!
3131	#include "dummy_new_args.inc"
3132	!
3133	)
3134	USE module_state_description
3135	USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid
3136	USE module_configure, ONLY : grid_config_rec_type, model_config_rec
3137	USE module_dm
3138	USE module_utility
3139	IMPLICIT NONE
3140
3141	!
3142	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3143	TYPE(domain), POINTER :: intermediate_grid
3144	TYPE(domain), POINTER :: ngrid
3145
3146	#include <dummy_new_decl.inc>
3147	INTEGER nlev, msize
3148	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3149	TYPE (grid_config_rec_type) :: config_flags
3150	REAL xv(500)
3151	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3152	cims, cime, cjms, cjme, ckms, ckme, &
3153	cips, cipe, cjps, cjpe, ckps, ckpe
3154	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3155	nims, nime, njms, njme, nkms, nkme, &
3156	nips, nipe, njps, njpe, nkps, nkpe
3157	INTEGER :: ids, ide, jds, jde, kds, kde, &
3158	ims, ime, jms, jme, kms, kme, &
3159	ips, ipe, jps, jpe, kps, kpe
3160	INTEGER icoord, jcoord, idim_cd, jdim_cd
3161	INTEGER local_comm, myproc, nproc
3162	INTEGER iparstrt, jparstrt, sw, thisdomain_max_halo_width
3163	REAL nest_influence
3164
3165	character*256 :: timestr
3166	integer ierr
3167
3168	LOGICAL, EXTERNAL :: cd_feedback_mask
3169
3170	! On entry to this routine,
3171	! "grid" refers to the parent domain
3172	! "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
3173	! "ngrid" refers to the nest, which is only needed for smoothing on the parent because
3174	! the nest feedback data has already been transferred during em_nest_feedbackup_interp
3175	! in part1, above.
3176	! The way these settings c and n dimensions are set, below, looks backwards but from the point
3177	! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
3178	! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
3179	! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
3180	! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
3181	! sign that says "DIP" than fix the dip, at this point it was easier just to write this comment. JM
3182	!
3183	nest_influence = 1.
3184
3185	CALL domain_clock_get( grid, current_timestr=timestr )
3186
3187	CALL get_ijk_from_grid ( intermediate_grid , &
3188	cids, cide, cjds, cjde, ckds, ckde, &
3189	cims, cime, cjms, cjme, ckms, ckme, &
3190	cips, cipe, cjps, cjpe, ckps, ckpe )
3191	CALL get_ijk_from_grid ( grid , &
3192	nids, nide, njds, njde, nkds, nkde, &
3193	nims, nime, njms, njme, nkms, nkme, &
3194	nips, nipe, njps, njpe, nkps, nkpe )
3195
3196	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
3197	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
3198	CALL nl_get_shw ( intermediate_grid%id, sw )
3199	icoord = iparstrt - sw
3200	jcoord = jparstrt - sw
3201	idim_cd = cide - cids + 1
3202	jdim_cd = cjde - cjds + 1
3203
3204	nlev = ckde - ckds + 1
3205
3206	CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
3207
3208	#include "nest_feedbackup_pack.inc"
3209
3210	CALL wrf_get_dm_communicator ( local_comm )
3211	CALL wrf_get_myproc( myproc )
3212	CALL wrf_get_nproc( nproc )
3213
3214	CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
3215
3216	#define NEST_INFLUENCE(A,B) A = B
3217	#include "nest_feedbackup_unpack.inc"
3218
3219	! smooth coarse grid
3220	CALL get_ijk_from_grid ( ngrid, &
3221	nids, nide, njds, njde, nkds, nkde, &
3222	nims, nime, njms, njme, nkms, nkme, &
3223	nips, nipe, njps, njpe, nkps, nkpe )
3224	CALL get_ijk_from_grid ( grid , &
3225	ids, ide, jds, jde, kds, kde, &
3226	ims, ime, jms, jme, kms, kme, &
3227	ips, ipe, jps, jpe, kps, kpe )
3228
3229	#include "HALO_INTERP_UP.inc"
3230
3231	CALL get_ijk_from_grid ( grid , &
3232	cids, cide, cjds, cjde, ckds, ckde, &
3233	cims, cime, cjms, cjme, ckms, ckme, &
3234	cips, cipe, cjps, cjpe, ckps, ckpe )
3235
3236	#include "nest_feedbackup_smooth.inc"
3237
3238	RETURN
3239	END SUBROUTINE feedback_domain_em_part2
3240	#endif
3241
3242	#if ( NMM_CORE == 1 && NMM_NEST == 1 )
3243	!==============================================================================
3244	! NMM nesting infrastructure extended from EM core. This is gopal's doing.
3245	!==============================================================================
3246
3247	SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags &
3248	!
3249	#include "dummy_args.inc"
3250	!
3251	)
3252	USE module_state_description
3253	USE module_domain, ONLY : domain, get_ijk_from_grid
3254	USE module_configure, ONLY : grid_config_rec_type
3255	USE module_dm
3256	USE module_timing
3257	IMPLICIT NONE
3258	!
3259	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3260	TYPE(domain), POINTER :: intermediate_grid
3261	TYPE(domain), POINTER :: ngrid
3262	#include <dummy_decl.inc>
3263	INTEGER nlev, msize
3264	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3265	INTEGER iparstrt,jparstrt,sw
3266	TYPE (grid_config_rec_type) :: config_flags
3267	REAL xv(500)
3268	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3269	cims, cime, cjms, cjme, ckms, ckme, &
3270	cips, cipe, cjps, cjpe, ckps, ckpe
3271	INTEGER :: iids, iide, ijds, ijde, ikds, ikde, &
3272	iims, iime, ijms, ijme, ikms, ikme, &
3273	iips, iipe, ijps, ijpe, ikps, ikpe
3274	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3275	nims, nime, njms, njme, nkms, nkme, &
3276	nips, nipe, njps, njpe, nkps, nkpe
3277
3278	INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
3279	INTEGER local_comm, myproc, nproc
3280	INTEGER thisdomain_max_halo_width
3281
3282	CALL wrf_get_dm_communicator ( local_comm )
3283	CALL wrf_get_myproc( myproc )
3284	CALL wrf_get_nproc( nproc )
3285
3286	#define COPY_IN
3287	#include <scalar_derefs.inc>
3288
3289	CALL get_ijk_from_grid ( grid , &
3290	cids, cide, cjds, cjde, ckds, ckde, &
3291	cims, cime, cjms, cjme, ckms, ckme, &
3292	cips, cipe, cjps, cjpe, ckps, ckpe )
3293	CALL get_ijk_from_grid ( intermediate_grid , &
3294	iids, iide, ijds, ijde, ikds, ikde, &
3295	iims, iime, ijms, ijme, ikms, ikme, &
3296	iips, iipe, ijps, ijpe, ikps, ikpe )
3297	CALL get_ijk_from_grid ( ngrid , &
3298	nids, nide, njds, njde, nkds, nkde, &
3299	nims, nime, njms, njme, nkms, nkme, &
3300	nips, nipe, njps, njpe, nkps, nkpe )
3301
3302	CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
3303	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
3304	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
3305	CALL nl_get_shw ( intermediate_grid%id, sw )
3306	icoord = iparstrt - sw
3307	jcoord = jparstrt - sw
3308	idim_cd = iide - iids + 1
3309	jdim_cd = ijde - ijds + 1
3310
3311	nlev = ckde - ckds + 1
3312
3313	CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
3314	#include "nest_interpdown_pack.inc"
3315
3316	CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
3317
3318	#define COPY_OUT
3319	#include <scalar_derefs.inc>
3320	RETURN
3321	END SUBROUTINE interp_domain_nmm_part1
3322
3323	!------------------------------------------------------------------
3324
3325	SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags &
3326	!
3327	#include "dummy_args.inc"
3328	!
3329	)
3330	USE module_state_description
3331	USE module_domain, ONLY : domain, get_ijk_from_grid
3332	USE module_configure, ONLY : grid_config_rec_type
3333	USE module_dm
3334	IMPLICIT NONE
3335	!
3336	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3337	TYPE(domain), POINTER :: ngrid
3338	#include <dummy_decl.inc>
3339	INTEGER nlev, msize
3340	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3341	TYPE (grid_config_rec_type) :: config_flags
3342	REAL xv(500)
3343	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3344	cims, cime, cjms, cjme, ckms, ckme, &
3345	cips, cipe, cjps, cjpe, ckps, ckpe
3346	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3347	nims, nime, njms, njme, nkms, nkme, &
3348	nips, nipe, njps, njpe, nkps, nkpe
3349	INTEGER :: ids, ide, jds, jde, kds, kde, &
3350	ims, ime, jms, jme, kms, kme, &
3351	ips, ipe, jps, jpe, kps, kpe
3352	INTEGER myproc
3353	INTEGER ierr
3354
3355	#ifdef DEREF_KLUDGE
3356	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3357	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
3358	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3359	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3360	#endif
3361	#include "deref_kludge.h"
3362
3363	#define COPY_IN
3364	#include <scalar_derefs.inc>
3365	CALL get_ijk_from_grid ( grid , &
3366	cids, cide, cjds, cjde, ckds, ckde, &
3367	cims, cime, cjms, cjme, ckms, ckme, &
3368	cips, cipe, cjps, cjpe, ckps, ckpe )
3369	CALL get_ijk_from_grid ( ngrid , &
3370	nids, nide, njds, njde, nkds, nkde, &
3371	nims, nime, njms, njme, nkms, nkme, &
3372	nips, nipe, njps, njpe, nkps, nkpe )
3373
3374	nlev = ckde - ckds + 1
3375
3376	#include "nest_interpdown_unpack.inc"
3377
3378	CALL get_ijk_from_grid ( grid , &
3379	ids, ide, jds, jde, kds, kde, &
3380	ims, ime, jms, jme, kms, kme, &
3381	ips, ipe, jps, jpe, kps, kpe )
3382
3383	#include "HALO_NMM_INTERP_DOWN1.inc"
3384
3385	#include "nest_interpdown_interp.inc"
3386
3387	#define COPY_OUT
3388	#include <scalar_derefs.inc>
3389
3390	RETURN
3391	END SUBROUTINE interp_domain_nmm_part2
3392
3393	!------------------------------------------------------------------
3394
3395	SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags &
3396	!
3397	#include "dummy_args.inc"
3398	!
3399	)
3400	USE module_state_description
3401	USE module_domain, ONLY : domain, get_ijk_from_grid
3402	USE module_configure, ONLY : grid_config_rec_type
3403	USE module_dm
3404	USE module_timing
3405	!
3406	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3407	TYPE(domain), POINTER :: intermediate_grid
3408	#include <dummy_decl.inc>
3409	INTEGER nlev, msize
3410	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3411	TYPE (grid_config_rec_type) :: config_flags
3412	REAL xv(500)
3413	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3414	cims, cime, cjms, cjme, ckms, ckme, &
3415	cips, cipe, cjps, cjpe, ckps, ckpe
3416	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3417	nims, nime, njms, njme, nkms, nkme, &
3418	nips, nipe, njps, njpe, nkps, nkpe
3419	#define COPY_IN
3420	#include <scalar_derefs.inc>
3421	!
3422	CALL get_ijk_from_grid ( grid , &
3423	cids, cide, cjds, cjde, ckds, ckde, &
3424	cims, cime, cjms, cjme, ckms, ckme, &
3425	cips, cipe, cjps, cjpe, ckps, ckpe )
3426
3427	CALL get_ijk_from_grid ( intermediate_grid , &
3428	nids, nide, njds, njde, nkds, nkde, &
3429	nims, nime, njms, njme, nkms, nkme, &
3430	nips, nipe, njps, njpe, nkps, nkpe )
3431
3432	nlev = ckde - ckds + 1
3433
3434	#include "nest_forcedown_pack.inc"
3435
3436	! WRITE(0,*)'I have completed PACKING of BCs data successfully'
3437
3438	#define COPY_OUT
3439	#include <scalar_derefs.inc>
3440	RETURN
3441	END SUBROUTINE force_domain_nmm_part1
3442
3443	!==============================================================================================
3444
3445	SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags &
3446	!
3447	#include "dummy_args.inc"
3448	!
3449	)
3450	USE module_state_description
3451	USE module_domain, ONLY : domain, get_ijk_from_grid
3452	USE module_configure, ONLY : grid_config_rec_type
3453	USE module_dm
3454	IMPLICIT NONE
3455	!
3456	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3457	TYPE(domain), POINTER :: ngrid
3458	#include <dummy_decl.inc>
3459	INTEGER nlev, msize
3460	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3461	TYPE (grid_config_rec_type) :: config_flags
3462	REAL xv(500)
3463	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3464	cims, cime, cjms, cjme, ckms, ckme, &
3465	cips, cipe, cjps, cjpe, ckps, ckpe
3466	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3467	nims, nime, njms, njme, nkms, nkme, &
3468	nips, nipe, njps, njpe, nkps, nkpe
3469	INTEGER :: ids, ide, jds, jde, kds, kde, &
3470	ims, ime, jms, jme, kms, kme, &
3471	ips, ipe, jps, jpe, kps, kpe
3472	integer myproc
3473
3474	#ifdef DEREF_KLUDGE
3475	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3476	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
3477	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3478	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3479	#endif
3480	#include "deref_kludge.h"
3481
3482	#define COPY_IN
3483	#include <scalar_derefs.inc>
3484
3485	CALL get_ijk_from_grid ( grid , &
3486	cids, cide, cjds, cjde, ckds, ckde, &
3487	cims, cime, cjms, cjme, ckms, ckme, &
3488	cips, cipe, cjps, cjpe, ckps, ckpe )
3489	CALL get_ijk_from_grid ( ngrid , &
3490	nids, nide, njds, njde, nkds, nkde, &
3491	nims, nime, njms, njme, nkms, nkme, &
3492	nips, nipe, njps, njpe, nkps, nkpe )
3493
3494	nlev = ckde - ckds + 1
3495
3496	#include "nest_interpdown_unpack.inc"
3497
3498	CALL get_ijk_from_grid ( grid , &
3499	ids, ide, jds, jde, kds, kde, &
3500	ims, ime, jms, jme, kms, kme, &
3501	ips, ipe, jps, jpe, kps, kpe )
3502
3503	#include "HALO_NMM_FORCE_DOWN1.inc"
3504
3505	! code here to interpolate the data into the nested domain
3506	#include "nest_forcedown_interp.inc"
3507
3508	#define COPY_OUT
3509	#include <scalar_derefs.inc>
3510
3511	RETURN
3512	END SUBROUTINE force_domain_nmm_part2
3513
3514	!================================================================================
3515	!
3516	! This routine exists only to call a halo on a domain (the nest)
3517	! gets called from feedback_domain_em_part1, below. This is needed
3518	! because the halo code expects the fields being exchanged to have
3519	! been dereferenced from the grid data structure, but in feedback_domain_em_part1
3520	! the grid data structure points to the coarse domain, not the nest.
3521	! And we want the halo exchange on the nest, so that the code in
3522	! em_nest_feedbackup_interp.inc will work correctly on multi-p. JM 20040308
3523	!
3524
3525	SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags &
3526	!
3527	#include "dummy_args.inc"
3528	!
3529	)
3530	USE module_state_description
3531	USE module_domain, ONLY : domain, get_ijk_from_grid
3532	USE module_configure, ONLY : grid_config_rec_type
3533	USE module_dm
3534	IMPLICIT NONE
3535	!
3536	TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid")
3537	TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
3538	! soil temp, moisture, etc., has vertical dim
3539	! of soil categories
3540	#include <dummy_decl.inc>
3541
3542	INTEGER :: ids, ide, jds, jde, kds, kde, &
3543	ims, ime, jms, jme, kms, kme, &
3544	ips, ipe, jps, jpe, kps, kpe
3545
3546	INTEGER :: idum1, idum2
3547
3548
3549	#ifdef DEREF_KLUDGE
3550	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3551	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
3552	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3553	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3554	#endif
3555	#include "deref_kludge.h"
3556
3557	#define COPY_IN
3558	#include <scalar_derefs.inc>
3559
3560	CALL get_ijk_from_grid ( grid , &
3561	ids, ide, jds, jde, kds, kde, &
3562	ims, ime, jms, jme, kms, kme, &
3563	ips, ipe, jps, jpe, kps, kpe )
3564
3565	#ifdef DM_PARALLEL
3566	#include "HALO_NMM_WEIGHTS.inc"
3567	#endif
3568
3569	#define COPY_OUT
3570	#include <scalar_derefs.inc>
3571
3572	END SUBROUTINE feedback_nest_prep_nmm
3573
3574	!------------------------------------------------------------------
3575
3576	SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags &
3577	!
3578	#include "dummy_args.inc"
3579	!
3580	)
3581	USE module_state_description
3582	USE module_domain, ONLY : domain, get_ijk_from_grid
3583	USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
3584	USE module_dm
3585	IMPLICIT NONE
3586	!
3587	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3588	TYPE(domain), POINTER :: ngrid
3589	#include <dummy_decl.inc>
3590	INTEGER nlev, msize
3591	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3592	TYPE(domain), POINTER :: xgrid
3593	TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
3594	REAL xv(500)
3595	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3596	cims, cime, cjms, cjme, ckms, ckme, &
3597	cips, cipe, cjps, cjpe, ckps, ckpe
3598	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3599	nims, nime, njms, njme, nkms, nkme, &
3600	nips, nipe, njps, njpe, nkps, nkpe
3601	INTEGER local_comm, myproc, nproc, idum1, idum2
3602
3603	#ifdef DEREF_KLUDGE
3604	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3605	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
3606	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3607	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3608	#endif
3609
3610	INTERFACE
3611	SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags &
3612	!
3613	#include "dummy_args.inc"
3614	!
3615	)
3616	USE module_state_description
3617	USE module_domain, ONLY : domain
3618	USE module_configure, ONLY : grid_config_rec_type
3619	!
3620	TYPE (grid_config_rec_type) :: config_flags
3621	TYPE(domain), TARGET :: grid
3622	#include <dummy_decl.inc>
3623	END SUBROUTINE feedback_nest_prep_nmm
3624	END INTERFACE
3625	!
3626	#define COPY_IN
3627	#include <scalar_derefs.inc>
3628
3629	CALL wrf_get_dm_communicator ( local_comm )
3630	CALL wrf_get_myproc( myproc )
3631	CALL wrf_get_nproc( nproc )
3632
3633
3634	!
3635	! intermediate grid
3636	CALL get_ijk_from_grid ( grid , &
3637	cids, cide, cjds, cjde, ckds, ckde, &
3638	cims, cime, cjms, cjme, ckms, ckme, &
3639	cips, cipe, cjps, cjpe, ckps, ckpe )
3640	! nest grid
3641	CALL get_ijk_from_grid ( ngrid , &
3642	nids, nide, njds, njde, nkds, nkde, &
3643	nims, nime, njms, njme, nkms, nkme, &
3644	nips, nipe, njps, njpe, nkps, nkpe )
3645
3646	nlev = ckde - ckds + 1
3647
3648	ips_save = ngrid%i_parent_start ! +1 not used in ipe_save & jpe_save
3649	jps_save = ngrid%j_parent_start ! because of one extra namelist point
3650	ipe_save = ngrid%i_parent_start + (nide-nids) / ngrid%parent_grid_ratio
3651	jpe_save = ngrid%j_parent_start + (njde-njds) / ngrid%parent_grid_ratio
3652
3653	! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
3654	! in a separate routine because the HALOs need the data to be dereference from the
3655	! grid data structure and, in this routine, the dereferenced fields are related to
3656	! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
3657	! domain, switch grid to point to ngrid, invoke feedback_nest_prep, then restore grid
3658	! to point to intermediate domain.
3659
3660	CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
3661	CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
3662	xgrid => grid
3663	grid => ngrid
3664	#include "deref_kludge.h"
3665	CALL feedback_nest_prep_nmm ( grid, config_flags &
3666	!
3667	#include "actual_args.inc"
3668	!
3669	)
3670
3671	! put things back so grid is intermediate grid
3672
3673	grid => xgrid
3674	CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
3675
3676	! "interp" (basically copy) ngrid onto intermediate grid
3677
3678	#include "nest_feedbackup_interp.inc"
3679
3680	#define COPY_OUT
3681	#include <scalar_derefs.inc>
3682	RETURN
3683	END SUBROUTINE feedback_domain_nmm_part1
3684
3685	!------------------------------------------------------------------
3686
3687	SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags &
3688	!
3689	#include "dummy_args.inc"
3690	!
3691	)
3692	USE module_state_description
3693	USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid
3694	USE module_configure, ONLY : grid_config_rec_type
3695	USE module_dm
3696	USE module_utility
3697	IMPLICIT NONE
3698
3699	!
3700	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3701	TYPE(domain), POINTER :: intermediate_grid
3702	TYPE(domain), POINTER :: ngrid
3703
3704	#include <dummy_decl.inc>
3705	INTEGER nlev, msize
3706	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3707	TYPE (grid_config_rec_type) :: config_flags
3708	REAL xv(500)
3709	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3710	cims, cime, cjms, cjme, ckms, ckme, &
3711	cips, cipe, cjps, cjpe, ckps, ckpe
3712	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3713	nims, nime, njms, njme, nkms, nkme, &
3714	nips, nipe, njps, njpe, nkps, nkpe
3715	INTEGER :: ids, ide, jds, jde, kds, kde, &
3716	ims, ime, jms, jme, kms, kme, &
3717	ips, ipe, jps, jpe, kps, kpe
3718	INTEGER icoord, jcoord, idim_cd, jdim_cd
3719	INTEGER local_comm, myproc, nproc
3720	INTEGER iparstrt, jparstrt, sw
3721	INTEGER thisdomain_max_halo_width
3722
3723	character*256 :: timestr
3724	integer ierr
3725
3726	REAL nest_influence
3727	LOGICAL, EXTERNAL :: cd_feedback_mask
3728	LOGICAL, EXTERNAL :: cd_feedback_mask_v
3729
3730	#define COPY_IN
3731	#include <scalar_derefs.inc>
3732
3733	! On entry to this routine,
3734	! "grid" refers to the parent domain
3735	! "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
3736	! "ngrid" refers to the nest, which is only needed for smoothing on the parent because
3737	! the nest feedback data has already been transferred during em_nest_feedbackup_interp
3738	! in part1, above.
3739	! The way these settings c and n dimensions are set, below, looks backwards but from the point
3740	! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
3741	! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
3742	! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
3743	! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
3744	! sign that says "DIP" than fix the dip, at this point it was easier just to write this comment. JM
3745	!
3746
3747	nest_influence = 0.5
3748	#define NEST_INFLUENCE(A,B) A = nest_influence(B) + (1.0-nest_influence)(A)
3749
3750
3751	CALL domain_clock_get( grid, current_timestr=timestr )
3752
3753	CALL get_ijk_from_grid ( intermediate_grid , &
3754	cids, cide, cjds, cjde, ckds, ckde, &
3755	cims, cime, cjms, cjme, ckms, ckme, &
3756	cips, cipe, cjps, cjpe, ckps, ckpe )
3757	CALL get_ijk_from_grid ( grid , &
3758	nids, nide, njds, njde, nkds, nkde, &
3759	nims, nime, njms, njme, nkms, nkme, &
3760	nips, nipe, njps, njpe, nkps, nkpe )
3761
3762	nide = nide - 1 !dusan
3763	njde = njde - 1 !dusan
3764
3765	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
3766	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
3767	CALL nl_get_shw ( intermediate_grid%id, sw )
3768	icoord = iparstrt - sw
3769	jcoord = jparstrt - sw
3770	idim_cd = cide - cids + 1
3771	jdim_cd = cjde - cjds + 1
3772
3773	nlev = ckde - ckds + 1
3774
3775	CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
3776	#include "nest_feedbackup_pack.inc"
3777
3778	CALL wrf_get_dm_communicator ( local_comm )
3779	CALL wrf_get_myproc( myproc )
3780	CALL wrf_get_nproc( nproc )
3781
3782	CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
3783
3784	#include "nest_feedbackup_unpack.inc"
3785
3786
3787	! smooth coarse grid
3788
3789	CALL get_ijk_from_grid ( ngrid, &
3790	nids, nide, njds, njde, nkds, nkde, &
3791	nims, nime, njms, njme, nkms, nkme, &
3792	nips, nipe, njps, njpe, nkps, nkpe )
3793	CALL get_ijk_from_grid ( grid , &
3794	ids, ide, jds, jde, kds, kde, &
3795	ims, ime, jms, jme, kms, kme, &
3796	ips, ipe, jps, jpe, kps, kpe )
3797
3798	#include "HALO_INTERP_UP.inc"
3799
3800	CALL get_ijk_from_grid ( grid , &
3801	cids, cide, cjds, cjde, ckds, ckde, &
3802	cims, cime, cjms, cjme, ckms, ckme, &
3803	cips, cipe, cjps, cjpe, ckps, ckpe )
3804
3805	#include "nest_feedbackup_smooth.inc"
3806
3807	#define COPY_OUT
3808	#include <scalar_derefs.inc>
3809	RETURN
3810	END SUBROUTINE feedback_domain_nmm_part2
3811
3812	!=================================================================================
3813	! End of gopal's doing
3814	!=================================================================================
3815	#endif
3816
3817	!------------------------------------------------------------------
3818
3819	SUBROUTINE wrf_gatherv_real (Field, field_ofst, &
3820	my_count , & ! sendcount
3821	globbuf, glob_ofst , & ! recvbuf
3822	counts , & ! recvcounts
3823	displs , & ! displs
3824	root , & ! root
3825	communicator , & ! communicator
3826	ierr )
3827	USE module_dm, ONLY : getrealmpitype
3828	IMPLICIT NONE
3829	INTEGER field_ofst, glob_ofst
3830	INTEGER my_count, communicator, root, ierr
3831	INTEGER , DIMENSION(*) :: counts, displs
3832	REAL, DIMENSION(*) :: Field, globbuf
3833	#ifndef STUBMPI
3834	INCLUDE 'mpif.h'
3835
3836	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
3837	my_count , & ! sendcount
3838	getrealmpitype() , & ! sendtype
3839	globbuf( glob_ofst ) , & ! recvbuf
3840	counts , & ! recvcounts
3841	displs , & ! displs
3842	getrealmpitype() , & ! recvtype
3843	root , & ! root
3844	communicator , & ! communicator
3845	ierr )
3846	#endif
3847
3848	END SUBROUTINE wrf_gatherv_real
3849
3850	SUBROUTINE wrf_gatherv_double (Field, field_ofst, &
3851	my_count , & ! sendcount
3852	globbuf, glob_ofst , & ! recvbuf
3853	counts , & ! recvcounts
3854	displs , & ! displs
3855	root , & ! root
3856	communicator , & ! communicator
3857	ierr )
3858	! USE module_dm
3859	IMPLICIT NONE
3860	INTEGER field_ofst, glob_ofst
3861	INTEGER my_count, communicator, root, ierr
3862	INTEGER , DIMENSION(*) :: counts, displs
3863	! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
3864	! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
3865	! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
3866	! if we were not indexing the globbuf and Field arrays it would not even matter
3867	REAL, DIMENSION(*) :: Field, globbuf
3868	#ifndef STUBMPI
3869	INCLUDE 'mpif.h'
3870
3871	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
3872	my_count , & ! sendcount
3873	MPI_DOUBLE_PRECISION , & ! sendtype
3874	globbuf( glob_ofst ) , & ! recvbuf
3875	counts , & ! recvcounts
3876	displs , & ! displs
3877	MPI_DOUBLE_PRECISION , & ! recvtype
3878	root , & ! root
3879	communicator , & ! communicator
3880	ierr )
3881	#endif
3882
3883	END SUBROUTINE wrf_gatherv_double
3884
3885	SUBROUTINE wrf_gatherv_integer (Field, field_ofst, &
3886	my_count , & ! sendcount
3887	globbuf, glob_ofst , & ! recvbuf
3888	counts , & ! recvcounts
3889	displs , & ! displs
3890	root , & ! root
3891	communicator , & ! communicator
3892	ierr )
3893	IMPLICIT NONE
3894	INTEGER field_ofst, glob_ofst
3895	INTEGER my_count, communicator, root, ierr
3896	INTEGER , DIMENSION(*) :: counts, displs
3897	INTEGER, DIMENSION(*) :: Field, globbuf
3898	#ifndef STUBMPI
3899	INCLUDE 'mpif.h'
3900
3901	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
3902	my_count , & ! sendcount
3903	MPI_INTEGER , & ! sendtype
3904	globbuf( glob_ofst ) , & ! recvbuf
3905	counts , & ! recvcounts
3906	displs , & ! displs
3907	MPI_INTEGER , & ! recvtype
3908	root , & ! root
3909	communicator , & ! communicator
3910	ierr )
3911	#endif
3912
3913	END SUBROUTINE wrf_gatherv_integer
3914
3915	!new stuff 20070124
3916	SUBROUTINE wrf_scatterv_real ( &
3917	globbuf, glob_ofst , & ! recvbuf
3918	counts , & ! recvcounts
3919	Field, field_ofst, &
3920	my_count , & ! sendcount
3921	displs , & ! displs
3922	root , & ! root
3923	communicator , & ! communicator
3924	ierr )
3925	USE module_dm, ONLY : getrealmpitype
3926	IMPLICIT NONE
3927	INTEGER field_ofst, glob_ofst
3928	INTEGER my_count, communicator, root, ierr
3929	INTEGER , DIMENSION(*) :: counts, displs
3930	REAL, DIMENSION(*) :: Field, globbuf
3931	#ifndef STUBMPI
3932	INCLUDE 'mpif.h'
3933
3934	CALL mpi_scatterv( &
3935	globbuf( glob_ofst ) , & ! recvbuf
3936	counts , & ! recvcounts
3937	displs , & ! displs
3938	getrealmpitype() , & ! recvtype
3939	Field( field_ofst ), & ! sendbuf
3940	my_count , & ! sendcount
3941	getrealmpitype() , & ! sendtype
3942	root , & ! root
3943	communicator , & ! communicator
3944	ierr )
3945	#endif
3946
3947	END SUBROUTINE wrf_scatterv_real
3948
3949	SUBROUTINE wrf_scatterv_double ( &
3950	globbuf, glob_ofst , & ! recvbuf
3951	counts , & ! recvcounts
3952	Field, field_ofst, &
3953	my_count , & ! sendcount
3954	displs , & ! displs
3955	root , & ! root
3956	communicator , & ! communicator
3957	ierr )
3958	USE module_dm
3959	IMPLICIT NONE
3960	INTEGER field_ofst, glob_ofst
3961	INTEGER my_count, communicator, root, ierr
3962	INTEGER , DIMENSION(*) :: counts, displs
3963	REAL, DIMENSION(*) :: Field, globbuf
3964	#ifndef STUBMPI
3965	INCLUDE 'mpif.h'
3966	! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
3967	! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
3968	! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
3969	! if we were not indexing the globbuf and Field arrays it would not even matter
3970
3971	CALL mpi_scatterv( &
3972	globbuf( glob_ofst ) , & ! recvbuf
3973	counts , & ! recvcounts
3974	displs , & ! displs
3975	MPI_DOUBLE_PRECISION , & ! recvtype
3976	Field( field_ofst ), & ! sendbuf
3977	my_count , & ! sendcount
3978	MPI_DOUBLE_PRECISION , & ! sendtype
3979	root , & ! root
3980	communicator , & ! communicator
3981	ierr )
3982	#endif
3983
3984	END SUBROUTINE wrf_scatterv_double
3985
3986	SUBROUTINE wrf_scatterv_integer ( &
3987	globbuf, glob_ofst , & ! recvbuf
3988	counts , & ! recvcounts
3989	Field, field_ofst, &
3990	my_count , & ! sendcount
3991	displs , & ! displs
3992	root , & ! root
3993	communicator , & ! communicator
3994	ierr )
3995	IMPLICIT NONE
3996	INTEGER field_ofst, glob_ofst
3997	INTEGER my_count, communicator, root, ierr
3998	INTEGER , DIMENSION(*) :: counts, displs
3999	INTEGER, DIMENSION(*) :: Field, globbuf
4000	#ifndef STUBMPI
4001	INCLUDE 'mpif.h'
4002
4003	CALL mpi_scatterv( &
4004	globbuf( glob_ofst ) , & ! recvbuf
4005	counts , & ! recvcounts
4006	displs , & ! displs
4007	MPI_INTEGER , & ! recvtype
4008	Field( field_ofst ), & ! sendbuf
4009	my_count , & ! sendcount
4010	MPI_INTEGER , & ! sendtype
4011	root , & ! root
4012	communicator , & ! communicator
4013	ierr )
4014	#endif
4015
4016	END SUBROUTINE wrf_scatterv_integer
4017	! end new stuff 20070124
4018
4019	SUBROUTINE wrf_dm_define_comms ( grid )
4020	USE module_domain, ONLY : domain
4021	IMPLICIT NONE
4022	TYPE(domain) , INTENT (INOUT) :: grid
4023	RETURN
4024	END SUBROUTINE wrf_dm_define_comms
4025
4026	SUBROUTINE tfp_message( fname, lno )
4027	CHARACTER() fname
4028	INTEGER lno
4029	CHARACTER*1024 mess
4030	#ifndef STUBMPI
4031	WRITE(mess,*)'tfp_message: ',trim(fname),lno
4032	CALL wrf_message(mess)
4033	# ifdef ALLOW_OVERDECOMP
4034	CALL task_for_point_message ! defined in RSL_LITE/task_for_point.c
4035	# else
4036	CALL wrf_error_fatal(mess)
4037	# endif
4038	#endif
4039	END SUBROUTINE tfp_message
4040
4041	SUBROUTINE set_dm_debug
4042	USE module_dm
4043	IMPLICIT NONE
4044	dm_debug_flag = .TRUE.
4045	END SUBROUTINE set_dm_debug
4046	SUBROUTINE reset_dm_debug
4047	USE module_dm
4048	IMPLICIT NONE
4049	dm_debug_flag = .FALSE.
4050	END SUBROUTINE reset_dm_debug
4051	SUBROUTINE get_dm_debug ( arg )
4052	USE module_dm
4053	IMPLICIT NONE
4054	LOGICAL arg
4055	arg = dm_debug_flag
4056	END SUBROUTINE get_dm_debug

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

Download in other formats:

Original Format