Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_dm.F @ 3553

Last change on this file since 3553 was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 123.5 KB

Line
1	!WRF:PACKAGE:RSL
2	!
3	MODULE module_dm
4
5	USE module_machine
6	USE module_configure
7	USE module_state_description
8	USE module_wrf_error
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 = 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	LOGICAL :: dm_debug_flag = .FALSE.
22
23	INTERFACE wrf_dm_maxval
24	MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision
25	END INTERFACE
26
27	INTERFACE wrf_dm_minval ! gopal's doing
28	MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision
29	END INTERFACE
30
31	CONTAINS
32
33
34	SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N )
35	IMPLICIT NONE
36	INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N
37	MINI = 2*P
38	MINM = 1
39	MINN = P
40	DO M = 1, P
41	IF ( MOD( P, M ) .EQ. 0 ) THEN
42	N = P / M
43	IF ( ABS(M-N) .LT. MINI &
44	.AND. M .GE. PROCMIN_M &
45	.AND. N .GE. PROCMIN_N &
46	) THEN
47	MINI = ABS(M-N)
48	MINM = M
49	MINN = N
50	ENDIF
51	ENDIF
52	ENDDO
53	IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN
54	WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH. STOPPING.'
55	CALL wrf_message ( TRIM ( wrf_err_message ) )
56	WRITE(0,*)' PROCMIN_M ', PROCMIN_M
57	WRITE( wrf_err_message , * )' PROCMIN_M ', PROCMIN_M
58	CALL wrf_message ( TRIM ( wrf_err_message ) )
59	WRITE( wrf_err_message , * )' PROCMIN_N ', PROCMIN_N
60	CALL wrf_message ( TRIM ( wrf_err_message ) )
61	WRITE( wrf_err_message , * )' P ', P
62	CALL wrf_message ( TRIM ( wrf_err_message ) )
63	WRITE( wrf_err_message , * )' MINM ', MINM
64	CALL wrf_message ( TRIM ( wrf_err_message ) )
65	WRITE( wrf_err_message , * )' MINN ', MINN
66	CALL wrf_message ( TRIM ( wrf_err_message ) )
67	CALL wrf_error_fatal ( 'module_dm: mpaspect' )
68	ENDIF
69	RETURN
70	END SUBROUTINE MPASPECT
71
72	SUBROUTINE wrf_dm_initialize
73	IMPLICIT NONE
74	INCLUDE 'mpif.h'
75	INTEGER :: local_comm, local_comm2, new_local_comm, group, newgroup, p, p1, ierr
76	INTEGER, ALLOCATABLE, DIMENSION(:) :: ranks
77	INTEGER, DIMENSION(2) :: dims, coords
78	LOGICAL, DIMENSION(2) :: isperiodic
79	LOGICAL :: reorder_mesh
80
81	CALL wrf_get_dm_communicator ( local_comm )
82	CALL mpi_comm_size( local_comm, ntasks, ierr )
83	CALL nl_get_nproc_x ( 1, ntasks_x )
84	CALL nl_get_nproc_y ( 1, ntasks_y )
85	CALL nl_get_reorder_mesh( 1, reorder_mesh )
86
87	! check if user has specified in the namelist
88	IF ( ntasks_x .GT. 0 .OR. ntasks_y .GT. 0 ) THEN
89	! if only ntasks_x is specified then make it 1-d decomp in i
90	IF ( ntasks_x .GT. 0 .AND. ntasks_y .EQ. -1 ) THEN
91	ntasks_y = ntasks / ntasks_x
92	! if only ntasks_y is specified then make it 1-d decomp in j
93	ELSE IF ( ntasks_x .EQ. -1 .AND. ntasks_y .GT. 0 ) THEN
94	ntasks_x = ntasks / ntasks_y
95	ENDIF
96	! make sure user knows what they're doing
97	IF ( ntasks_x * ntasks_y .NE. ntasks ) THEN
98	WRITE( wrf_err_message , * )'WRF_DM_INITIALIZE (RSL_LITE): nproc_x * nproc_y in namelist ne ',ntasks
99	CALL wrf_error_fatal ( wrf_err_message )
100	ENDIF
101	ELSE
102	! When neither is specified, work out mesh with MPASPECT
103	! Pass nproc_ln and nproc_nt so that number of procs in
104	! i-dim (nproc_ln) is equal or lesser.
105	CALL mpaspect ( ntasks, ntasks_x, ntasks_y, 1, 1 )
106	ENDIF
107	WRITE( wrf_err_message , * )'Ntasks in X ',ntasks_x,', ntasks in Y ',ntasks_y
108	CALL wrf_message( wrf_err_message )
109
110	CALL mpi_comm_rank( local_comm, mytask, ierr )
111	! extra code to reorder the communicator 20051212jm
112	IF ( reorder_mesh ) THEN
113	write(0,*)'reordering mesh'
114	ALLOCATE (ranks(ntasks))
115	CALL mpi_comm_dup ( local_comm , local_comm2, ierr )
116	CALL mpi_comm_group ( local_comm2, group, ierr )
117	DO p1=1,ntasks
118	p = p1 - 1
119	ranks(p1) = mod( p , ntasks_x ) * ntasks_y + p / ntasks_x
120	ENDDO
121	CALL mpi_group_incl( group, ntasks, ranks, newgroup, ierr )
122	DEALLOCATE (ranks)
123	CALL mpi_comm_create( local_comm2, newgroup, new_local_comm , ierr )
124	ELSE
125	new_local_comm = local_comm
126	ENDIF
127	! end extra code to reorder the communicator 20051212jm
128	dims(1) = ntasks_y ! rows
129	dims(2) = ntasks_x ! columns
130	isperiodic(1) = .false.
131	isperiodic(2) = .false.
132	CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator, ierr )
133	dims(1) = ntasks_y ! rows
134	dims(2) = ntasks_x ! columns
135	isperiodic(1) = .true.
136	isperiodic(2) = .true.
137	CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator_periodic, ierr )
138	! debug
139	CALL mpi_comm_rank( local_communicator_periodic, mytask, ierr )
140	CALL mpi_cart_coords( local_communicator_periodic, mytask, 2, coords, ierr )
141	write(0,*)'periodic coords ',mytask, coords
142
143	CALL mpi_comm_rank( local_communicator, mytask, ierr )
144	CALL mpi_cart_coords( local_communicator, mytask, 2, coords, ierr )
145	write(0,*)'non periodic coords ',mytask, coords
146	mytask_x = coords(2) ! col task (x)
147	mytask_y = coords(1) ! row task (y)
148	CALL nl_set_nproc_x ( 1, ntasks_x )
149	CALL nl_set_nproc_y ( 1, ntasks_y )
150	CALL wrf_set_dm_communicator ( local_communicator )
151	RETURN
152	END SUBROUTINE wrf_dm_initialize
153
154	SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, &
155	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
156	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
157	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
158	bdx , bdy )
159
160	USE module_domain
161	USE module_machine
162
163	IMPLICIT NONE
164	INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
165	INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
166	sm1 , em1 , sm2 , em2 , sm3 , em3
167	INTEGER, INTENT(IN) :: id, parent_id
168	TYPE(domain),POINTER :: parent
169
170	! Local variables
171	INTEGER :: ids, ide, jds, jde, kds, kde
172	INTEGER :: ims, ime, jms, jme, kms, kme
173	INTEGER :: ips, ipe, jps, jpe, kps, kpe
174
175	INTEGER :: c_sd1 , c_ed1 , c_sd2 , c_ed2 , c_sd3 , c_ed3
176	INTEGER :: c_sp1 , c_ep1 , c_sp2 , c_ep2 , c_sp3 , c_ep3 , &
177	c_sm1 , c_em1 , c_sm2 , c_em2 , c_sm3 , c_em3
178	INTEGER :: c_sp1x , c_ep1x , c_sp2x , c_ep2x , c_sp3x , c_ep3x , &
179	c_sm1x , c_em1x , c_sm2x , c_em2x , c_sm3x , c_em3x
180	INTEGER :: c_sp1y , c_ep1y , c_sp2y , c_ep2y , c_sp3y , c_ep3y , &
181	c_sm1y , c_em1y , c_sm2y , c_em2y , c_sm3y , c_em3y
182
183	INTEGER :: c_ids, c_ide, c_jds, c_jde, c_kds, c_kde
184	INTEGER :: c_ims, c_ime, c_jms, c_jme, c_kms, c_kme
185	INTEGER :: c_ips, c_ipe, c_jps, c_jpe, c_kps, c_kpe
186
187	INTEGER :: idim , jdim , kdim , rem , a, b
188	INTEGER :: i, j, ni, nj, Px, Py, P
189
190	INTEGER :: parent_grid_ratio, i_parent_start, j_parent_start
191	INTEGER :: shw
192	INTEGER :: idim_cd, jdim_cd
193
194	TYPE(domain), POINTER :: intermediate_grid
195	TYPE(domain), POINTER :: nest_grid
196
197
198	SELECT CASE ( model_data_order )
199	! need to finish other cases
200	CASE ( DATA_ORDER_ZXY )
201	ids = sd2 ; ide = ed2
202	jds = sd3 ; jde = ed3
203	kds = sd1 ; kde = ed1
204	CASE ( DATA_ORDER_XYZ )
205	ids = sd1 ; ide = ed1
206	jds = sd2 ; jde = ed2
207	kds = sd3 ; kde = ed3
208	CASE ( DATA_ORDER_XZY )
209	ids = sd1 ; ide = ed1
210	jds = sd3 ; jde = ed3
211	kds = sd2 ; kde = ed2
212	CASE ( DATA_ORDER_YXZ)
213	ids = sd2 ; ide = ed2
214	jds = sd1 ; jde = ed1
215	kds = sd3 ; kde = ed3
216	END SELECT
217
218	CALL compute_memory_dims_rsl_lite ( 0 , bdx, bdy, &
219	ids, ide, jds, jde, kds, kde, &
220	ims, ime, jms, jme, kms, kme, &
221	ips, ipe, jps, jpe, kps, kpe )
222
223	! ensure that the every parent domain point has a full set of nested points under it
224	! even at the borders. Do this by making sure the number of nest points is a multiple of
225	! the nesting ratio. Note that this is important mostly to the intermediate domain, which
226	! is the subject of the scatter gather comms with the parent
227
228	IF ( id .GT. 1 ) THEN
229	CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
230	if ( mod(ime,parent_grid_ratio) .NE. 0 ) ime = ime + parent_grid_ratio - mod(ime,parent_grid_ratio)
231	if ( mod(jme,parent_grid_ratio) .NE. 0 ) jme = jme + parent_grid_ratio - mod(jme,parent_grid_ratio)
232	ENDIF
233
234	SELECT CASE ( model_data_order )
235	! need to finish other cases
236	CASE ( DATA_ORDER_ZXY )
237	sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
238	sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
239	sp1 = kps ; ep1 = kpe ; sm1 = kms ; em1 = kme
240	CASE ( DATA_ORDER_XYZ )
241	sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
242	sp2 = jps ; ep2 = jpe ; sm2 = jms ; em2 = jme
243	sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
244	CASE ( DATA_ORDER_XZY )
245	sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
246	sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
247	sp2 = kps ; ep2 = kpe ; sm2 = kms ; em2 = kme
248	CASE ( DATA_ORDER_YXZ)
249	sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
250	sp1 = jps ; ep1 = jpe ; sm1 = jms ; em1 = jme
251	sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
252	END SELECT
253
254	if ( id.eq.1 ) then
255	WRITE(wrf_err_message,)'************************************'
256	CALL wrf_message( TRIM(wrf_err_message) )
257	WRITE(wrf_err_message,*)'Parent domain'
258	CALL wrf_message( TRIM(wrf_err_message) )
259	WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
260	CALL wrf_message( TRIM(wrf_err_message) )
261	WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
262	CALL wrf_message( TRIM(wrf_err_message) )
263	WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
264	CALL wrf_message( TRIM(wrf_err_message) )
265	WRITE(wrf_err_message,)'************************************'
266	CALL wrf_message( TRIM(wrf_err_message) )
267	endif
268
269	IF ( id .GT. 1 ) THEN
270
271	CALL nl_get_shw( id, shw )
272	CALL nl_get_i_parent_start( id , i_parent_start )
273	CALL nl_get_j_parent_start( id , j_parent_start )
274	CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
275
276	SELECT CASE ( model_data_order )
277	! need to finish other cases
278	CASE ( DATA_ORDER_ZXY )
279	idim = ed2-sd2+1
280	jdim = ed3-sd3+1
281	kdim = ed1-sd1+1
282	CASE ( DATA_ORDER_XYZ )
283	idim = ed1-sd1+1
284	jdim = ed2-sd2+1
285	kdim = ed3-sd3+1
286	CASE ( DATA_ORDER_XZY )
287	idim = ed1-sd1+1
288	jdim = ed3-sd3+1
289	kdim = ed2-sd2+1
290	CASE ( DATA_ORDER_YXZ)
291	idim = ed2-sd2+1
292	jdim = ed1-sd1+1
293	kdim = ed3-sd3+1
294	END SELECT
295
296	idim_cd = idim / parent_grid_ratio + 1 + 2*shw + 1
297	jdim_cd = jdim / parent_grid_ratio + 1 + 2*shw + 1
298
299	c_ids = i_parent_start-shw ; c_ide = c_ids + idim_cd - 1
300	c_jds = j_parent_start-shw ; c_jde = c_jds + jdim_cd - 1
301	c_kds = sd2 ; c_kde = ed2 ! IKJ ONLY
302
303	! we want the intermediate domain to be decomposed the
304	! the same as the underlying nest. So try this:
305	#if 0
306	CALL compute_memory_dims_rsl_lite ( shw, bdx, bdy, &
307	c_ids, c_ide, c_jds, c_jde, c_kds, c_kde, &
308	c_ims, c_ime, c_jms, c_jme, c_kms, c_kme, &
309	c_ips, c_ipe, c_jps, c_jpe, c_kps, c_kpe )
310	#else
311
312	! At such time as NMM nesting is able to use RSL_LITE (would require
313	! a number of other mods to this file for that to happen), this should
314	! be updated along the lines of what's done in compute_memory_dims_rsl_lite
315	! below. See note dated 20051020. JM
316
317	c_ips = -1
318	nj = ( c_jds - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
319	DO i = c_ids, c_ide
320	ni = ( i - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
321	CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
322	IF ( Px .EQ. mytask_x ) THEN
323	c_ipe = i
324	IF ( c_ips .EQ. -1 ) c_ips = i
325	ENDIF
326	ENDDO
327
328	c_jps = -1
329	ni = ( c_ids - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
330	DO j = c_jds, c_jde
331	nj = ( j - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
332	CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
333	IF ( Py .EQ. mytask_y ) THEN
334	c_jpe = j
335	IF ( c_jps .EQ. -1 ) c_jps = j
336	ENDIF
337	ENDDO
338
339	#endif
340
341	! extend the patch dimensions out shw along edges of domain
342	IF ( mytask_x .EQ. 0 ) THEN
343	c_ips = c_ips - shw
344	ENDIF
345	IF ( mytask_x .EQ. ntasks_x-1 ) THEN
346	c_ipe = c_ipe + shw
347	ENDIF
348	c_ims = max( c_ips - max(shw,max_halo_width), c_ids - bdx ) - 1
349	c_ime = min( c_ipe + max(shw,max_halo_width), c_ide + bdx ) + 1
350
351	! handle j dims
352	! extend the patch dimensions out shw along edges of domain
353	IF ( mytask_y .EQ. 0 ) THEN
354	c_jps = c_jps - shw
355	ENDIF
356	IF ( mytask_y .EQ. ntasks_y-1 ) THEN
357	c_jpe = c_jpe + shw
358	ENDIF
359	c_jms = max( c_jps - max(shw,max_halo_width), c_jds - bdx ) - 1
360	c_jme = min( c_jpe + max(shw,max_halo_width), c_jde + bdx ) + 1
361	! handle k dims
362	c_kps = 1
363	c_kpe = c_kde
364	c_kms = 1
365	c_kme = c_kde
366
367	WRITE(wrf_err_message,)'************************************'
368	CALL wrf_message( TRIM(wrf_err_message) )
369	WRITE(wrf_err_message,*)'Nesting domain'
370	CALL wrf_message( TRIM(wrf_err_message) )
371	WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
372	CALL wrf_message( TRIM(wrf_err_message) )
373	WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
374	CALL wrf_message( TRIM(wrf_err_message) )
375	WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
376	CALL wrf_message( TRIM(wrf_err_message) )
377	WRITE(wrf_err_message,*)'INTERMEDIATE domain'
378	CALL wrf_message( TRIM(wrf_err_message) )
379	WRITE(wrf_err_message,*)'ids,ide,jds,jde ',c_ids,c_ide,c_jds,c_jde
380	CALL wrf_message( TRIM(wrf_err_message) )
381	WRITE(wrf_err_message,*)'ims,ime,jms,jme ',c_ims,c_ime,c_jms,c_jme
382	CALL wrf_message( TRIM(wrf_err_message) )
383	WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',c_ips,c_ipe,c_jps,c_jpe
384	CALL wrf_message( TRIM(wrf_err_message) )
385	WRITE(wrf_err_message,)'************************************'
386	CALL wrf_message( TRIM(wrf_err_message) )
387
388	SELECT CASE ( model_data_order )
389	! need to finish other cases
390	CASE ( DATA_ORDER_ZXY )
391	c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
392	c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
393	c_sd1 = c_kds ; c_ed1 = c_kde ; c_sp1 = c_kps ; c_ep1 = c_kpe ; c_sm1 = c_kms ; c_em1 = c_kme
394	CASE ( DATA_ORDER_XYZ )
395	c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
396	c_sd2 = c_jds ; c_ed2 = c_jde ; c_sp2 = c_jps ; c_ep2 = c_jpe ; c_sm2 = c_jms ; c_em2 = c_jme
397	c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
398	CASE ( DATA_ORDER_XZY )
399	c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
400	c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
401	c_sd2 = c_kds ; c_ed2 = c_kde ; c_sp2 = c_kps ; c_ep2 = c_kpe ; c_sm2 = c_kms ; c_em2 = c_kme
402	CASE ( DATA_ORDER_YXZ)
403	c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
404	c_sd1 = c_jds ; c_ed1 = c_jde ; c_sp1 = c_jps ; c_ep1 = c_jpe ; c_sm1 = c_jms ; c_em1 = c_jme
405	c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
406	END SELECT
407
408	ALLOCATE ( intermediate_grid )
409	ALLOCATE ( intermediate_grid%parents( max_parents ) )
410	ALLOCATE ( intermediate_grid%nests( max_nests ) )
411
412	NULLIFY( intermediate_grid%sibling )
413	DO i = 1, max_nests
414	NULLIFY( intermediate_grid%nests(i)%ptr )
415	ENDDO
416	NULLIFY (intermediate_grid%next)
417	NULLIFY (intermediate_grid%same_level)
418	NULLIFY (intermediate_grid%i_start)
419	NULLIFY (intermediate_grid%j_start)
420	NULLIFY (intermediate_grid%i_end)
421	NULLIFY (intermediate_grid%j_end)
422	intermediate_grid%id = id
423	intermediate_grid%num_nests = 0
424	intermediate_grid%num_siblings = 0
425	intermediate_grid%num_parents = 1
426	intermediate_grid%max_tiles = 0
427	intermediate_grid%num_tiles_spec = 0
428	CALL find_grid_by_id ( id, head_grid, nest_grid )
429
430	nest_grid%intermediate_grid => intermediate_grid ! nest grid now has a pointer to this baby
431	intermediate_grid%parents(1)%ptr => nest_grid ! the intermediate grid considers nest its parent
432	intermediate_grid%num_parents = 1
433
434	c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
435	c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
436
437	intermediate_grid%sm31x = c_sm1x
438	intermediate_grid%em31x = c_em1x
439	intermediate_grid%sm32x = c_sm2x
440	intermediate_grid%em32x = c_em2x
441	intermediate_grid%sm33x = c_sm3x
442	intermediate_grid%em33x = c_em3x
443	intermediate_grid%sm31y = c_sm1y
444	intermediate_grid%em31y = c_em1y
445	intermediate_grid%sm32y = c_sm2y
446	intermediate_grid%em32y = c_em2y
447	intermediate_grid%sm33y = c_sm3y
448	intermediate_grid%em33y = c_em3y
449
450	#if 0
451	! allocate space for the intermediate domain
452	CALL alloc_space_field ( intermediate_grid, id , 3 , .FALSE., & ! use same id as nest
453	c_sd1, c_ed1, c_sd2, c_ed2, c_sd3, c_ed3, &
454	c_sm1, c_em1, c_sm2, c_em2, c_sm3, c_em3, &
455	c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, & ! x-xpose
456	c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y ) ! y-xpose
457	#endif
458	intermediate_grid%sd31 = c_sd1
459	intermediate_grid%ed31 = c_ed1
460	intermediate_grid%sp31 = c_sp1
461	intermediate_grid%ep31 = c_ep1
462	intermediate_grid%sm31 = c_sm1
463	intermediate_grid%em31 = c_em1
464	intermediate_grid%sd32 = c_sd2
465	intermediate_grid%ed32 = c_ed2
466	intermediate_grid%sp32 = c_sp2
467	intermediate_grid%ep32 = c_ep2
468	intermediate_grid%sm32 = c_sm2
469	intermediate_grid%em32 = c_em2
470	intermediate_grid%sd33 = c_sd3
471	intermediate_grid%ed33 = c_ed3
472	intermediate_grid%sp33 = c_sp3
473	intermediate_grid%ep33 = c_ep3
474	intermediate_grid%sm33 = c_sm3
475	intermediate_grid%em33 = c_em3
476
477	CALL med_add_config_info_to_grid ( intermediate_grid )
478
479	intermediate_grid%dx = parent%dx
480	intermediate_grid%dy = parent%dy
481	intermediate_grid%dt = parent%dt
482	ENDIF
483
484	RETURN
485	END SUBROUTINE patch_domain_rsl_lite
486
487	SUBROUTINE compute_memory_dims_rsl_lite ( &
488	shw , bdx, bdy , &
489	ids, ide, jds, jde, kds, kde, &
490	ims, ime, jms, jme, kms, kme, &
491	ips, ipe, jps, jpe, kps, kpe )
492
493	IMPLICIT NONE
494	INTEGER, INTENT(IN) :: shw, bdx, bdy
495	INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
496	INTEGER, INTENT(OUT) :: ips, ipe, jps, jpe, kps, kpe
497	INTEGER, INTENT(OUT) :: ims, ime, jms, jme, kms, kme
498
499	INTEGER idim, jdim, kdim, rem, a, b
500	INTEGER Px, Py, P, i, j
501
502	idim = ide-ids+1 - (2*shw)
503	jdim = jde-jds+1 - (2*shw)
504	kdim = kde-kds+1
505
506	#if 0
507	rem = mod(idim,ntasks_x)
508	a = ( idim / ntasks_x + 1 ) * min( rem, mytask_x )
509	b = ( idim / ntasks_x ) * max( 0, mytask_x - rem )
510	ips = max( 1, a + b + 1 ) + shw + ids-1
511	a = ( idim / ntasks_x + 1 ) * min( rem, mytask_x+1 )
512	b = ( idim / ntasks_x ) * max( 0, mytask_x+1 - rem )
513	ipe = a + b + shw + ids-1
514
515	rem = mod(jdim,ntasks_y)
516	a = ( jdim / ntasks_y + 1 ) * min( rem, mytask_y )
517	b = ( jdim / ntasks_y ) * max( 0, mytask_y - rem )
518	jps = max( 1, a + b + 1 ) + shw + jds-1
519	a = ( jdim / ntasks_y + 1 ) * min( rem, mytask_y+1 )
520	b = ( jdim / ntasks_y ) * max( 0, mytask_y+1 - rem )
521	jpe = a + b + shw + jds-1
522	#else
523	# if ( ! NMM_CORE == 1 )
524	ips = -1
525	j = jds ;
526	DO i = ids, ide
527	CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
528	IF ( Px .EQ. mytask_x ) THEN
529	ipe = i
530	IF ( ips .EQ. -1 ) ips = i
531	ENDIF
532	ENDDO
533
534	jps = -1
535	i = ids ;
536	DO j = jds, jde
537	CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
538	IF ( Py .EQ. mytask_y ) THEN
539	jpe = j
540	IF ( jps .EQ. -1 ) jps = j
541	ENDIF
542	ENDDO
543	# else
544
545	! In case of NMM CORE, the domain only ever runs from ids..ide-1 and jds..jde-1 so
546	! adjust decomposition to reflect. 20051020 JM
547
548	ips = -1
549	j = jds ;
550	DO i = ids, ide-1
551	CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py )
552	IF ( Px .EQ. mytask_x ) THEN
553	ipe = i
554	IF ( Px .EQ. ntasks_x-1 ) ipe = ipe + 1
555	IF ( ips .EQ. -1 ) ips = i
556	ENDIF
557	ENDDO
558
559	jps = -1
560	i = ids ;
561	DO j = jds, jde-1
562	CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py )
563	IF ( Py .EQ. mytask_y ) THEN
564	jpe = j
565	IF ( Py .EQ. ntasks_y-1 ) jpe = jpe + 1
566	IF ( jps .EQ. -1 ) jps = j
567	ENDIF
568	ENDDO
569	# endif
570	#endif
571
572	! extend the patch dimensions out shw along edges of domain
573	IF ( mytask_x .EQ. 0 ) THEN
574	ips = ips - shw
575	ENDIF
576	IF ( mytask_x .EQ. ntasks_x-1 ) THEN
577	ipe = ipe + shw
578	ENDIF
579	IF ( mytask_y .EQ. 0 ) THEN
580	jps = jps - shw
581	ENDIF
582	IF ( mytask_y .EQ. ntasks_y-1 ) THEN
583	jpe = jpe + shw
584	ENDIF
585
586	kps = 1
587	kpe = kdim
588	ims = max( ips - max(shw,max_halo_width), ids - bdx ) - 1
589	ime = min( ipe + max(shw,max_halo_width), ide + bdx ) + 1
590	jms = max( jps - max(shw,max_halo_width), jds - bdy ) - 1
591	jme = min( jpe + max(shw,max_halo_width), jde + bdy ) + 1
592	kms = 1
593	kme = kdim
594
595	END SUBROUTINE compute_memory_dims_rsl_lite
596
597	! internal, used below for switching the argument to MPI calls
598	! if reals are being autopromoted to doubles in the build of WRF
599	INTEGER function getrealmpitype()
600	#ifndef STUBMPI
601	IMPLICIT NONE
602	INCLUDE 'mpif.h'
603	INTEGER rtypesize, dtypesize, ierr
604	CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
605	CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
606	IF ( RWORDSIZE .EQ. rtypesize ) THEN
607	getrealmpitype = MPI_REAL
608	ELSE IF ( RWORDSIZE .EQ. dtypesize ) THEN
609	getrealmpitype = MPI_DOUBLE_PRECISION
610	ELSE
611	CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' )
612	ENDIF
613	#else
614	! required dummy initialization for function that is never called
615	getrealmpitype = 1
616	#endif
617	RETURN
618	END FUNCTION getrealmpitype
619
620	REAL FUNCTION wrf_dm_max_real ( inval )
621	IMPLICIT NONE
622	INCLUDE 'mpif.h'
623	REAL inval, retval
624	INTEGER ierr
625	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MAX, local_communicator, ierr )
626	wrf_dm_max_real = retval
627	END FUNCTION wrf_dm_max_real
628
629	REAL FUNCTION wrf_dm_min_real ( inval )
630	IMPLICIT NONE
631	INCLUDE 'mpif.h'
632	REAL inval, retval
633	INTEGER ierr
634	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MIN, local_communicator, ierr )
635	wrf_dm_min_real = retval
636	END FUNCTION wrf_dm_min_real
637
638	REAL FUNCTION wrf_dm_sum_real ( inval )
639	IMPLICIT NONE
640	INCLUDE 'mpif.h'
641	REAL inval, retval
642	INTEGER ierr
643	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_SUM, local_communicator, ierr )
644	wrf_dm_sum_real = retval
645	END FUNCTION wrf_dm_sum_real
646
647	INTEGER FUNCTION wrf_dm_sum_integer ( inval )
648	IMPLICIT NONE
649	INCLUDE 'mpif.h'
650	INTEGER inval, retval
651	INTEGER ierr
652	CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, local_communicator, ierr )
653	wrf_dm_sum_integer = retval
654	END FUNCTION wrf_dm_sum_integer
655
656	SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
657	IMPLICIT NONE
658	INCLUDE 'mpif.h'
659	REAL val, val_all( ntasks )
660	INTEGER idex, jdex, ierr
661	INTEGER dex(2)
662	INTEGER dex_all (2,ntasks)
663	INTEGER i
664
665	dex(1) = idex ; dex(2) = jdex
666	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
667	CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), local_communicator, ierr )
668	val = val_all(1)
669	idex = dex_all(1,1) ; jdex = dex_all(2,1)
670	DO i = 2, ntasks
671	IF ( val_all(i) .GT. val ) THEN
672	val = val_all(i)
673	idex = dex_all(1,i)
674	jdex = dex_all(2,i)
675	ENDIF
676	ENDDO
677	END SUBROUTINE wrf_dm_maxval_real
678
679	SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
680	IMPLICIT NONE
681	INCLUDE 'mpif.h'
682	DOUBLE PRECISION val, val_all( ntasks )
683	INTEGER idex, jdex, ierr
684	INTEGER dex(2)
685	INTEGER dex_all (2,ntasks)
686	INTEGER i
687
688	dex(1) = idex ; dex(2) = jdex
689	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
690	CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, local_communicator, ierr )
691	val = val_all(1)
692	idex = dex_all(1,1) ; jdex = dex_all(2,1)
693	DO i = 2, ntasks
694	IF ( val_all(i) .GT. val ) THEN
695	val = val_all(i)
696	idex = dex_all(1,i)
697	jdex = dex_all(2,i)
698	ENDIF
699	ENDDO
700	END SUBROUTINE wrf_dm_maxval_doubleprecision
701
702	SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
703	IMPLICIT NONE
704	INCLUDE 'mpif.h'
705	INTEGER val, val_all( ntasks )
706	INTEGER idex, jdex, ierr
707	INTEGER dex(2)
708	INTEGER dex_all (2,ntasks)
709	INTEGER i
710
711	dex(1) = idex ; dex(2) = jdex
712	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
713	CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, local_communicator, ierr )
714	val = val_all(1)
715	idex = dex_all(1,1) ; jdex = dex_all(2,1)
716	DO i = 2, ntasks
717	IF ( val_all(i) .GT. val ) THEN
718	val = val_all(i)
719	idex = dex_all(1,i)
720	jdex = dex_all(2,i)
721	ENDIF
722	ENDDO
723	END SUBROUTINE wrf_dm_maxval_integer
724
725	! For HWRF some additional computation is required. This is gopal's doing
726
727	SUBROUTINE wrf_dm_minval_real ( val, idex, jdex )
728	IMPLICIT NONE
729	REAL val, val_all( ntasks )
730	INTEGER idex, jdex, ierr
731	INTEGER dex(2)
732	INTEGER dex_all (2,ntasks)
733	! <DESCRIPTION>
734	! Collective operation. Each processor calls passing a local value and its index; on return
735	! all processors are passed back the maximum of all values passed and its index.
736	!
737	! </DESCRIPTION>
738	INTEGER i, comm
739	#ifndef STUBMPI
740	INCLUDE 'mpif.h'
741
742	CALL wrf_get_dm_communicator ( comm )
743	dex(1) = idex ; dex(2) = jdex
744	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
745	CALL mpi_allgather ( val, 1, MPI_REAL, val_all , 1, MPI_REAL, comm, ierr )
746	val = val_all(1)
747	idex = dex_all(1,1) ; jdex = dex_all(2,1)
748	DO i = 2, ntasks
749	IF ( val_all(i) .LT. val ) THEN
750	val = val_all(i)
751	idex = dex_all(1,i)
752	jdex = dex_all(2,i)
753	ENDIF
754	ENDDO
755	#endif
756	END SUBROUTINE wrf_dm_minval_real
757
758	SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex )
759	IMPLICIT NONE
760	DOUBLE PRECISION val, val_all( ntasks )
761	INTEGER idex, jdex, ierr
762	INTEGER dex(2)
763	INTEGER dex_all (2,ntasks)
764	! <DESCRIPTION>
765	! Collective operation. Each processor calls passing a local value and its index; on return
766	! all processors are passed back the maximum of all values passed and its index.
767	!
768	! </DESCRIPTION>
769	INTEGER i, comm
770	#ifndef STUBMPI
771	INCLUDE 'mpif.h'
772
773	CALL wrf_get_dm_communicator ( comm )
774	dex(1) = idex ; dex(2) = jdex
775	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
776	CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
777	val = val_all(1)
778	idex = dex_all(1,1) ; jdex = dex_all(2,1)
779	DO i = 2, ntasks
780	IF ( val_all(i) .LT. val ) THEN
781	val = val_all(i)
782	idex = dex_all(1,i)
783	jdex = dex_all(2,i)
784	ENDIF
785	ENDDO
786	#endif
787	END SUBROUTINE wrf_dm_minval_doubleprecision
788
789	SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex )
790	IMPLICIT NONE
791	INTEGER val, val_all( ntasks )
792	INTEGER idex, jdex, ierr
793	INTEGER dex(2)
794	INTEGER dex_all (2,ntasks)
795	! <DESCRIPTION>
796	! Collective operation. Each processor calls passing a local value and its index; on return
797	! all processors are passed back the maximum of all values passed and its index.
798	!
799	! </DESCRIPTION>
800	INTEGER i, comm
801	#ifndef STUBMPI
802	INCLUDE 'mpif.h'
803
804	CALL wrf_get_dm_communicator ( comm )
805	dex(1) = idex ; dex(2) = jdex
806	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
807	CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
808	val = val_all(1)
809	idex = dex_all(1,1) ; jdex = dex_all(2,1)
810	DO i = 2, ntasks
811	IF ( val_all(i) .LT. val ) THEN
812	val = val_all(i)
813	idex = dex_all(1,i)
814	jdex = dex_all(2,i)
815	ENDIF
816	ENDDO
817	#endif
818	END SUBROUTINE wrf_dm_minval_integer ! End of gopal's doing
819
820	SUBROUTINE init_module_dm
821	IMPLICIT NONE
822	INTEGER mpi_comm_local, ierr, mytask, nproc
823	INCLUDE 'mpif.h'
824	LOGICAL mpi_inited
825	CALL mpi_initialized( mpi_inited, ierr )
826	IF ( .NOT. mpi_inited ) THEN
827	! If MPI has not been initialized then initialize it and
828	! make comm_world the communicator
829	! Otherwise, something else (e.g. quilt-io) has already
830	! initialized MPI, so just grab the communicator that
831	! should already be stored and use that.
832	CALL mpi_init ( ierr )
833	CALL wrf_termio_dup
834	CALL wrf_set_dm_communicator ( MPI_COMM_WORLD )
835	ENDIF
836	CALL wrf_get_dm_communicator( mpi_comm_local )
837	END SUBROUTINE init_module_dm
838
839	! stub
840	SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
841	USE module_domain
842	IMPLICIT NONE
843	TYPE (domain), INTENT(INOUT) :: parent, nest
844	INTEGER, INTENT(IN) :: dx,dy
845	RETURN
846	END SUBROUTINE wrf_dm_move_nest
847
848	!------------------------------------------------------------------------------
849	SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, &
850	mp_local_uobmask, &
851	mp_local_vobmask, &
852	mp_local_cobmask, errf )
853
854	!------------------------------------------------------------------------------
855	! PURPOSE: Do MPI allgatherv operation across processors to get the
856	! errors at each observation point on all processors.
857	!
858	!------------------------------------------------------------------------------
859	#ifndef STUBMPI
860	INCLUDE 'mpif.h'
861
862	INTEGER, INTENT(IN) :: nsta ! Observation index.
863	INTEGER, INTENT(IN) :: nerrf ! Number of error fields.
864	INTEGER, INTENT(IN) :: niobf ! Number of observations.
865	LOGICAL, INTENT(IN) :: MP_LOCAL_UOBMASK(NIOBF)
866	LOGICAL, INTENT(IN) :: MP_LOCAL_VOBMASK(NIOBF)
867	LOGICAL, INTENT(IN) :: MP_LOCAL_COBMASK(NIOBF)
868	REAL, INTENT(INOUT) :: errf(nerrf, niobf)
869
870	! Local declarations
871	integer i, n, nlocal_dot, nlocal_crs
872	REAL UVT_BUFFER(NIOBF) ! Buffer for holding U, V, or T
873	REAL QRK_BUFFER(NIOBF) ! Buffer for holding Q or RKO
874	REAL SFP_BUFFER(NIOBF) ! Buffer for holding Surface pressure
875	INTEGER N_BUFFER(NIOBF)
876	REAL FULL_BUFFER(NIOBF)
877	INTEGER IFULL_BUFFER(NIOBF)
878	INTEGER IDISPLACEMENT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
879	INTEGER ICOUNT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
880
881	INTEGER :: MPI_COMM_COMP ! MPI group communicator
882	INTEGER :: NPROCS ! Number of processors
883	INTEGER :: IERR ! Error code from MPI routines
884
885	! Get communicator for MPI operations.
886	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
887
888	! Get rank of monitor processor and broadcast to others.
889	CALL MPI_COMM_SIZE( MPI_COMM_COMP, NPROCS, IERR )
890
891	! DO THE U FIELD
892	NLOCAL_DOT = 0
893	DO N = 1, NSTA
894	IF ( MP_LOCAL_UOBMASK(N) ) THEN ! USE U-POINT MASK
895	NLOCAL_DOT = NLOCAL_DOT + 1
896	UVT_BUFFER(NLOCAL_DOT) = ERRF(1,N) ! U WIND COMPONENT
897	SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N) ! SURFACE PRESSURE
898	QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N) ! RKO
899	N_BUFFER(NLOCAL_DOT) = N
900	ENDIF
901	ENDDO
902	CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
903	ICOUNT,1,MPI_INTEGER, &
904	MPI_COMM_COMP,IERR)
905	I = 1
906
907	IDISPLACEMENT(1) = 0
908	DO I = 2, NPROCS
909	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
910	ENDDO
911	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
912	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
913	MPI_INTEGER, MPI_COMM_COMP, IERR)
914	! U
915	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
916	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
917	MPI_REAL, MPI_COMM_COMP, IERR)
918	DO N = 1, NSTA
919	ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N)
920	ENDDO
921	! SURF PRESS AT U-POINTS
922	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
923	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
924	MPI_REAL, MPI_COMM_COMP, IERR)
925	DO N = 1, NSTA
926	ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N)
927	ENDDO
928	! RKO
929	CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL, &
930	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
931	MPI_REAL, MPI_COMM_COMP, IERR)
932	DO N = 1, NSTA
933	ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N)
934	ENDDO
935
936	! DO THE V FIELD
937	NLOCAL_DOT = 0
938	DO N = 1, NSTA
939	IF ( MP_LOCAL_VOBMASK(N) ) THEN ! USE V-POINT MASK
940	NLOCAL_DOT = NLOCAL_DOT + 1
941	UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N) ! V WIND COMPONENT
942	SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N) ! SURFACE PRESSURE
943	N_BUFFER(NLOCAL_DOT) = N
944	ENDIF
945	ENDDO
946	CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
947	ICOUNT,1,MPI_INTEGER, &
948	MPI_COMM_COMP,IERR)
949	I = 1
950
951	IDISPLACEMENT(1) = 0
952	DO I = 2, NPROCS
953	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
954	ENDDO
955	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
956	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
957	MPI_INTEGER, MPI_COMM_COMP, IERR)
958	! V
959	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
960	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
961	MPI_REAL, MPI_COMM_COMP, IERR)
962	DO N = 1, NSTA
963	ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N)
964	ENDDO
965	! SURF PRESS AT V-POINTS
966	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
967	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
968	MPI_REAL, MPI_COMM_COMP, IERR)
969	DO N = 1, NSTA
970	ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N)
971	ENDDO
972
973	! DO THE CROSS FIELDS, T AND Q
974	NLOCAL_CRS = 0
975	DO N = 1, NSTA
976	IF ( MP_LOCAL_COBMASK(N) ) THEN ! USE MASS-POINT MASK
977	NLOCAL_CRS = NLOCAL_CRS + 1
978	UVT_BUFFER(NLOCAL_CRS) = ERRF(3,N) ! TEMPERATURE
979	QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N) ! MOISTURE
980	SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N) ! SURFACE PRESSURE
981	N_BUFFER(NLOCAL_CRS) = N
982	ENDIF
983	ENDDO
984	CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, &
985	ICOUNT,1,MPI_INTEGER, &
986	MPI_COMM_COMP,IERR)
987	IDISPLACEMENT(1) = 0
988	DO I = 2, NPROCS
989	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
990	ENDDO
991	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER, &
992	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
993	MPI_INTEGER, MPI_COMM_COMP, IERR)
994	! T
995	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_CRS, MPI_REAL, &
996	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
997	MPI_REAL, MPI_COMM_COMP, IERR)
998
999	DO N = 1, NSTA
1000	ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1001	ENDDO
1002	! Q
1003	CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL, &
1004	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1005	MPI_REAL, MPI_COMM_COMP, IERR)
1006	DO N = 1, NSTA
1007	ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1008	ENDDO
1009	! SURF PRESS AT MASS POINTS
1010	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL, &
1011	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
1012	MPI_REAL, MPI_COMM_COMP, IERR)
1013	DO N = 1, NSTA
1014	ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1015	ENDDO
1016	#endif
1017	END SUBROUTINE get_full_obs_vector
1018
1019	END MODULE module_dm
1020
1021	!=========================================================================
1022	! wrf_dm_patch_domain has to be outside the module because it is called
1023	! by a routine in module_domain but depends on module domain
1024
1025	SUBROUTINE wrf_dm_patch_domain ( id , domdesc , parent_id , parent_domdesc , &
1026	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
1027	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
1028	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
1029	sp1x , ep1x , sm1x , em1x , &
1030	sp2x , ep2x , sm2x , em2x , &
1031	sp3x , ep3x , sm3x , em3x , &
1032	sp1y , ep1y , sm1y , em1y , &
1033	sp2y , ep2y , sm2y , em2y , &
1034	sp3y , ep3y , sm3y , em3y , &
1035	bdx , bdy )
1036	USE module_domain
1037	USE module_dm
1038	IMPLICIT NONE
1039
1040	INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
1041	INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
1042	sm1 , em1 , sm2 , em2 , sm3 , em3
1043	INTEGER :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
1044	sm1x , em1x , sm2x , em2x , sm3x , em3x
1045	INTEGER :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
1046	sm1y , em1y , sm2y , em2y , sm3y , em3y
1047	INTEGER, INTENT(INOUT):: id , domdesc , parent_id , parent_domdesc
1048
1049	TYPE(domain), POINTER :: parent
1050	TYPE(domain), POINTER :: grid_ptr
1051
1052	! this is necessary because we cannot pass parent directly into
1053	! wrf_dm_patch_domain because creating the correct interface definitions
1054	! would generate a circular USE reference between module_domain and module_dm
1055	! see comment this date in module_domain for more information. JM 20020416
1056
1057	NULLIFY( parent )
1058	grid_ptr => head_grid
1059	CALL find_grid_by_id( parent_id , grid_ptr , parent )
1060
1061	CALL patch_domain_rsl_lite ( id , parent, parent_id , &
1062	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
1063	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
1064	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
1065	bdx , bdy )
1066
1067	RETURN
1068	END SUBROUTINE wrf_dm_patch_domain
1069
1070	SUBROUTINE wrf_termio_dup
1071	IMPLICIT NONE
1072	INCLUDE 'mpif.h'
1073	INTEGER mytask, ntasks, ierr
1074	CALL mpi_comm_size(MPI_COMM_WORLD, ntasks, ierr )
1075	CALL mpi_comm_rank(MPI_COMM_WORLD, mytask, ierr )
1076	write(0,*)'starting wrf task ',mytask,' of ',ntasks
1077	CALL rsl_error_dup1( mytask )
1078	END SUBROUTINE wrf_termio_dup
1079
1080	SUBROUTINE wrf_get_myproc( myproc )
1081	USE module_dm
1082	IMPLICIT NONE
1083	INTEGER myproc
1084	myproc = mytask
1085	RETURN
1086	END SUBROUTINE wrf_get_myproc
1087
1088	SUBROUTINE wrf_get_nproc( nproc )
1089	USE module_dm
1090	IMPLICIT NONE
1091	INTEGER nproc
1092	nproc = ntasks
1093	RETURN
1094	END SUBROUTINE wrf_get_nproc
1095
1096	SUBROUTINE wrf_get_nprocx( nprocx )
1097	USE module_dm
1098	IMPLICIT NONE
1099	INTEGER nprocx
1100	nprocx = ntasks_x
1101	RETURN
1102	END SUBROUTINE wrf_get_nprocx
1103
1104	SUBROUTINE wrf_get_nprocy( nprocy )
1105	USE module_dm
1106	IMPLICIT NONE
1107	INTEGER nprocy
1108	nprocy = ntasks_y
1109	RETURN
1110	END SUBROUTINE wrf_get_nprocy
1111
1112	SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
1113	USE module_dm
1114	IMPLICIT NONE
1115	INCLUDE 'mpif.h'
1116	INTEGER size
1117	#ifndef NEC
1118	INTEGER*1 BUF(size)
1119	#else
1120	CHARACTER*1 BUF(size)
1121	#endif
1122	CALL BYTE_BCAST ( buf , size, local_communicator )
1123	RETURN
1124	END SUBROUTINE wrf_dm_bcast_bytes
1125
1126	SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
1127	IMPLICIT NONE
1128	INTEGER n1
1129	! <DESCRIPTION>
1130	! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
1131	!
1132	! </DESCRIPTION>
1133	CHARACTER() buf
1134	INTEGER ibuf(256),i,n
1135	CHARACTER*256 tstr
1136	n = n1
1137	! Root task is required to have the correct value of N1, other tasks
1138	! might not have the correct value.
1139	CALL wrf_dm_bcast_integer( n , 1 )
1140	IF (n .GT. 256) n = 256
1141	IF (n .GT. 0 ) then
1142	DO i = 1, n
1143	ibuf(I) = ichar(buf(I:I))
1144	ENDDO
1145	CALL wrf_dm_bcast_integer( ibuf, n )
1146	buf = ''
1147	DO i = 1, n
1148	buf(i:i) = char(ibuf(i))
1149	ENDDO
1150	ENDIF
1151	RETURN
1152	END SUBROUTINE wrf_dm_bcast_string
1153
1154	SUBROUTINE wrf_dm_bcast_integer( BUF, N1 )
1155	IMPLICIT NONE
1156	INTEGER n1
1157	INTEGER buf(*)
1158	CALL wrf_dm_bcast_bytes ( BUF , N1 * IWORDSIZE )
1159	RETURN
1160	END SUBROUTINE wrf_dm_bcast_integer
1161
1162	SUBROUTINE wrf_dm_bcast_double( BUF, N1 )
1163	IMPLICIT NONE
1164	INTEGER n1
1165	DOUBLEPRECISION buf(*)
1166	CALL wrf_dm_bcast_bytes ( BUF , N1 * DWORDSIZE )
1167	RETURN
1168	END SUBROUTINE wrf_dm_bcast_double
1169
1170	SUBROUTINE wrf_dm_bcast_real( BUF, N1 )
1171	IMPLICIT NONE
1172	INTEGER n1
1173	REAL buf(*)
1174	CALL wrf_dm_bcast_bytes ( BUF , N1 * RWORDSIZE )
1175	RETURN
1176	END SUBROUTINE wrf_dm_bcast_real
1177
1178	SUBROUTINE wrf_dm_bcast_logical( BUF, N1 )
1179	IMPLICIT NONE
1180	INTEGER n1
1181	LOGICAL buf(*)
1182	CALL wrf_dm_bcast_bytes ( BUF , N1 * LWORDSIZE )
1183	RETURN
1184	END SUBROUTINE wrf_dm_bcast_logical
1185
1186	SUBROUTINE write_68( grid, v , s , &
1187	ids, ide, jds, jde, kds, kde, &
1188	ims, ime, jms, jme, kms, kme, &
1189	its, ite, jts, jte, kts, kte )
1190	USE module_domain
1191	IMPLICIT NONE
1192	TYPE(domain) , INTENT (INOUT) :: grid
1193	CHARACTER () s
1194	INTEGER ids, ide, jds, jde, kds, kde, &
1195	ims, ime, jms, jme, kms, kme, &
1196	its, ite, jts, jte, kts, kte
1197	REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) :: v
1198
1199	INTEGER i,j,k,ierr
1200
1201	logical, external :: wrf_dm_on_monitor
1202	real globbuf( ids:ide, kds:kde, jds:jde )
1203	character*3 ord, stag
1204
1205	if ( kds == kde ) then
1206	ord = 'xy'
1207	stag = 'xy'
1208	CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
1209	ids, ide, jds, jde, kds, kde, &
1210	ims, ime, jms, jme, kms, kme, &
1211	its, ite, jts, jte, kts, kte )
1212	else
1213
1214	stag = 'xyz'
1215	ord = 'xzy'
1216	CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
1217	ids, ide, kds, kde, jds, jde, &
1218	ims, ime, kms, kme, jms, jme, &
1219	its, ite, kts, kte, jts, jte )
1220	endif
1221
1222
1223	if ( wrf_dm_on_monitor() ) THEN
1224	WRITE(68,*) ide-ids+1, jde-jds+1 , s
1225	DO j = jds, jde
1226	DO i = ids, ide
1227	WRITE(68,*) globbuf(i,1,j)
1228	ENDDO
1229	ENDDO
1230	endif
1231
1232	RETURN
1233	END
1234
1235	SUBROUTINE wrf_abort
1236	IMPLICIT NONE
1237	INCLUDE 'mpif.h'
1238	INTEGER ierr
1239	CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
1240	END SUBROUTINE wrf_abort
1241
1242	SUBROUTINE wrf_dm_shutdown
1243	IMPLICIT NONE
1244	INTEGER ierr
1245	CALL MPI_FINALIZE( ierr )
1246	RETURN
1247	END SUBROUTINE wrf_dm_shutdown
1248
1249	LOGICAL FUNCTION wrf_dm_on_monitor()
1250	USE module_dm
1251	IMPLICIT NONE
1252	INCLUDE 'mpif.h'
1253	INTEGER tsk, ierr, mpi_comm_local
1254	CALL wrf_get_dm_communicator( mpi_comm_local )
1255	CALL mpi_comm_rank ( mpi_comm_local, tsk , ierr )
1256	wrf_dm_on_monitor = tsk .EQ. 0
1257	RETURN
1258	END FUNCTION wrf_dm_on_monitor
1259
1260	SUBROUTINE wrf_get_dm_communicator ( communicator )
1261	USE module_dm
1262	IMPLICIT NONE
1263	INTEGER , INTENT(OUT) :: communicator
1264	communicator = local_communicator
1265	RETURN
1266	END SUBROUTINE wrf_get_dm_communicator
1267
1268	SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
1269	USE module_dm
1270	IMPLICIT NONE
1271	INTEGER , INTENT(OUT) :: iocommunicator
1272	iocommunicator = local_iocommunicator
1273	RETURN
1274	END SUBROUTINE wrf_get_dm_iocommunicator
1275
1276	SUBROUTINE wrf_set_dm_communicator ( communicator )
1277	USE module_dm
1278	IMPLICIT NONE
1279	INTEGER , INTENT(IN) :: communicator
1280	local_communicator = communicator
1281	RETURN
1282	END SUBROUTINE wrf_set_dm_communicator
1283
1284	SUBROUTINE wrf_set_dm_iocommunicator ( iocommunicator )
1285	USE module_dm
1286	IMPLICIT NONE
1287	INTEGER , INTENT(IN) :: iocommunicator
1288	local_iocommunicator = iocommunicator
1289	RETURN
1290	END SUBROUTINE wrf_set_dm_iocommunicator
1291
1292
1293	!!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1294
1295	SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,stagger,ordering,&
1296	DS1,DE1,DS2,DE2,DS3,DE3,&
1297	MS1,ME1,MS2,ME2,MS3,ME3,&
1298	PS1,PE1,PS2,PE2,PS3,PE3 )
1299	IMPLICIT NONE
1300	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1301	MS1,ME1,MS2,ME2,MS3,ME3,&
1302	PS1,PE1,PS2,PE2,PS3,PE3
1303	CHARACTER () stagger,ordering
1304	INTEGER fid,domdesc
1305	REAL globbuf(*)
1306	REAL buf(*)
1307
1308	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,RWORDSIZE,&
1309	DS1,DE1,DS2,DE2,DS3,DE3,&
1310	MS1,ME1,MS2,ME2,MS3,ME3,&
1311	PS1,PE1,PS2,PE2,PS3,PE3 )
1312
1313	RETURN
1314	END SUBROUTINE wrf_patch_to_global_real
1315
1316	SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,stagger,ordering,&
1317	DS1,DE1,DS2,DE2,DS3,DE3,&
1318	MS1,ME1,MS2,ME2,MS3,ME3,&
1319	PS1,PE1,PS2,PE2,PS3,PE3 )
1320	IMPLICIT NONE
1321	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1322	MS1,ME1,MS2,ME2,MS3,ME3,&
1323	PS1,PE1,PS2,PE2,PS3,PE3
1324	CHARACTER () stagger,ordering
1325	INTEGER fid,domdesc
1326	DOUBLEPRECISION globbuf(*)
1327	DOUBLEPRECISION buf(*)
1328
1329	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,DWORDSIZE,&
1330	DS1,DE1,DS2,DE2,DS3,DE3,&
1331	MS1,ME1,MS2,ME2,MS3,ME3,&
1332	PS1,PE1,PS2,PE2,PS3,PE3 )
1333
1334	RETURN
1335	END SUBROUTINE wrf_patch_to_global_double
1336
1337
1338	SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,stagger,ordering,&
1339	DS1,DE1,DS2,DE2,DS3,DE3,&
1340	MS1,ME1,MS2,ME2,MS3,ME3,&
1341	PS1,PE1,PS2,PE2,PS3,PE3 )
1342	IMPLICIT NONE
1343	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1344	MS1,ME1,MS2,ME2,MS3,ME3,&
1345	PS1,PE1,PS2,PE2,PS3,PE3
1346	CHARACTER () stagger,ordering
1347	INTEGER fid,domdesc
1348	INTEGER globbuf(*)
1349	INTEGER buf(*)
1350
1351	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,IWORDSIZE,&
1352	DS1,DE1,DS2,DE2,DS3,DE3,&
1353	MS1,ME1,MS2,ME2,MS3,ME3,&
1354	PS1,PE1,PS2,PE2,PS3,PE3 )
1355
1356	RETURN
1357	END SUBROUTINE wrf_patch_to_global_integer
1358
1359
1360	SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,stagger,ordering,&
1361	DS1,DE1,DS2,DE2,DS3,DE3,&
1362	MS1,ME1,MS2,ME2,MS3,ME3,&
1363	PS1,PE1,PS2,PE2,PS3,PE3 )
1364	IMPLICIT NONE
1365	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1366	MS1,ME1,MS2,ME2,MS3,ME3,&
1367	PS1,PE1,PS2,PE2,PS3,PE3
1368	CHARACTER () stagger,ordering
1369	INTEGER fid,domdesc
1370	LOGICAL globbuf(*)
1371	LOGICAL buf(*)
1372
1373	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,LWORDSIZE,&
1374	DS1,DE1,DS2,DE2,DS3,DE3,&
1375	MS1,ME1,MS2,ME2,MS3,ME3,&
1376	PS1,PE1,PS2,PE2,PS3,PE3 )
1377
1378	RETURN
1379	END SUBROUTINE wrf_patch_to_global_logical
1380
1381	#ifdef DEREF_KLUDGE
1382	# define FRSTELEM (1)
1383	#else
1384	# define FRSTELEM
1385	#endif
1386
1387	SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,typesize,&
1388	DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
1389	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
1390	PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
1391	USE module_driver_constants
1392	USE module_timing
1393	USE module_wrf_error
1394	USE module_dm
1395	IMPLICIT NONE
1396	INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
1397	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
1398	PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
1399	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1400	MS1,ME1,MS2,ME2,MS3,ME3,&
1401	PS1,PE1,PS2,PE2,PS3,PE3
1402	INTEGER ids,ide,jds,jde,kds,kde,&
1403	ims,ime,jms,jme,kms,kme,&
1404	ips,ipe,jps,jpe,kps,kpe
1405	CHARACTER () stagger,ordering
1406	LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
1407	INTEGER fid,domdesc,typesize,ierr
1408	REAL globbuf(*)
1409	REAL buf(*)
1410
1411	INTEGER i, j, k, ndim
1412	INTEGER Patch(3,2), Gpatch(3,2,ntasks)
1413	! allocated further down, after the D indices are potentially recalculated for staggering
1414	REAL, ALLOCATABLE :: tmpbuf( : )
1415	REAL locbuf( (PE1a-PS1a+1)(PE2a-PS2a+1)(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
1416
1417	DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
1418	MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
1419	PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
1420
1421	SELECT CASE ( TRIM(ordering) )
1422	CASE ( 'xy', 'yx' )
1423	ndim = 2
1424	CASE DEFAULT
1425	ndim = 3 ! where appropriate
1426	END SELECT
1427
1428	SELECT CASE ( TRIM(ordering) )
1429	CASE ( 'xyz','xy' )
1430	! the non-staggered variables come in at one-less than
1431	! domain dimensions, but code wants full domain spec, so
1432	! adjust if not staggered
1433	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
1434	IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
1435	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
1436	CASE ( 'yxz','yx' )
1437	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
1438	IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
1439	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
1440	CASE ( 'zxy' )
1441	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
1442	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
1443	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
1444	CASE ( 'xzy' )
1445	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
1446	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
1447	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
1448	CASE DEFAULT
1449	END SELECT
1450
1451	! moved to here to be after the potential recalculations of D dims
1452	IF ( wrf_dm_on_monitor() ) THEN
1453	ALLOCATE ( tmpbuf ( (DE1-DS1+1)(DE2-DS2+1)(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
1454	ELSE
1455	ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
1456	ENDIF
1457	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_patch_to_global_generic')
1458
1459	Patch(1,1) = ps1 ; Patch(1,2) = pe1 ! use patch dims
1460	Patch(2,1) = ps2 ; Patch(2,2) = pe2
1461	Patch(3,1) = ps3 ; Patch(3,2) = pe3
1462
1463	IF ( typesize .EQ. RWORDSIZE ) THEN
1464	CALL just_patch_r ( buf , locbuf , size(locbuf), &
1465	PS1, PE1, PS2, PE2, PS3, PE3 , &
1466	MS1, ME1, MS2, ME2, MS3, ME3 )
1467	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
1468	CALL just_patch_i ( buf , locbuf , size(locbuf), &
1469	PS1, PE1, PS2, PE2, PS3, PE3 , &
1470	MS1, ME1, MS2, ME2, MS3, ME3 )
1471	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
1472	CALL just_patch_d ( buf , locbuf , size(locbuf), &
1473	PS1, PE1, PS2, PE2, PS3, PE3 , &
1474	MS1, ME1, MS2, ME2, MS3, ME3 )
1475	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
1476	CALL just_patch_l ( buf , locbuf , size(locbuf), &
1477	PS1, PE1, PS2, PE2, PS3, PE3 , &
1478	MS1, ME1, MS2, ME2, MS3, ME3 )
1479	ENDIF
1480
1481	! defined in external/io_quilt
1482	CALL collect_on_comm0 ( local_communicator , IWORDSIZE , &
1483	Patch , 6 , &
1484	GPatch , 6*ntasks )
1485
1486	CALL collect_on_comm0 ( local_communicator , typesize , &
1487	locbuf , (pe1-ps1+1)(pe2-ps2+1)(pe3-ps3+1), &
1488	tmpbuf FRSTELEM , (de1-ds1+1)(de2-ds2+1)(de3-ds3+1) )
1489
1490	ndim = len(TRIM(ordering))
1491
1492	IF ( wrf_at_debug_level(500) ) THEN
1493	CALL start_timing
1494	ENDIF
1495
1496	IF ( ndim .GE. 2 .AND. wrf_dm_on_monitor() ) THEN
1497
1498	IF ( typesize .EQ. RWORDSIZE ) THEN
1499	CALL patch_2_outbuf_r ( tmpbuf FRSTELEM , globbuf , &
1500	DS1, DE1, DS2, DE2, DS3, DE3 , &
1501	GPATCH )
1502	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
1503	CALL patch_2_outbuf_i ( tmpbuf FRSTELEM , globbuf , &
1504	DS1, DE1, DS2, DE2, DS3, DE3 , &
1505	GPATCH )
1506	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
1507	CALL patch_2_outbuf_d ( tmpbuf FRSTELEM , globbuf , &
1508	DS1, DE1, DS2, DE2, DS3, DE3 , &
1509	GPATCH )
1510	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
1511	CALL patch_2_outbuf_l ( tmpbuf FRSTELEM , globbuf , &
1512	DS1, DE1, DS2, DE2, DS3, DE3 , &
1513	GPATCH )
1514	ENDIF
1515
1516	ENDIF
1517
1518	IF ( wrf_at_debug_level(500) ) THEN
1519	CALL end_timing('wrf_patch_to_global_generic')
1520	ENDIF
1521	DEALLOCATE( tmpbuf )
1522	RETURN
1523	END SUBROUTINE wrf_patch_to_global_generic
1524
1525	SUBROUTINE just_patch_i ( inbuf , outbuf, noutbuf, &
1526	PS1,PE1,PS2,PE2,PS3,PE3, &
1527	MS1,ME1,MS2,ME2,MS3,ME3 )
1528	USE module_dm
1529	IMPLICIT NONE
1530	INTEGER , INTENT(IN) :: noutbuf
1531	INTEGER , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
1532	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
1533	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
1534	INTEGER , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(IN) :: inbuf
1535	! Local
1536	INTEGER :: i,j,k,n , icurs
1537	icurs = 1
1538	DO k = PS3, PE3
1539	DO j = PS2, PE2
1540	DO i = PS1, PE1
1541	outbuf( icurs ) = inbuf( i, j, k )
1542	icurs = icurs + 1
1543	ENDDO
1544	ENDDO
1545	ENDDO
1546	RETURN
1547	END SUBROUTINE just_patch_i
1548
1549	SUBROUTINE just_patch_r ( inbuf , outbuf, noutbuf, &
1550	PS1,PE1,PS2,PE2,PS3,PE3, &
1551	MS1,ME1,MS2,ME2,MS3,ME3 )
1552	USE module_dm
1553	IMPLICIT NONE
1554	INTEGER , INTENT(IN) :: noutbuf
1555	REAL , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
1556	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
1557	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
1558	REAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
1559	! Local
1560	INTEGER :: i,j,k , icurs
1561	icurs = 1
1562	DO k = PS3, PE3
1563	DO j = PS2, PE2
1564	DO i = PS1, PE1
1565	outbuf( icurs ) = inbuf( i, j, k )
1566	icurs = icurs + 1
1567	ENDDO
1568	ENDDO
1569	ENDDO
1570	RETURN
1571	END SUBROUTINE just_patch_r
1572
1573	SUBROUTINE just_patch_d ( inbuf , outbuf, noutbuf, &
1574	PS1,PE1,PS2,PE2,PS3,PE3, &
1575	MS1,ME1,MS2,ME2,MS3,ME3 )
1576	USE module_dm
1577	IMPLICIT NONE
1578	INTEGER , INTENT(IN) :: noutbuf
1579	DOUBLE PRECISION , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
1580	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
1581	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
1582	DOUBLE PRECISION , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
1583	! Local
1584	INTEGER :: i,j,k,n , icurs
1585	icurs = 1
1586	DO k = PS3, PE3
1587	DO j = PS2, PE2
1588	DO i = PS1, PE1
1589	outbuf( icurs ) = inbuf( i, j, k )
1590	icurs = icurs + 1
1591	ENDDO
1592	ENDDO
1593	ENDDO
1594	RETURN
1595	END SUBROUTINE just_patch_d
1596
1597	SUBROUTINE just_patch_l ( inbuf , outbuf, noutbuf, &
1598	PS1,PE1,PS2,PE2,PS3,PE3, &
1599	MS1,ME1,MS2,ME2,MS3,ME3 )
1600	USE module_dm
1601	IMPLICIT NONE
1602	INTEGER , INTENT(IN) :: noutbuf
1603	LOGICAL , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
1604	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
1605	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
1606	LOGICAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
1607	! Local
1608	INTEGER :: i,j,k,n , icurs
1609	icurs = 1
1610	DO k = PS3, PE3
1611	DO j = PS2, PE2
1612	DO i = PS1, PE1
1613	outbuf( icurs ) = inbuf( i, j, k )
1614	icurs = icurs + 1
1615	ENDDO
1616	ENDDO
1617	ENDDO
1618	RETURN
1619	END SUBROUTINE just_patch_l
1620
1621
1622	SUBROUTINE patch_2_outbuf_r( inbuf, outbuf, &
1623	DS1,DE1,DS2,DE2,DS3,DE3, &
1624	GPATCH )
1625	USE module_dm
1626	IMPLICIT NONE
1627	REAL , DIMENSION(*) , INTENT(IN) :: inbuf
1628	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
1629	REAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
1630	! Local
1631	INTEGER :: i,j,k,n , icurs
1632	icurs = 1
1633	DO n = 1, ntasks
1634	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
1635	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
1636	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
1637	outbuf( i, j, k ) = inbuf( icurs )
1638	icurs = icurs + 1
1639	ENDDO
1640	ENDDO
1641	ENDDO
1642	ENDDO
1643
1644	RETURN
1645	END SUBROUTINE patch_2_outbuf_r
1646
1647	SUBROUTINE patch_2_outbuf_i( inbuf, outbuf, &
1648	DS1,DE1,DS2,DE2,DS3,DE3,&
1649	GPATCH )
1650	USE module_dm
1651	IMPLICIT NONE
1652	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
1653	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
1654	INTEGER , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
1655	! Local
1656	INTEGER :: i,j,k,n , icurs
1657	icurs = 1
1658	DO n = 1, ntasks
1659	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
1660	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
1661	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
1662	outbuf( i, j, k ) = inbuf( icurs )
1663	icurs = icurs + 1
1664	ENDDO
1665	ENDDO
1666	ENDDO
1667	ENDDO
1668	RETURN
1669	END SUBROUTINE patch_2_outbuf_i
1670
1671	SUBROUTINE patch_2_outbuf_d( inbuf, outbuf, &
1672	DS1,DE1,DS2,DE2,DS3,DE3,&
1673	GPATCH )
1674	USE module_dm
1675	IMPLICIT NONE
1676	DOUBLE PRECISION , DIMENSION(*) , INTENT(IN) :: inbuf
1677	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
1678	DOUBLE PRECISION , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
1679	! Local
1680	INTEGER :: i,j,k,n , icurs
1681	icurs = 1
1682	DO n = 1, ntasks
1683	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
1684	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
1685	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
1686	outbuf( i, j, k ) = inbuf( icurs )
1687	icurs = icurs + 1
1688	ENDDO
1689	ENDDO
1690	ENDDO
1691	ENDDO
1692	RETURN
1693	END SUBROUTINE patch_2_outbuf_d
1694
1695	SUBROUTINE patch_2_outbuf_l( inbuf, outbuf, &
1696	DS1,DE1,DS2,DE2,DS3,DE3,&
1697	GPATCH )
1698	USE module_dm
1699	IMPLICIT NONE
1700	LOGICAL , DIMENSION(*) , INTENT(IN) :: inbuf
1701	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
1702	LOGICAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
1703	! Local
1704	INTEGER :: i,j,k,n , icurs
1705	icurs = 1
1706	DO n = 1, ntasks
1707	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
1708	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
1709	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
1710	outbuf( i, j, k ) = inbuf( icurs )
1711	icurs = icurs + 1
1712	ENDDO
1713	ENDDO
1714	ENDDO
1715	ENDDO
1716	RETURN
1717	END SUBROUTINE patch_2_outbuf_l
1718
1719	!!!!!!!!!!!!!!!!!!!!!!! GLOBAL TO PATCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1720
1721	SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
1722	DS1,DE1,DS2,DE2,DS3,DE3,&
1723	MS1,ME1,MS2,ME2,MS3,ME3,&
1724	PS1,PE1,PS2,PE2,PS3,PE3 )
1725	IMPLICIT NONE
1726	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1727	MS1,ME1,MS2,ME2,MS3,ME3,&
1728	PS1,PE1,PS2,PE2,PS3,PE3
1729	CHARACTER () stagger,ordering
1730	INTEGER fid,domdesc
1731	REAL globbuf(*)
1732	REAL buf(*)
1733
1734	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,RWORDSIZE,&
1735	DS1,DE1,DS2,DE2,DS3,DE3,&
1736	MS1,ME1,MS2,ME2,MS3,ME3,&
1737	PS1,PE1,PS2,PE2,PS3,PE3 )
1738	RETURN
1739	END SUBROUTINE wrf_global_to_patch_real
1740
1741	SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,stagger,ordering,&
1742	DS1,DE1,DS2,DE2,DS3,DE3,&
1743	MS1,ME1,MS2,ME2,MS3,ME3,&
1744	PS1,PE1,PS2,PE2,PS3,PE3 )
1745	IMPLICIT NONE
1746	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1747	MS1,ME1,MS2,ME2,MS3,ME3,&
1748	PS1,PE1,PS2,PE2,PS3,PE3
1749	CHARACTER () stagger,ordering
1750	INTEGER fid,domdesc
1751	DOUBLEPRECISION globbuf(*)
1752	DOUBLEPRECISION buf(*)
1753
1754	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,DWORDSIZE,&
1755	DS1,DE1,DS2,DE2,DS3,DE3,&
1756	MS1,ME1,MS2,ME2,MS3,ME3,&
1757	PS1,PE1,PS2,PE2,PS3,PE3 )
1758	RETURN
1759	END SUBROUTINE wrf_global_to_patch_double
1760
1761
1762	SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,stagger,ordering,&
1763	DS1,DE1,DS2,DE2,DS3,DE3,&
1764	MS1,ME1,MS2,ME2,MS3,ME3,&
1765	PS1,PE1,PS2,PE2,PS3,PE3 )
1766	IMPLICIT NONE
1767	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1768	MS1,ME1,MS2,ME2,MS3,ME3,&
1769	PS1,PE1,PS2,PE2,PS3,PE3
1770	CHARACTER () stagger,ordering
1771	INTEGER fid,domdesc
1772	INTEGER globbuf(*)
1773	INTEGER buf(*)
1774
1775	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,IWORDSIZE,&
1776	DS1,DE1,DS2,DE2,DS3,DE3,&
1777	MS1,ME1,MS2,ME2,MS3,ME3,&
1778	PS1,PE1,PS2,PE2,PS3,PE3 )
1779	RETURN
1780	END SUBROUTINE wrf_global_to_patch_integer
1781
1782	SUBROUTINE wrf_global_to_patch_logical (globbuf,buf,domdesc,stagger,ordering,&
1783	DS1,DE1,DS2,DE2,DS3,DE3,&
1784	MS1,ME1,MS2,ME2,MS3,ME3,&
1785	PS1,PE1,PS2,PE2,PS3,PE3 )
1786	IMPLICIT NONE
1787	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1788	MS1,ME1,MS2,ME2,MS3,ME3,&
1789	PS1,PE1,PS2,PE2,PS3,PE3
1790	CHARACTER () stagger,ordering
1791	INTEGER fid,domdesc
1792	LOGICAL globbuf(*)
1793	LOGICAL buf(*)
1794
1795	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,LWORDSIZE,&
1796	DS1,DE1,DS2,DE2,DS3,DE3,&
1797	MS1,ME1,MS2,ME2,MS3,ME3,&
1798	PS1,PE1,PS2,PE2,PS3,PE3 )
1799	RETURN
1800	END SUBROUTINE wrf_global_to_patch_logical
1801
1802	SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,typesize,&
1803	DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
1804	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
1805	PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
1806	USE module_dm
1807	USE module_driver_constants
1808	IMPLICIT NONE
1809	INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
1810	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
1811	PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
1812	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
1813	MS1,ME1,MS2,ME2,MS3,ME3,&
1814	PS1,PE1,PS2,PE2,PS3,PE3
1815	CHARACTER () stagger,ordering
1816	INTEGER fid,domdesc,typesize,ierr
1817	REAL globbuf(*)
1818	REAL buf(*)
1819	LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
1820
1821	INTEGER i,j,k,ord,ord2d,ndim
1822	INTEGER Patch(3,2), Gpatch(3,2,ntasks)
1823	REAL, ALLOCATABLE :: tmpbuf( : )
1824	REAL locbuf( (PE1a-PS1a+1)(PE2a-PS2a+1)(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
1825
1826	DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
1827	MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
1828	PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
1829
1830	SELECT CASE ( TRIM(ordering) )
1831	CASE ( 'xy', 'yx' )
1832	ndim = 2
1833	CASE DEFAULT
1834	ndim = 3 ! where appropriate
1835	END SELECT
1836
1837	SELECT CASE ( TRIM(ordering) )
1838	CASE ( 'xyz','xy' )
1839	! the non-staggered variables come in at one-less than
1840	! domain dimensions, but code wants full domain spec, so
1841	! adjust if not staggered
1842	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
1843	IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
1844	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
1845	CASE ( 'yxz','yx' )
1846	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
1847	IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
1848	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
1849	CASE ( 'zxy' )
1850	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
1851	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
1852	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
1853	CASE ( 'xzy' )
1854	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
1855	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
1856	IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
1857	CASE DEFAULT
1858	END SELECT
1859
1860	! moved to here to be after the potential recalculations of D dims
1861	IF ( wrf_dm_on_monitor() ) THEN
1862	ALLOCATE ( tmpbuf ( (DE1-DS1+1)(DE2-DS2+1)(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
1863	ELSE
1864	ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
1865	ENDIF
1866	IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_global_to_patch_generic')
1867
1868	Patch(1,1) = ps1 ; Patch(1,2) = pe1 ! use patch dims
1869	Patch(2,1) = ps2 ; Patch(2,2) = pe2
1870	Patch(3,1) = ps3 ; Patch(3,2) = pe3
1871
1872	! defined in external/io_quilt
1873	CALL collect_on_comm0 ( local_communicator , IWORDSIZE , &
1874	Patch , 6 , &
1875	GPatch , 6*ntasks )
1876
1877	ndim = len(TRIM(ordering))
1878
1879	IF ( wrf_dm_on_monitor() .AND. ndim .GE. 2 ) THEN
1880	IF ( typesize .EQ. RWORDSIZE ) THEN
1881	CALL outbuf_2_patch_r ( globbuf , tmpbuf FRSTELEM , &
1882	DS1, DE1, DS2, DE2, DS3, DE3 , &
1883	MS1, ME1, MS2, ME2, MS3, ME3 , &
1884	GPATCH )
1885	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
1886	CALL outbuf_2_patch_i ( globbuf , tmpbuf FRSTELEM , &
1887	DS1, DE1, DS2, DE2, DS3, DE3 , &
1888	GPATCH )
1889	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
1890	CALL outbuf_2_patch_d ( globbuf , tmpbuf FRSTELEM , &
1891	DS1, DE1, DS2, DE2, DS3, DE3 , &
1892	GPATCH )
1893	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
1894	CALL outbuf_2_patch_l ( globbuf , tmpbuf FRSTELEM , &
1895	DS1, DE1, DS2, DE2, DS3, DE3 , &
1896	GPATCH )
1897	ENDIF
1898	ENDIF
1899
1900	CALL dist_on_comm0 ( local_communicator , typesize , &
1901	tmpbuf FRSTELEM , (de1-ds1+1)(de2-ds2+1)(de3-ds3+1) , &
1902	locbuf , (pe1-ps1+1)(pe2-ps2+1)(pe3-ps3+1) )
1903
1904	IF ( typesize .EQ. RWORDSIZE ) THEN
1905	CALL all_sub_r ( locbuf , buf , &
1906	PS1, PE1, PS2, PE2, PS3, PE3 , &
1907	MS1, ME1, MS2, ME2, MS3, ME3 )
1908
1909	ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
1910	CALL all_sub_i ( locbuf , buf , &
1911	PS1, PE1, PS2, PE2, PS3, PE3 , &
1912	MS1, ME1, MS2, ME2, MS3, ME3 )
1913	ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
1914	CALL all_sub_d ( locbuf , buf , &
1915	PS1, PE1, PS2, PE2, PS3, PE3 , &
1916	MS1, ME1, MS2, ME2, MS3, ME3 )
1917	ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
1918	CALL all_sub_l ( locbuf , buf , &
1919	PS1, PE1, PS2, PE2, PS3, PE3 , &
1920	MS1, ME1, MS2, ME2, MS3, ME3 )
1921	ENDIF
1922
1923
1924	DEALLOCATE ( tmpbuf )
1925	RETURN
1926	END SUBROUTINE wrf_global_to_patch_generic
1927
1928	SUBROUTINE all_sub_i ( inbuf , outbuf, &
1929	PS1,PE1,PS2,PE2,PS3,PE3, &
1930	MS1,ME1,MS2,ME2,MS3,ME3 )
1931	USE module_dm
1932	IMPLICIT NONE
1933	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
1934	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
1935	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
1936	INTEGER , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
1937	! Local
1938	INTEGER :: i,j,k,n , icurs
1939	icurs = 1
1940	DO k = PS3, PE3
1941	DO j = PS2, PE2
1942	DO i = PS1, PE1
1943	outbuf( i, j, k ) = inbuf ( icurs )
1944	icurs = icurs + 1
1945	ENDDO
1946	ENDDO
1947	ENDDO
1948	RETURN
1949	END SUBROUTINE all_sub_i
1950
1951	SUBROUTINE all_sub_r ( inbuf , outbuf, &
1952	PS1,PE1,PS2,PE2,PS3,PE3, &
1953	MS1,ME1,MS2,ME2,MS3,ME3 )
1954	USE module_dm
1955	IMPLICIT NONE
1956	REAL , DIMENSION(*) , INTENT(IN) :: inbuf
1957	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
1958	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
1959	REAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
1960	! Local
1961	INTEGER :: i,j,k,n , icurs
1962	icurs = 1
1963	DO k = PS3, PE3
1964	DO j = PS2, PE2
1965	DO i = PS1, PE1
1966	outbuf( i, j, k ) = inbuf ( icurs )
1967	icurs = icurs + 1
1968	ENDDO
1969	ENDDO
1970	ENDDO
1971
1972	RETURN
1973	END SUBROUTINE all_sub_r
1974
1975	SUBROUTINE all_sub_d ( inbuf , outbuf, &
1976	PS1,PE1,PS2,PE2,PS3,PE3, &
1977	MS1,ME1,MS2,ME2,MS3,ME3 )
1978	USE module_dm
1979	IMPLICIT NONE
1980	DOUBLE PRECISION , DIMENSION(*) , INTENT(IN) :: inbuf
1981	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
1982	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
1983	DOUBLE PRECISION , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
1984	! Local
1985	INTEGER :: i,j,k,n , icurs
1986	icurs = 1
1987	DO k = PS3, PE3
1988	DO j = PS2, PE2
1989	DO i = PS1, PE1
1990	outbuf( i, j, k ) = inbuf ( icurs )
1991	icurs = icurs + 1
1992	ENDDO
1993	ENDDO
1994	ENDDO
1995	RETURN
1996	END SUBROUTINE all_sub_d
1997
1998	SUBROUTINE all_sub_l ( inbuf , outbuf, &
1999	PS1,PE1,PS2,PE2,PS3,PE3, &
2000	MS1,ME1,MS2,ME2,MS3,ME3 )
2001	USE module_dm
2002	IMPLICIT NONE
2003	LOGICAL , DIMENSION(*) , INTENT(IN) :: inbuf
2004	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2005	INTEGER PS1,PE1,PS2,PE2,PS3,PE3
2006	LOGICAL , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2007	! Local
2008	INTEGER :: i,j,k,n , icurs
2009	icurs = 1
2010	DO k = PS3, PE3
2011	DO j = PS2, PE2
2012	DO i = PS1, PE1
2013	outbuf( i, j, k ) = inbuf ( icurs )
2014	icurs = icurs + 1
2015	ENDDO
2016	ENDDO
2017	ENDDO
2018	RETURN
2019	END SUBROUTINE all_sub_l
2020
2021
2022	SUBROUTINE outbuf_2_patch_r( inbuf, outbuf, &
2023	DS1,DE1,DS2,DE2,DS3,DE3,&
2024	MS1, ME1, MS2, ME2, MS3, ME3 , &
2025	GPATCH )
2026	USE module_dm
2027	IMPLICIT NONE
2028	REAL , DIMENSION(*) , INTENT(OUT) :: outbuf
2029	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2030	INTEGER MS1,ME1,MS2,ME2,MS3,ME3
2031	REAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2032	! Local
2033	INTEGER :: i,j,k,n , icurs
2034
2035	icurs = 1
2036	DO n = 1, ntasks
2037	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2038	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2039	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2040	outbuf( icurs ) = inbuf( i,j,k )
2041	icurs = icurs + 1
2042	ENDDO
2043	ENDDO
2044	ENDDO
2045	ENDDO
2046	RETURN
2047	END SUBROUTINE outbuf_2_patch_r
2048
2049	SUBROUTINE outbuf_2_patch_i( inbuf, outbuf, &
2050	DS1,DE1,DS2,DE2,DS3,DE3,&
2051	GPATCH )
2052	USE module_dm
2053	IMPLICIT NONE
2054	INTEGER , DIMENSION(*) , INTENT(OUT) :: outbuf
2055	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2056	INTEGER , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2057	! Local
2058	INTEGER :: i,j,k,n , icurs
2059	icurs = 1
2060	DO n = 1, ntasks
2061	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2062	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2063	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2064	outbuf( icurs ) = inbuf( i,j,k )
2065	icurs = icurs + 1
2066	ENDDO
2067	ENDDO
2068	ENDDO
2069	ENDDO
2070	RETURN
2071	END SUBROUTINE outbuf_2_patch_i
2072
2073	SUBROUTINE outbuf_2_patch_d( inbuf, outbuf, &
2074	DS1,DE1,DS2,DE2,DS3,DE3,&
2075	GPATCH )
2076	USE module_dm
2077	IMPLICIT NONE
2078	DOUBLE PRECISION , DIMENSION(*) , INTENT(OUT) :: outbuf
2079	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2080	DOUBLE PRECISION , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2081	! Local
2082	INTEGER :: i,j,k,n , icurs
2083	icurs = 1
2084	DO n = 1, ntasks
2085	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2086	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2087	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2088	outbuf( icurs ) = inbuf( i,j,k )
2089	icurs = icurs + 1
2090	ENDDO
2091	ENDDO
2092	ENDDO
2093	ENDDO
2094	RETURN
2095	END SUBROUTINE outbuf_2_patch_d
2096
2097	SUBROUTINE outbuf_2_patch_l( inbuf, outbuf, &
2098	DS1,DE1,DS2,DE2,DS3,DE3,&
2099	GPATCH )
2100	USE module_dm
2101	IMPLICIT NONE
2102	LOGICAL , DIMENSION(*) , INTENT(OUT) :: outbuf
2103	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2104	LOGICAL , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2105	! Local
2106	INTEGER :: i,j,k,n , icurs
2107	icurs = 1
2108	DO n = 1, ntasks
2109	DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2110	DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2111	DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2112	outbuf( icurs ) = inbuf( i,j,k )
2113	icurs = icurs + 1
2114	ENDDO
2115	ENDDO
2116	ENDDO
2117	ENDDO
2118	RETURN
2119	END SUBROUTINE outbuf_2_patch_l
2120
2121
2122
2123	!------------------------------------------------------------------
2124
2125	#if ( EM_CORE == 1 )
2126
2127	!------------------------------------------------------------------
2128
2129	SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags &
2130	!
2131	#include "em_dummy_new_args.inc"
2132	!
2133	)
2134	USE module_domain
2135	USE module_configure
2136	USE module_dm
2137	IMPLICIT NONE
2138	!
2139	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2140	TYPE(domain), POINTER :: ngrid
2141	#include <em_dummy_new_decl.inc>
2142	INTEGER nlev, msize
2143	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2144	TYPE (grid_config_rec_type) :: config_flags
2145	REAL xv(500)
2146	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2147	cims, cime, cjms, cjme, ckms, ckme, &
2148	cips, cipe, cjps, cjpe, ckps, ckpe
2149	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2150	nims, nime, njms, njme, nkms, nkme, &
2151	nips, nipe, njps, njpe, nkps, nkpe
2152	INTEGER :: ids, ide, jds, jde, kds, kde, &
2153	ims, ime, jms, jme, kms, kme, &
2154	ips, ipe, jps, jpe, kps, kpe
2155
2156	CALL get_ijk_from_grid ( grid , &
2157	cids, cide, cjds, cjde, ckds, ckde, &
2158	cims, cime, cjms, cjme, ckms, ckme, &
2159	cips, cipe, cjps, cjpe, ckps, ckpe )
2160	CALL get_ijk_from_grid ( ngrid , &
2161	nids, nide, njds, njde, nkds, nkde, &
2162	nims, nime, njms, njme, nkms, nkme, &
2163	nips, nipe, njps, njpe, nkps, nkpe )
2164
2165	nlev = ckde - ckds + 1
2166
2167	#include "em_nest_interpdown_unpack.inc"
2168
2169	CALL get_ijk_from_grid ( grid , &
2170	ids, ide, jds, jde, kds, kde, &
2171	ims, ime, jms, jme, kms, kme, &
2172	ips, ipe, jps, jpe, kps, kpe )
2173
2174	#include "HALO_EM_FORCE_DOWN.inc"
2175
2176	! code here to interpolate the data into the nested domain
2177	# include "em_nest_forcedown_interp.inc"
2178
2179	RETURN
2180	END SUBROUTINE force_domain_em_part2
2181
2182	!------------------------------------------------------------------
2183
2184	SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags &
2185	!
2186	#include "em_dummy_new_args.inc"
2187	!
2188	)
2189	USE module_domain
2190	USE module_configure
2191	USE module_dm
2192	USE module_timing
2193	IMPLICIT NONE
2194	!
2195	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2196	TYPE(domain), POINTER :: intermediate_grid
2197	TYPE(domain), POINTER :: ngrid
2198	#include <em_dummy_new_decl.inc>
2199	INTEGER nlev, msize
2200	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2201	INTEGER iparstrt,jparstrt,sw
2202	TYPE (grid_config_rec_type) :: config_flags
2203	REAL xv(500)
2204	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2205	cims, cime, cjms, cjme, ckms, ckme, &
2206	cips, cipe, cjps, cjpe, ckps, ckpe
2207	INTEGER :: iids, iide, ijds, ijde, ikds, ikde, &
2208	iims, iime, ijms, ijme, ikms, ikme, &
2209	iips, iipe, ijps, ijpe, ikps, ikpe
2210	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2211	nims, nime, njms, njme, nkms, nkme, &
2212	nips, nipe, njps, njpe, nkps, nkpe
2213
2214	INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
2215	INTEGER local_comm, myproc, nproc
2216
2217	CALL wrf_get_dm_communicator ( local_comm )
2218	CALL wrf_get_myproc( myproc )
2219	CALL wrf_get_nproc( nproc )
2220
2221	CALL get_ijk_from_grid ( grid , &
2222	cids, cide, cjds, cjde, ckds, ckde, &
2223	cims, cime, cjms, cjme, ckms, ckme, &
2224	cips, cipe, cjps, cjpe, ckps, ckpe )
2225	CALL get_ijk_from_grid ( intermediate_grid , &
2226	iids, iide, ijds, ijde, ikds, ikde, &
2227	iims, iime, ijms, ijme, ikms, ikme, &
2228	iips, iipe, ijps, ijpe, ikps, ikpe )
2229	CALL get_ijk_from_grid ( ngrid , &
2230	nids, nide, njds, njde, nkds, nkde, &
2231	nims, nime, njms, njme, nkms, nkme, &
2232	nips, nipe, njps, njpe, nkps, nkpe )
2233
2234	CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
2235	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
2236	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
2237	CALL nl_get_shw ( intermediate_grid%id, sw )
2238	icoord = iparstrt - sw
2239	jcoord = jparstrt - sw
2240	idim_cd = iide - iids + 1
2241	jdim_cd = ijde - ijds + 1
2242
2243	nlev = ckde - ckds + 1
2244
2245	#include "em_nest_interpdown_pack.inc"
2246
2247	CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
2248
2249	RETURN
2250	END SUBROUTINE interp_domain_em_part1
2251
2252	!------------------------------------------------------------------
2253
2254	SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags &
2255	!
2256	#include "em_dummy_new_args.inc"
2257	!
2258	)
2259	USE module_domain
2260	USE module_configure
2261	USE module_dm
2262	IMPLICIT NONE
2263	!
2264	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2265	TYPE(domain), POINTER :: ngrid
2266	#include <em_dummy_new_decl.inc>
2267	INTEGER nlev, msize
2268	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2269	TYPE (grid_config_rec_type) :: config_flags
2270	REAL xv(500)
2271	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2272	cims, cime, cjms, cjme, ckms, ckme, &
2273	cips, cipe, cjps, cjpe, ckps, ckpe
2274	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2275	nims, nime, njms, njme, nkms, nkme, &
2276	nips, nipe, njps, njpe, nkps, nkpe
2277	INTEGER :: ids, ide, jds, jde, kds, kde, &
2278	ims, ime, jms, jme, kms, kme, &
2279	ips, ipe, jps, jpe, kps, kpe
2280	INTEGER myproc
2281	INTEGER ierr
2282
2283	CALL get_ijk_from_grid ( grid , &
2284	cids, cide, cjds, cjde, ckds, ckde, &
2285	cims, cime, cjms, cjme, ckms, ckme, &
2286	cips, cipe, cjps, cjpe, ckps, ckpe )
2287	CALL get_ijk_from_grid ( ngrid , &
2288	nids, nide, njds, njde, nkds, nkde, &
2289	nims, nime, njms, njme, nkms, nkme, &
2290	nips, nipe, njps, njpe, nkps, nkpe )
2291
2292	nlev = ckde - ckds + 1
2293
2294	#include "em_nest_interpdown_unpack.inc"
2295
2296	CALL get_ijk_from_grid ( grid , &
2297	ids, ide, jds, jde, kds, kde, &
2298	ims, ime, jms, jme, kms, kme, &
2299	ips, ipe, jps, jpe, kps, kpe )
2300
2301	#include "HALO_EM_INTERP_DOWN.inc"
2302
2303	# include "em_nest_interpdown_interp.inc"
2304
2305	RETURN
2306	END SUBROUTINE interp_domain_em_part2
2307
2308	!------------------------------------------------------------------
2309
2310	SUBROUTINE feedback_nest_prep ( grid, config_flags &
2311	!
2312	#include "em_dummy_new_args.inc"
2313	!
2314	)
2315	USE module_domain
2316	USE module_configure
2317	USE module_dm
2318	USE module_state_description
2319	IMPLICIT NONE
2320	!
2321	TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid")
2322	TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
2323	! soil temp, moisture, etc., has vertical dim
2324	! of soil categories
2325	#include <em_dummy_new_decl.inc>
2326
2327	INTEGER :: ids, ide, jds, jde, kds, kde, &
2328	ims, ime, jms, jme, kms, kme, &
2329	ips, ipe, jps, jpe, kps, kpe
2330
2331	INTEGER :: idum1, idum2
2332
2333
2334	CALL get_ijk_from_grid ( grid , &
2335	ids, ide, jds, jde, kds, kde, &
2336	ims, ime, jms, jme, kms, kme, &
2337	ips, ipe, jps, jpe, kps, kpe )
2338
2339	#ifdef DM_PARALLEL
2340	#include "HALO_EM_INTERP_UP.inc"
2341	#endif
2342
2343	END SUBROUTINE feedback_nest_prep
2344
2345	!------------------------------------------------------------------
2346
2347	SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags &
2348	!
2349	#include "em_dummy_new_args.inc"
2350	!
2351	)
2352	USE module_domain
2353	USE module_configure
2354	USE module_dm
2355	IMPLICIT NONE
2356	!
2357	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2358	TYPE(domain), POINTER :: ngrid
2359	#include <em_dummy_new_decl.inc>
2360	INTEGER nlev, msize
2361	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2362	TYPE(domain), POINTER :: xgrid
2363	TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
2364	REAL xv(500)
2365	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2366	cims, cime, cjms, cjme, ckms, ckme, &
2367	cips, cipe, cjps, cjpe, ckps, ckpe
2368	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2369	nims, nime, njms, njme, nkms, nkme, &
2370	nips, nipe, njps, njpe, nkps, nkpe
2371	INTEGER local_comm, myproc, nproc, idum1, idum2
2372
2373	INTERFACE
2374	SUBROUTINE feedback_nest_prep ( grid, config_flags &
2375	!
2376	#include "em_dummy_new_args.inc"
2377	!
2378	)
2379	USE module_domain
2380	USE module_configure
2381	USE module_dm
2382	USE module_state_description
2383	!
2384	TYPE (grid_config_rec_type) :: config_flags
2385	TYPE(domain), TARGET :: grid
2386	#include <em_dummy_new_decl.inc>
2387	END SUBROUTINE feedback_nest_prep
2388	END INTERFACE
2389	!
2390
2391	CALL wrf_get_dm_communicator ( local_comm )
2392	CALL wrf_get_myproc( myproc )
2393	CALL wrf_get_nproc( nproc )
2394
2395	!
2396	! intermediate grid
2397	CALL get_ijk_from_grid ( grid , &
2398	cids, cide, cjds, cjde, ckds, ckde, &
2399	cims, cime, cjms, cjme, ckms, ckme, &
2400	cips, cipe, cjps, cjpe, ckps, ckpe )
2401	! nest grid
2402	CALL get_ijk_from_grid ( ngrid , &
2403	nids, nide, njds, njde, nkds, nkde, &
2404	nims, nime, njms, njme, nkms, nkme, &
2405	nips, nipe, njps, njpe, nkps, nkpe )
2406
2407	nlev = ckde - ckds + 1
2408
2409	ips_save = ngrid%i_parent_start ! used in feedback_domain_em_part2 below
2410	jps_save = ngrid%j_parent_start
2411	ipe_save = ngrid%i_parent_start + (nide-nids+1) / ngrid%parent_grid_ratio - 1
2412	jpe_save = ngrid%j_parent_start + (njde-njds+1) / ngrid%parent_grid_ratio - 1
2413
2414	! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
2415	! in a separate routine because the HALOs need the data to be dereference from the
2416	! grid data structure and, in this routine, the dereferenced fields are related to
2417	! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
2418	! domain, switch grid to point to ngrid, invoke feedback_nest_prep, then restore grid
2419	! to point to intermediate domain.
2420
2421	CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
2422	CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
2423	xgrid => grid
2424	grid => ngrid
2425
2426	CALL feedback_nest_prep ( grid, nconfig_flags &
2427	!
2428	#include "em_actual_new_args.inc"
2429	!
2430	)
2431
2432	! put things back so grid is intermediate grid
2433
2434	grid => xgrid
2435	CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
2436
2437	! "interp" (basically copy) ngrid onto intermediate grid
2438
2439	#include "em_nest_feedbackup_interp.inc"
2440
2441	RETURN
2442	END SUBROUTINE feedback_domain_em_part1
2443
2444	!------------------------------------------------------------------
2445
2446	SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags &
2447	!
2448	#include "em_dummy_new_args.inc"
2449	!
2450	)
2451	USE module_domain
2452	USE module_configure
2453	USE module_dm
2454	USE module_utility
2455	IMPLICIT NONE
2456
2457	!
2458	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2459	TYPE(domain), POINTER :: intermediate_grid
2460	TYPE(domain), POINTER :: ngrid
2461
2462	#include <em_dummy_new_decl.inc>
2463	INTEGER nlev, msize
2464	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2465	TYPE (grid_config_rec_type) :: config_flags
2466	REAL xv(500)
2467	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2468	cims, cime, cjms, cjme, ckms, ckme, &
2469	cips, cipe, cjps, cjpe, ckps, ckpe
2470	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2471	nims, nime, njms, njme, nkms, nkme, &
2472	nips, nipe, njps, njpe, nkps, nkpe
2473	INTEGER :: ids, ide, jds, jde, kds, kde, &
2474	ims, ime, jms, jme, kms, kme, &
2475	ips, ipe, jps, jpe, kps, kpe
2476	INTEGER icoord, jcoord, idim_cd, jdim_cd
2477	INTEGER local_comm, myproc, nproc
2478	INTEGER iparstrt, jparstrt, sw
2479	REAL nest_influence
2480
2481	character*256 :: timestr
2482	integer ierr
2483
2484	LOGICAL, EXTERNAL :: em_cd_feedback_mask
2485
2486	! On entry to this routine,
2487	! "grid" refers to the parent domain
2488	! "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
2489	! "ngrid" refers to the nest, which is only needed for smoothing on the parent because
2490	! the nest feedback data has already been transferred during em_nest_feedbackup_interp
2491	! in part1, above.
2492	! The way these settings c and n dimensions are set, below, looks backwards but from the point
2493	! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
2494	! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
2495	! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
2496	! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
2497	! sign that says "DIP" than fix the dip, at this point it was easier just to write this comment. JM
2498	!
2499	nest_influence = 1.
2500
2501	CALL domain_clock_get( grid, current_timestr=timestr )
2502
2503	CALL get_ijk_from_grid ( intermediate_grid , &
2504	cids, cide, cjds, cjde, ckds, ckde, &
2505	cims, cime, cjms, cjme, ckms, ckme, &
2506	cips, cipe, cjps, cjpe, ckps, ckpe )
2507	CALL get_ijk_from_grid ( grid , &
2508	nids, nide, njds, njde, nkds, nkde, &
2509	nims, nime, njms, njme, nkms, nkme, &
2510	nips, nipe, njps, njpe, nkps, nkpe )
2511
2512	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
2513	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
2514	CALL nl_get_shw ( intermediate_grid%id, sw )
2515	icoord = iparstrt - sw
2516	jcoord = jparstrt - sw
2517	idim_cd = cide - cids + 1
2518	jdim_cd = cjde - cjds + 1
2519
2520	nlev = ckde - ckds + 1
2521
2522	#include "em_nest_feedbackup_pack.inc"
2523
2524	CALL wrf_get_dm_communicator ( local_comm )
2525	CALL wrf_get_myproc( myproc )
2526	CALL wrf_get_nproc( nproc )
2527
2528	CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
2529
2530	#define NEST_INFLUENCE(A,B) A = B
2531	#include "em_nest_feedbackup_unpack.inc"
2532
2533	! smooth coarse grid
2534	CALL get_ijk_from_grid ( ngrid, &
2535	nids, nide, njds, njde, nkds, nkde, &
2536	nims, nime, njms, njme, nkms, nkme, &
2537	nips, nipe, njps, njpe, nkps, nkpe )
2538	CALL get_ijk_from_grid ( grid , &
2539	ids, ide, jds, jde, kds, kde, &
2540	ims, ime, jms, jme, kms, kme, &
2541	ips, ipe, jps, jpe, kps, kpe )
2542
2543	#include "HALO_EM_INTERP_UP.inc"
2544
2545	CALL get_ijk_from_grid ( grid , &
2546	cids, cide, cjds, cjde, ckds, ckde, &
2547	cims, cime, cjms, cjme, ckms, ckme, &
2548	cips, cipe, cjps, cjpe, ckps, ckpe )
2549
2550	#include "em_nest_feedbackup_smooth.inc"
2551
2552	RETURN
2553	END SUBROUTINE feedback_domain_em_part2
2554	#endif
2555
2556	#if ( NMM_CORE == 1 && NMM_NEST == 1 )
2557	!==============================================================================
2558	! NMM nesting infrastructure extended from EM core. This is gopal's doing.
2559	!==============================================================================
2560
2561	SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags &
2562	!
2563	#include "nmm_dummy_args.inc"
2564	!
2565	)
2566	USE module_domain
2567	USE module_configure
2568	USE module_dm
2569	USE module_timing
2570	IMPLICIT NONE
2571	!
2572	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2573	TYPE(domain), POINTER :: intermediate_grid
2574	TYPE(domain), POINTER :: ngrid
2575	#include <nmm_dummy_decl.inc>
2576	INTEGER nlev, msize
2577	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2578	INTEGER iparstrt,jparstrt,sw
2579	TYPE (grid_config_rec_type) :: config_flags
2580	REAL xv(500)
2581	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2582	cims, cime, cjms, cjme, ckms, ckme, &
2583	cips, cipe, cjps, cjpe, ckps, ckpe
2584	INTEGER :: iids, iide, ijds, ijde, ikds, ikde, &
2585	iims, iime, ijms, ijme, ikms, ikme, &
2586	iips, iipe, ijps, ijpe, ikps, ikpe
2587	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2588	nims, nime, njms, njme, nkms, nkme, &
2589	nips, nipe, njps, njpe, nkps, nkpe
2590
2591	INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
2592	INTEGER local_comm, myproc, nproc
2593
2594	CALL wrf_get_dm_communicator ( local_comm )
2595	CALL wrf_get_myproc( myproc )
2596	CALL wrf_get_nproc( nproc )
2597
2598	#define COPY_IN
2599	#include <nmm_scalar_derefs.inc>
2600
2601	CALL get_ijk_from_grid ( grid , &
2602	cids, cide, cjds, cjde, ckds, ckde, &
2603	cims, cime, cjms, cjme, ckms, ckme, &
2604	cips, cipe, cjps, cjpe, ckps, ckpe )
2605	CALL get_ijk_from_grid ( intermediate_grid , &
2606	iids, iide, ijds, ijde, ikds, ikde, &
2607	iims, iime, ijms, ijme, ikms, ikme, &
2608	iips, iipe, ijps, ijpe, ikps, ikpe )
2609	CALL get_ijk_from_grid ( ngrid , &
2610	nids, nide, njds, njde, nkds, nkde, &
2611	nims, nime, njms, njme, nkms, nkme, &
2612	nips, nipe, njps, njpe, nkps, nkpe )
2613
2614	CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
2615	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
2616	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
2617	CALL nl_get_shw ( intermediate_grid%id, sw )
2618	icoord = iparstrt - sw
2619	jcoord = jparstrt - sw
2620	idim_cd = iide - iids + 1
2621	jdim_cd = ijde - ijds + 1
2622
2623	nlev = ckde - ckds + 1
2624
2625	#include "nmm_nest_interpdown_pack.inc"
2626
2627	CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
2628
2629	#define COPY_OUT
2630	#include <nmm_scalar_derefs.inc>
2631	RETURN
2632	END SUBROUTINE interp_domain_nmm_part1
2633
2634	!------------------------------------------------------------------
2635
2636	SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags &
2637	!
2638	#include "nmm_dummy_args.inc"
2639	!
2640	)
2641	USE module_domain
2642	USE module_configure
2643	USE module_dm
2644	IMPLICIT NONE
2645	!
2646	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2647	TYPE(domain), POINTER :: ngrid
2648	#include <nmm_dummy_decl.inc>
2649	INTEGER nlev, msize
2650	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2651	TYPE (grid_config_rec_type) :: config_flags
2652	REAL xv(500)
2653	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2654	cims, cime, cjms, cjme, ckms, ckme, &
2655	cips, cipe, cjps, cjpe, ckps, ckpe
2656	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2657	nims, nime, njms, njme, nkms, nkme, &
2658	nips, nipe, njps, njpe, nkps, nkpe
2659	INTEGER :: ids, ide, jds, jde, kds, kde, &
2660	ims, ime, jms, jme, kms, kme, &
2661	ips, ipe, jps, jpe, kps, kpe
2662	INTEGER myproc
2663	INTEGER ierr
2664
2665	#ifdef DEREF_KLUDGE
2666	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
2667	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
2668	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
2669	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
2670	#endif
2671	#include "deref_kludge.h"
2672
2673	#define COPY_IN
2674	#include <nmm_scalar_derefs.inc>
2675	CALL get_ijk_from_grid ( grid , &
2676	cids, cide, cjds, cjde, ckds, ckde, &
2677	cims, cime, cjms, cjme, ckms, ckme, &
2678	cips, cipe, cjps, cjpe, ckps, ckpe )
2679	CALL get_ijk_from_grid ( ngrid , &
2680	nids, nide, njds, njde, nkds, nkde, &
2681	nims, nime, njms, njme, nkms, nkme, &
2682	nips, nipe, njps, njpe, nkps, nkpe )
2683
2684	nlev = ckde - ckds + 1
2685
2686	#include "nmm_nest_interpdown_unpack.inc"
2687
2688	CALL get_ijk_from_grid ( grid , &
2689	ids, ide, jds, jde, kds, kde, &
2690	ims, ime, jms, jme, kms, kme, &
2691	ips, ipe, jps, jpe, kps, kpe )
2692
2693	#include "HALO_NMM_INTERP_DOWN1.inc"
2694
2695	#include "nmm_nest_interpdown_interp.inc"
2696
2697	#define COPY_OUT
2698	#include <nmm_scalar_derefs.inc>
2699
2700	RETURN
2701	END SUBROUTINE interp_domain_nmm_part2
2702
2703	!------------------------------------------------------------------
2704
2705	SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags &
2706	!
2707	#include "nmm_dummy_args.inc"
2708	!
2709	)
2710	USE module_domain
2711	USE module_configure
2712	USE module_dm
2713	USE module_timing
2714	!
2715	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2716	TYPE(domain), POINTER :: intermediate_grid
2717	#include <nmm_dummy_decl.inc>
2718	INTEGER nlev, msize
2719	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2720	TYPE (grid_config_rec_type) :: config_flags
2721	REAL xv(500)
2722	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2723	cims, cime, cjms, cjme, ckms, ckme, &
2724	cips, cipe, cjps, cjpe, ckps, ckpe
2725	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2726	nims, nime, njms, njme, nkms, nkme, &
2727	nips, nipe, njps, njpe, nkps, nkpe
2728	#define COPY_IN
2729	#include <nmm_scalar_derefs.inc>
2730	!
2731	CALL get_ijk_from_grid ( grid , &
2732	cids, cide, cjds, cjde, ckds, ckde, &
2733	cims, cime, cjms, cjme, ckms, ckme, &
2734	cips, cipe, cjps, cjpe, ckps, ckpe )
2735
2736	CALL get_ijk_from_grid ( intermediate_grid , &
2737	nids, nide, njds, njde, nkds, nkde, &
2738	nims, nime, njms, njme, nkms, nkme, &
2739	nips, nipe, njps, njpe, nkps, nkpe )
2740
2741	nlev = ckde - ckds + 1
2742
2743	#include "nmm_nest_forcedown_pack.inc"
2744
2745	! WRITE(0,*)'I have completed PACKING of BCs data successfully'
2746
2747	#define COPY_OUT
2748	#include <nmm_scalar_derefs.inc>
2749	RETURN
2750	END SUBROUTINE force_domain_nmm_part1
2751
2752	!==============================================================================================
2753
2754	SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags &
2755	!
2756	#include "nmm_dummy_args.inc"
2757	!
2758	)
2759	USE module_domain
2760	USE module_configure
2761	USE module_dm
2762	IMPLICIT NONE
2763	!
2764	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2765	TYPE(domain), POINTER :: ngrid
2766	#include <nmm_dummy_decl.inc>
2767	INTEGER nlev, msize
2768	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2769	TYPE (grid_config_rec_type) :: config_flags
2770	REAL xv(500)
2771	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2772	cims, cime, cjms, cjme, ckms, ckme, &
2773	cips, cipe, cjps, cjpe, ckps, ckpe
2774	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2775	nims, nime, njms, njme, nkms, nkme, &
2776	nips, nipe, njps, njpe, nkps, nkpe
2777	INTEGER :: ids, ide, jds, jde, kds, kde, &
2778	ims, ime, jms, jme, kms, kme, &
2779	ips, ipe, jps, jpe, kps, kpe
2780	integer myproc
2781
2782	#ifdef DEREF_KLUDGE
2783	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
2784	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
2785	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
2786	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
2787	#endif
2788	#include "deref_kludge.h"
2789
2790	#define COPY_IN
2791	#include <nmm_scalar_derefs.inc>
2792
2793	CALL get_ijk_from_grid ( grid , &
2794	cids, cide, cjds, cjde, ckds, ckde, &
2795	cims, cime, cjms, cjme, ckms, ckme, &
2796	cips, cipe, cjps, cjpe, ckps, ckpe )
2797	CALL get_ijk_from_grid ( ngrid , &
2798	nids, nide, njds, njde, nkds, nkde, &
2799	nims, nime, njms, njme, nkms, nkme, &
2800	nips, nipe, njps, njpe, nkps, nkpe )
2801
2802	nlev = ckde - ckds + 1
2803
2804	#include "nmm_nest_interpdown_unpack.inc"
2805
2806	CALL get_ijk_from_grid ( grid , &
2807	ids, ide, jds, jde, kds, kde, &
2808	ims, ime, jms, jme, kms, kme, &
2809	ips, ipe, jps, jpe, kps, kpe )
2810
2811	#include "HALO_NMM_FORCE_DOWN1.inc"
2812
2813	! code here to interpolate the data into the nested domain
2814	#include "nmm_nest_forcedown_interp.inc"
2815
2816	#define COPY_OUT
2817	#include <nmm_scalar_derefs.inc>
2818
2819	RETURN
2820	END SUBROUTINE force_domain_nmm_part2
2821
2822	!================================================================================
2823	!
2824	! This routine exists only to call a halo on a domain (the nest)
2825	! gets called from feedback_domain_em_part1, below. This is needed
2826	! because the halo code expects the fields being exchanged to have
2827	! been dereferenced from the grid data structure, but in feedback_domain_em_part1
2828	! the grid data structure points to the coarse domain, not the nest.
2829	! And we want the halo exchange on the nest, so that the code in
2830	! em_nest_feedbackup_interp.inc will work correctly on multi-p. JM 20040308
2831	!
2832
2833	SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags &
2834	!
2835	#include "nmm_dummy_args.inc"
2836	!
2837	)
2838	USE module_domain
2839	USE module_configure
2840	USE module_dm
2841	USE module_state_description
2842	IMPLICIT NONE
2843	!
2844	TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid")
2845	TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
2846	! soil temp, moisture, etc., has vertical dim
2847	! of soil categories
2848	#include <nmm_dummy_decl.inc>
2849
2850	INTEGER :: ids, ide, jds, jde, kds, kde, &
2851	ims, ime, jms, jme, kms, kme, &
2852	ips, ipe, jps, jpe, kps, kpe
2853
2854	INTEGER :: idum1, idum2
2855
2856
2857	#ifdef DEREF_KLUDGE
2858	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
2859	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
2860	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
2861	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
2862	#endif
2863	#include "deref_kludge.h"
2864
2865	#define COPY_IN
2866	#include <nmm_scalar_derefs.inc>
2867
2868	CALL get_ijk_from_grid ( grid , &
2869	ids, ide, jds, jde, kds, kde, &
2870	ims, ime, jms, jme, kms, kme, &
2871	ips, ipe, jps, jpe, kps, kpe )
2872
2873	#ifdef DM_PARALLEL
2874	#include "HALO_NMM_WEIGHTS.inc"
2875	#endif
2876
2877	#define COPY_OUT
2878	#include <nmm_scalar_derefs.inc>
2879
2880	END SUBROUTINE feedback_nest_prep_nmm
2881
2882	!------------------------------------------------------------------
2883
2884	SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags &
2885	!
2886	#include "nmm_dummy_args.inc"
2887	!
2888	)
2889	USE module_domain
2890	USE module_configure
2891	USE module_dm
2892	IMPLICIT NONE
2893	!
2894	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
2895	TYPE(domain), POINTER :: ngrid
2896	#include <nmm_dummy_decl.inc>
2897	INTEGER nlev, msize
2898	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
2899	TYPE(domain), POINTER :: xgrid
2900	TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
2901	REAL xv(500)
2902	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
2903	cims, cime, cjms, cjme, ckms, ckme, &
2904	cips, cipe, cjps, cjpe, ckps, ckpe
2905	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
2906	nims, nime, njms, njme, nkms, nkme, &
2907	nips, nipe, njps, njpe, nkps, nkpe
2908	INTEGER local_comm, myproc, nproc, idum1, idum2
2909
2910	#ifdef DEREF_KLUDGE
2911	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
2912	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
2913	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
2914	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
2915	#endif
2916
2917	INTERFACE
2918	SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags &
2919	!
2920	#include "nmm_dummy_args.inc"
2921	!
2922	)
2923	USE module_domain
2924	USE module_configure
2925	USE module_dm
2926	USE module_state_description
2927	!
2928	TYPE (grid_config_rec_type) :: config_flags
2929	TYPE(domain), TARGET :: grid
2930	#include <nmm_dummy_decl.inc>
2931	END SUBROUTINE feedback_nest_prep_nmm
2932	END INTERFACE
2933	!
2934	#define COPY_IN
2935	#include <nmm_scalar_derefs.inc>
2936
2937	CALL wrf_get_dm_communicator ( local_comm )
2938	CALL wrf_get_myproc( myproc )
2939	CALL wrf_get_nproc( nproc )
2940
2941
2942	!
2943	! intermediate grid
2944	CALL get_ijk_from_grid ( grid , &
2945	cids, cide, cjds, cjde, ckds, ckde, &
2946	cims, cime, cjms, cjme, ckms, ckme, &
2947	cips, cipe, cjps, cjpe, ckps, ckpe )
2948	! nest grid
2949	CALL get_ijk_from_grid ( ngrid , &
2950	nids, nide, njds, njde, nkds, nkde, &
2951	nims, nime, njms, njme, nkms, nkme, &
2952	nips, nipe, njps, njpe, nkps, nkpe )
2953
2954	nlev = ckde - ckds + 1
2955
2956	ips_save = ngrid%i_parent_start ! +1 not used in ipe_save & jpe_save
2957	jps_save = ngrid%j_parent_start ! because of one extra namelist point
2958	ipe_save = ngrid%i_parent_start + (nide-nids) / ngrid%parent_grid_ratio
2959	jpe_save = ngrid%j_parent_start + (njde-njds) / ngrid%parent_grid_ratio
2960
2961	! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
2962	! in a separate routine because the HALOs need the data to be dereference from the
2963	! grid data structure and, in this routine, the dereferenced fields are related to
2964	! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
2965	! domain, switch grid to point to ngrid, invoke feedback_nest_prep, then restore grid
2966	! to point to intermediate domain.
2967
2968	CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
2969	CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
2970	xgrid => grid
2971	grid => ngrid
2972	#include "deref_kludge.h"
2973	CALL feedback_nest_prep_nmm ( grid, config_flags &
2974	!
2975	#include "nmm_actual_args.inc"
2976	!
2977	)
2978
2979	! put things back so grid is intermediate grid
2980
2981	grid => xgrid
2982	CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
2983
2984	! "interp" (basically copy) ngrid onto intermediate grid
2985
2986	#include "nmm_nest_feedbackup_interp.inc"
2987
2988	#define COPY_OUT
2989	#include <nmm_scalar_derefs.inc>
2990	RETURN
2991	END SUBROUTINE feedback_domain_nmm_part1
2992
2993	!------------------------------------------------------------------
2994
2995	SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags &
2996	!
2997	#include "nmm_dummy_args.inc"
2998	!
2999	)
3000	USE module_domain
3001	USE module_configure
3002	USE module_dm
3003	USE module_utility
3004	IMPLICIT NONE
3005
3006	!
3007	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
3008	TYPE(domain), POINTER :: intermediate_grid
3009	TYPE(domain), POINTER :: ngrid
3010
3011	#include <nmm_dummy_decl.inc>
3012	INTEGER nlev, msize
3013	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3014	TYPE (grid_config_rec_type) :: config_flags
3015	REAL xv(500)
3016	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
3017	cims, cime, cjms, cjme, ckms, ckme, &
3018	cips, cipe, cjps, cjpe, ckps, ckpe
3019	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
3020	nims, nime, njms, njme, nkms, nkme, &
3021	nips, nipe, njps, njpe, nkps, nkpe
3022	INTEGER :: ids, ide, jds, jde, kds, kde, &
3023	ims, ime, jms, jme, kms, kme, &
3024	ips, ipe, jps, jpe, kps, kpe
3025	INTEGER icoord, jcoord, idim_cd, jdim_cd
3026	INTEGER local_comm, myproc, nproc
3027	INTEGER iparstrt, jparstrt, sw
3028
3029	character*256 :: timestr
3030	integer ierr
3031
3032	REAL nest_influence
3033	LOGICAL, EXTERNAL :: nmm_cd_feedback_mask
3034	#ifdef DEREF_KLUDGE
3035	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3036	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
3037	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3038	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3039	#endif
3040	#include "deref_kludge.h"
3041
3042	#define COPY_IN
3043	#include <nmm_scalar_derefs.inc>
3044
3045	! On entry to this routine,
3046	! "grid" refers to the parent domain
3047	! "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
3048	! "ngrid" refers to the nest, which is only needed for smoothing on the parent because
3049	! the nest feedback data has already been transferred during em_nest_feedbackup_interp
3050	! in part1, above.
3051	! The way these settings c and n dimensions are set, below, looks backwards but from the point
3052	! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
3053	! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
3054	! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
3055	! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
3056	! sign that says "DIP" than fix the dip, at this point it was easier just to write this comment. JM
3057	!
3058
3059	nest_influence = 0.5
3060	#define NEST_INFLUENCE(A,B) A = nest_influence(B) + (1.0-nest_influence)(A)
3061
3062
3063	CALL domain_clock_get( grid, current_timestr=timestr )
3064
3065	CALL get_ijk_from_grid ( intermediate_grid , &
3066	cids, cide, cjds, cjde, ckds, ckde, &
3067	cims, cime, cjms, cjme, ckms, ckme, &
3068	cips, cipe, cjps, cjpe, ckps, ckpe )
3069	CALL get_ijk_from_grid ( grid , &
3070	nids, nide, njds, njde, nkds, nkde, &
3071	nims, nime, njms, njme, nkms, nkme, &
3072	nips, nipe, njps, njpe, nkps, nkpe )
3073
3074	nide = nide - 1 !dusan
3075	njde = njde - 1 !dusan
3076
3077	CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
3078	CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
3079	CALL nl_get_shw ( intermediate_grid%id, sw )
3080	icoord = iparstrt - sw
3081	jcoord = jparstrt - sw
3082	idim_cd = cide - cids + 1
3083	jdim_cd = cjde - cjds + 1
3084
3085	nlev = ckde - ckds + 1
3086
3087	#include "nmm_nest_feedbackup_pack.inc"
3088
3089	CALL wrf_get_dm_communicator ( local_comm )
3090	CALL wrf_get_myproc( myproc )
3091	CALL wrf_get_nproc( nproc )
3092
3093	CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
3094
3095	#include "nmm_nest_feedbackup_unpack.inc"
3096
3097
3098	! smooth coarse grid
3099
3100	CALL get_ijk_from_grid ( ngrid, &
3101	nids, nide, njds, njde, nkds, nkde, &
3102	nims, nime, njms, njme, nkms, nkme, &
3103	nips, nipe, njps, njpe, nkps, nkpe )
3104	CALL get_ijk_from_grid ( grid , &
3105	ids, ide, jds, jde, kds, kde, &
3106	ims, ime, jms, jme, kms, kme, &
3107	ips, ipe, jps, jpe, kps, kpe )
3108
3109	#include "HALO_NMM_INTERP_UP.inc"
3110
3111	CALL get_ijk_from_grid ( grid , &
3112	cids, cide, cjds, cjde, ckds, ckde, &
3113	cims, cime, cjms, cjme, ckms, ckme, &
3114	cips, cipe, cjps, cjpe, ckps, ckpe )
3115
3116	#include "nmm_nest_feedbackup_smooth.inc"
3117
3118	#define COPY_OUT
3119	#include <nmm_scalar_derefs.inc>
3120	RETURN
3121	END SUBROUTINE feedback_domain_nmm_part2
3122
3123	!=================================================================================
3124	! End of gopal's doing
3125	!=================================================================================
3126	#endif
3127
3128	!------------------------------------------------------------------
3129
3130	SUBROUTINE wrf_gatherv_real (Field, field_ofst, &
3131	my_count , & ! sendcount
3132	globbuf, glob_ofst , & ! recvbuf
3133	counts , & ! recvcounts
3134	displs , & ! displs
3135	root , & ! root
3136	communicator , & ! communicator
3137	ierr )
3138	USE module_dm
3139	IMPLICIT NONE
3140	INCLUDE 'mpif.h'
3141	INTEGER field_ofst, glob_ofst
3142	INTEGER my_count, communicator, root, ierr
3143	INTEGER , DIMENSION(*) :: counts, displs
3144	REAL, DIMENSION(*) :: Field, globbuf
3145
3146	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
3147	my_count , & ! sendcount
3148	getrealmpitype() , & ! sendtype
3149	globbuf( glob_ofst ) , & ! recvbuf
3150	counts , & ! recvcounts
3151	displs , & ! displs
3152	getrealmpitype() , & ! recvtype
3153	root , & ! root
3154	communicator , & ! communicator
3155	ierr )
3156
3157	END SUBROUTINE wrf_gatherv_real
3158
3159	SUBROUTINE wrf_gatherv_double (Field, field_ofst, &
3160	my_count , & ! sendcount
3161	globbuf, glob_ofst , & ! recvbuf
3162	counts , & ! recvcounts
3163	displs , & ! displs
3164	root , & ! root
3165	communicator , & ! communicator
3166	ierr )
3167	USE module_dm
3168	IMPLICIT NONE
3169	INCLUDE 'mpif.h'
3170	INTEGER field_ofst, glob_ofst
3171	INTEGER my_count, communicator, root, ierr
3172	INTEGER , DIMENSION(*) :: counts, displs
3173	DOUBLE PRECISION, DIMENSION(*) :: Field, globbuf
3174
3175	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
3176	my_count , & ! sendcount
3177	MPI_DOUBLE_PRECISION , & ! sendtype
3178	globbuf( glob_ofst ) , & ! recvbuf
3179	counts , & ! recvcounts
3180	displs , & ! displs
3181	MPI_DOUBLE_PRECISION , & ! recvtype
3182	root , & ! root
3183	communicator , & ! communicator
3184	ierr )
3185
3186	END SUBROUTINE wrf_gatherv_double
3187
3188	SUBROUTINE wrf_gatherv_integer (Field, field_ofst, &
3189	my_count , & ! sendcount
3190	globbuf, glob_ofst , & ! recvbuf
3191	counts , & ! recvcounts
3192	displs , & ! displs
3193	root , & ! root
3194	communicator , & ! communicator
3195	ierr )
3196	IMPLICIT NONE
3197	INCLUDE 'mpif.h'
3198	INTEGER field_ofst, glob_ofst
3199	INTEGER my_count, communicator, root, ierr
3200	INTEGER , DIMENSION(*) :: counts, displs
3201	INTEGER, DIMENSION(*) :: Field, globbuf
3202
3203	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
3204	my_count , & ! sendcount
3205	MPI_INTEGER , & ! sendtype
3206	globbuf( glob_ofst ) , & ! recvbuf
3207	counts , & ! recvcounts
3208	displs , & ! displs
3209	MPI_INTEGER , & ! recvtype
3210	root , & ! root
3211	communicator , & ! communicator
3212	ierr )
3213
3214	END SUBROUTINE wrf_gatherv_integer
3215
3216	SUBROUTINE wrf_dm_define_comms ( grid )
3217	USE module_domain
3218	IMPLICIT NONE
3219	TYPE(domain) , INTENT (INOUT) :: grid
3220	RETURN
3221	END SUBROUTINE wrf_dm_define_comms
3222
3223	SUBROUTINE set_dm_debug
3224	USE module_dm
3225	IMPLICIT NONE
3226	dm_debug_flag = .TRUE.
3227	END SUBROUTINE set_dm_debug
3228	SUBROUTINE reset_dm_debug
3229	USE module_dm
3230	IMPLICIT NONE
3231	dm_debug_flag = .FALSE.
3232	END SUBROUTINE reset_dm_debug
3233	SUBROUTINE get_dm_debug ( arg )
3234	USE module_dm
3235	IMPLICIT NONE
3236	LOGICAL arg
3237	arg = dm_debug_flag
3238	END SUBROUTINE get_dm_debug

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

Download in other formats:

Original Format