Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_dm.F @ 650

Last change on this file since 650 was 1, checked in by lfita, 11 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 172.1 KB

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

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

Download in other formats:

Original Format