Context Navigation

module_dm.F

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

Line
1	!WRF:PACKAGE:RSL
2	!
3	MODULE module_dm
4
5	USE module_machine
6	USE module_configure
7	USE module_state_description
8	USE module_wrf_error
9
10	#include "rsl.inc"
11
12	INTEGER msg_z, msg_x, msg_y
13	INTEGER msg,messages(168)
14	INTEGER invalid_message_value
15	INTEGER x_period_flag, y_period_flag
16	INTEGER msg_msg
17	INTEGER &
18	n5w5 ,n5w4 ,n5w3 ,n5w2 ,n5w ,n5 ,n5e ,n5e2 ,n5e3 ,n5e4 ,n5e5 &
19	,n4w5 ,n4w4 ,n4w3 ,n4w2 ,n4w ,n4 ,n4e ,n4e2 ,n4e3 ,n4e4 ,n4e5 &
20	,n3w5 ,n3w4 ,n3w3 ,n3w2 ,n3w ,n3 ,n3e ,n3e2 ,n3e3 ,n3e4 ,n3e5 &
21	,n2w5 ,n2w4 ,n2w3 ,n2w2 ,n2w ,n2 ,n2e ,n2e2 ,n2e3 ,n2e4 ,n2e5 &
22	,nw5 ,nw4 ,nw3 ,nw2 ,nw ,n1 ,ne ,ne2 ,ne3 ,ne4 ,ne5 &
23	,w5 ,w4 ,w3 ,w2 ,w1 ,e1 ,e2 ,e3 ,e4 ,e5 &
24	,sw5 ,sw4 ,sw3 ,sw2 ,sw ,s1 ,se ,se2 ,se3 ,se4 ,se5 &
25	,s2w5 ,s2w4 ,s2w3 ,s2w2 ,s2w ,s2 ,s2e ,s2e2 ,s2e3 ,s2e4 ,s2e5 &
26	,s3w5 ,s3w4 ,s3w3 ,s3w2 ,s3w ,s3 ,s3e ,s3e2 ,s3e3 ,s3e4 ,s3e5 &
27	,s4w5 ,s4w4 ,s4w3 ,s4w2 ,s4w ,s4 ,s4e ,s4e2 ,s4e3 ,s4e4 ,s4e5 &
28	,s5w5 ,s5w4 ,s5w3 ,s5w2 ,s5w ,s5 ,s5e ,s5e2 ,s5e3 ,s5e4 ,s5e5
29	INTEGER glen(3), llen(3), decomp(3), decompx(3), decompy(3), decompxy(3)
30	INTEGER glen2d(2), llen2d(2), decomp2d(2), decompx2d(2), decompy2d(2), decompxy2d(2)
31	INTEGER glenx(3), gleny(3), glenxy(3)
32	INTEGER llenx(3), lleny(3), llenxy(3)
33	INTEGER glenx2d(2), gleny2d(2), glenxy2d(2)
34	INTEGER llenx2d(2), lleny2d(2), llenxy2d(2)
35	INTEGER llen_tx(3)
36	INTEGER llen_ty(3)
37	INTEGER ips_save, jps_save
38	INTEGER ipe_save, jpe_save
39	INTEGER, PRIVATE :: mpi_comm_local
40	INTEGER, PRIVATE :: nproc_lt, nproc_ln
41
42	#if ( RWORDSIZE != DWORDSIZE )
43	INTERFACE add_msg_period
44	MODULE PROCEDURE add_msg_period_real, add_msg_period_integer, add_msg_period_doubleprecision
45	END INTERFACE
46	INTERFACE add_msg_xpose
47	MODULE PROCEDURE add_msg_xpose_real, add_msg_xpose_integer, add_msg_xpose_doubleprecision
48	END INTERFACE
49	INTERFACE add_msg_4pt
50	MODULE PROCEDURE add_msg_4pt_real, add_msg_4pt_integer, add_msg_4pt_doubleprecision
51	END INTERFACE
52	INTERFACE add_msg_8pt
53	MODULE PROCEDURE add_msg_8pt_real, add_msg_8pt_integer, add_msg_8pt_doubleprecision
54	END INTERFACE
55	INTERFACE add_msg_12pt
56	MODULE PROCEDURE add_msg_12pt_real, add_msg_12pt_integer, add_msg_12pt_doubleprecision
57	END INTERFACE
58	INTERFACE add_msg_24pt
59	MODULE PROCEDURE add_msg_24pt_real, add_msg_24pt_integer, add_msg_24pt_doubleprecision
60	END INTERFACE
61	INTERFACE add_msg_48pt
62	MODULE PROCEDURE add_msg_48pt_real, add_msg_48pt_integer, add_msg_48pt_doubleprecision
63	END INTERFACE
64	INTERFACE add_msg_80pt
65	MODULE PROCEDURE add_msg_80pt_real, add_msg_80pt_integer, add_msg_80pt_doubleprecision
66	END INTERFACE
67	INTERFACE add_msg_120pt
68	MODULE PROCEDURE add_msg_120pt_real, add_msg_120pt_integer, add_msg_120pt_doubleprecision
69	END INTERFACE
70	INTERFACE wrf_dm_maxval
71	MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision
72	END INTERFACE
73	INTERFACE wrf_dm_minval
74	MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision
75	END INTERFACE
76
77	#define TRUE_RSL_REAL RSL_REAL
78	#define TRUE_RSL_REAL_F90 RSL_REAL_F90
79	#else
80	INTERFACE add_msg_period
81	MODULE PROCEDURE add_msg_period_real, add_msg_period_integer
82	END INTERFACE
83	INTERFACE add_msg_xpose
84	MODULE PROCEDURE add_msg_xpose_real, add_msg_xpose_integer
85	END INTERFACE
86	INTERFACE add_msg_4pt
87	MODULE PROCEDURE add_msg_4pt_real, add_msg_4pt_integer
88	END INTERFACE
89	INTERFACE add_msg_8pt
90	MODULE PROCEDURE add_msg_8pt_real, add_msg_8pt_integer
91	END INTERFACE
92	INTERFACE add_msg_12pt
93	MODULE PROCEDURE add_msg_12pt_real, add_msg_12pt_integer
94	END INTERFACE
95	INTERFACE add_msg_24pt
96	MODULE PROCEDURE add_msg_24pt_real, add_msg_24pt_integer
97	END INTERFACE
98	INTERFACE add_msg_48pt
99	MODULE PROCEDURE add_msg_48pt_real, add_msg_48pt_integer
100	END INTERFACE
101	INTERFACE add_msg_80pt
102	MODULE PROCEDURE add_msg_80pt_real, add_msg_80pt_integer
103	END INTERFACE
104	INTERFACE add_msg_120pt
105	MODULE PROCEDURE add_msg_120pt_real, add_msg_120pt_integer
106	END INTERFACE
107	INTERFACE wrf_dm_maxval
108	MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer
109	END INTERFACE
110	INTERFACE wrf_dm_minval
111	MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer
112	END INTERFACE
113
114	#define TRUE_RSL_REAL RSL_DOUBLE
115	#define TRUE_RSL_REAL_F90 RSL_DOUBLE_F90
116	#endif
117
118	CONTAINS
119
120	SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N )
121
122	! <DESCRIPTION>
123	! This is a routine provided by the rsl external comm layer.
124	! and is defined in external/RSL/module_dm.F, which is copied
125	! into frame/module_dm.F at compile time. Changes to frame/module_dm.F
126	! will be lost.
127	!
128	! Given a total number of tasks, P, work out a two-dimensional mesh of
129	! processors that is MINM processors in the M dimension and MINN
130	! processors in the N dimension. The algorithm attempts to find two
131	! numbers that divide the total number of processors without a remainder.
132	! The best it might do, sometimes, is 1 and P. It attempts to divide
133	! the M dimension over the smaller number.
134	!
135	! The PROCMIN arguments are a holdover from MM5. The represent the
136	! minimum number of processors the algorithm is allowed to use for M and
137	! N. This is a holdover from MM5 which had static (compile-time) array
138	! sizes ; PROCMIN_M and PROCMIN_N should always be 1 in WRF.
139	!
140	! </DESCRIPTION>
141
142	INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N
143	MINI = 2*P
144	MINM = 1
145	MINN = P
146	DO M = 1, P
147	IF ( MOD( P, M ) .EQ. 0 ) THEN
148	N = P / M
149	IF ( ABS(M-N) .LT. MINI &
150	.AND. M .GE. PROCMIN_M &
151	.AND. N .GE. PROCMIN_N &
152	) THEN
153	MINI = ABS(M-N)
154	MINM = M
155	MINN = N
156	ENDIF
157	ENDIF
158	ENDDO
159	IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN
160	WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH. STOPPING.'
161	CALL wrf_message ( TRIM ( wrf_err_message ) )
162	WRITE(0,*)' PROCMIN_M ', PROCMIN_M
163	WRITE( wrf_err_message , * )' PROCMIN_M ', PROCMIN_M
164	CALL wrf_message ( TRIM ( wrf_err_message ) )
165	WRITE( wrf_err_message , * )' PROCMIN_N ', PROCMIN_N
166	CALL wrf_message ( TRIM ( wrf_err_message ) )
167	WRITE( wrf_err_message , * )' P ', P
168	CALL wrf_message ( TRIM ( wrf_err_message ) )
169	WRITE( wrf_err_message , * )' MINM ', MINM
170	CALL wrf_message ( TRIM ( wrf_err_message ) )
171	WRITE( wrf_err_message , * )' MINN ', MINN
172	CALL wrf_message ( TRIM ( wrf_err_message ) )
173	CALL wrf_error_fatal ( 'module_dm: mpaspect' )
174	ENDIF
175	RETURN
176	END SUBROUTINE MPASPECT
177
178
179	SUBROUTINE wrf_dm_initialize
180	! <DESCRIPTION>
181	! This is a routine provided by the RSL external comm layer.
182	! and is defined in external/RSL/module_dm.F, which is copied
183	! into frame/module_dm.F at compile time. Changes to frame/module_dm.F
184	! will be lost.
185	!
186	! This routine is used to complete initialization the rsl external comm
187	! layer, once the namelist.input file has been read-in and broadcast to
188	! all the tasks. It must be called <em>after</em> the call to <a
189	! href=init_module_dm.html>init_module_dm</a>.
190	!
191	! Wrf_dm_initialize calls RSL_SET_REGULAR_DECOMP to set up a regular
192	! domain decompostion (subdomains will be rectangular) and then looks to
193	! see if the namelist variables nproc_x and nproc_y have been set. If
194	! these have been set it uses these to map the MPI tasks to a
195	! two-dimensional processor mesh. Otherwise, it uses the <a
196	! href=mpaspect.html>mpaspect</a> routine to compute the mesh. The
197	! dimensions of the mesh are then provided to rsl with call to RSL_MESH.
198	!
199	! The WRF EM core uses the default pad area (the area of extra memory
200	! that will be allocated around each local processor subdomain). The
201	! default, defined in external/RSL/RSL/rsl.h, is 4. Other dycores, such
202	! as NMM, may need a different size. A non-default pad area is set in
203	! rsl using a call to RSL_SET_PADAREA.
204	!
205	! </DESCRIPTION>
206	CALL RSL_SET_REGULAR_DECOMP
207	CALL nl_get_nproc_x ( 1, nproc_ln )
208	CALL nl_get_nproc_y ( 1, nproc_lt )
209	! check if user has specified in the namelist
210	IF ( nproc_ln .GT. 0 .OR. nproc_lt .GT. 0 ) THEN
211	! if only nproc_ln is specified then make it 1-d decomp in i
212	IF ( nproc_ln .GT. 0 .AND. nproc_lt .EQ. -1 ) THEN
213	nproc_lt = rsl_nproc / nproc_ln
214	! if only nproc_lt is specified then make it 1-d decomp in j
215	ELSE IF ( nproc_ln .EQ. -1 .AND. nproc_lt .GT. 0 ) THEN
216	nproc_ln = rsl_nproc / nproc_lt
217	ENDIF
218	! make sure user knows what they're doing
219	IF ( nproc_ln * nproc_lt .NE. rsl_nproc ) THEN
220	WRITE( wrf_err_message , * )'WRF_DM_INITIALIZE (RSL): nproc_x * nproc_y in namelist ne ',rsl_nproc
221	CALL wrf_error_fatal ( wrf_err_message )
222	ENDIF
223	ELSE
224	! When neither is specified, work out mesh with MPASPECT
225	! Pass nproc_ln and nproc_nt so that number of procs in
226	! i-dim (nproc_ln) is equal or lesser.
227	CALL mpaspect( rsl_nproc , nproc_ln , nproc_lt , 1 , 1 )
228	ENDIF
229	! X Y
230	CALL RSL_MESH( nproc_ln, nproc_lt )
231	#ifdef NMM_CORE
232	CALL rsl_set_padarea ( 6 )
233	#endif
234	CALL nl_set_nproc_x ( 1, nproc_ln )
235	CALL nl_set_nproc_y ( 1, nproc_lt )
236	invalid_message_value = RSL_INVALID
237	x_period_flag = RSL_M
238	y_period_flag = RSL_N
239	RETURN
240	END SUBROUTINE wrf_dm_initialize
241
242	! period additions, 200505
243
244	SUBROUTINE reset_period
245	IMPLICIT NONE
246	CALL rsl_create_message ( msg )
247	END SUBROUTINE reset_period
248
249	SUBROUTINE add_msg_period_real( fld, kdim )
250	IMPLICIT NONE
251	integer kdim, gl(3), ll(3)
252	real fld(*)
253	SELECT CASE ( model_data_order )
254	! need to finish other cases
255	CASE ( DATA_ORDER_XZY )
256	gl(1) = glen(1) ; ll(1) = llen(1)
257	gl(2) = kdim ; ll(2) = kdim
258	gl(3) = glen(3) ; ll(3) = llen(3)
259	CASE ( DATA_ORDER_XYZ )
260	gl(1) = glen(1) ; ll(1) = llen(1)
261	gl(2) = glen(2) ; ll(2) = llen(2)
262	gl(3) = kdim ; ll(3) = kdim
263	CASE DEFAULT
264	END SELECT
265	if ( kdim > 1 ) then
266	CALL rsl_build_message(msg,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
267	else if ( kdim == 1 ) then
268	CALL rsl_build_message(msg,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
269	endif
270	END SUBROUTINE add_msg_period_real
271
272	SUBROUTINE add_msg_period_integer( fld, kdim )
273	IMPLICIT NONE
274	integer kdim, gl(3), ll(3)
275	integer fld(*)
276	SELECT CASE ( model_data_order )
277	! need to finish other cases
278	CASE ( DATA_ORDER_XZY )
279	gl(1) = glen(1) ; ll(1) = llen(1)
280	gl(2) = kdim ; ll(2) = kdim
281	gl(3) = glen(3) ; ll(3) = llen(3)
282	CASE ( DATA_ORDER_XYZ )
283	gl(1) = glen(1) ; ll(1) = llen(1)
284	gl(2) = glen(2) ; ll(2) = llen(2)
285	gl(3) = kdim ; ll(3) = kdim
286	CASE DEFAULT
287	END SELECT
288	if ( kdim > 1 ) then
289	CALL rsl_build_message(msg,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
290	else if ( kdim == 1 ) then
291	CALL rsl_build_message(msg,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
292	endif
293	END SUBROUTINE add_msg_period_integer
294
295	#if ( RWORDSIZE != DWORDSIZE )
296	SUBROUTINE add_msg_period_doubleprecision( fld, kdim )
297	IMPLICIT NONE
298	integer kdim, gl(3), ll(3)
299	doubleprecision fld(*)
300	SELECT CASE ( model_data_order )
301	! need to finish other cases
302	CASE ( DATA_ORDER_XZY )
303	gl(1) = glen(1) ; ll(1) = llen(1)
304	gl(2) = kdim ; ll(2) = kdim
305	gl(3) = glen(3) ; ll(3) = llen(3)
306	CASE ( DATA_ORDER_XYZ )
307	gl(1) = glen(1) ; ll(1) = llen(1)
308	gl(2) = glen(2) ; ll(2) = llen(2)
309	gl(3) = kdim ; ll(3) = kdim
310	CASE DEFAULT
311	END SELECT
312	if ( kdim > 1 ) then
313	CALL rsl_build_message(msg,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
314	else if ( kdim == 1 ) then
315	CALL rsl_build_message(msg,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
316	endif
317	END SUBROUTINE add_msg_period_doubleprecision
318	#endif
319
320	! xpose additions, 20000302
321
322	SUBROUTINE reset_msgs_xpose
323	IMPLICIT NONE
324	CALL rsl_create_message ( msg_z )
325	CALL rsl_create_message ( msg_x )
326	CALL rsl_create_message ( msg_y )
327	END SUBROUTINE reset_msgs_xpose
328
329	SUBROUTINE add_msg_xpose_real( fld_z, fld_x, fld_y, dim )
330	IMPLICIT NONE
331	real fld_z(), fld_x(), fld_y(*)
332	integer dim
333	if ( dim == 3 ) then
334	CALL rsl_build_message(msg_z,TRUE_RSL_REAL_F90,fld_z,dim,decomp(1),glen(1),llen(1))
335	CALL rsl_build_message(msg_y,TRUE_RSL_REAL_F90,fld_x,dim,decomp(1),glen(1),llen_tx(1)) ! msg_y->msg_x 20020908
336	CALL rsl_build_message(msg_x,TRUE_RSL_REAL_F90,fld_y,dim,decomp(1),glen(1),llen_ty(1)) ! msg_x->msg_y 20020908
337	endif
338	END SUBROUTINE add_msg_xpose_real
339
340	#if ( RWORDSIZE != DWORDSIZE )
341	SUBROUTINE add_msg_xpose_doubleprecision( fld_z, fld_x, fld_y, dim )
342	IMPLICIT NONE
343	doubleprecision fld_z(), fld_x(), fld_y(*)
344	integer dim
345	if ( dim == 3 ) then
346	CALL rsl_build_message(msg_z,RSL_DOUBLE_F90,fld_z,dim,decomp(1),glen(1),llen(1))
347	CALL rsl_build_message(msg_y,RSL_DOUBLE_F90,fld_x,dim,decomp(1),glen(1),llen_tx(1)) ! msg_y->msg_x 20020908
348	CALL rsl_build_message(msg_x,RSL_DOUBLE_F90,fld_y,dim,decomp(1),glen(1),llen_ty(1)) ! msg_x->msg_y 20020908
349	endif
350	END SUBROUTINE add_msg_xpose_doubleprecision
351	#endif
352
353
354	SUBROUTINE add_msg_xpose_integer ( fld_z, fld_x, fld_y, dim )
355	IMPLICIT NONE
356	integer fld_z(), fld_x(), fld_y(*)
357	integer dim
358	if ( dim == 3 ) then
359	CALL rsl_build_message(msg_z,RSL_INTEGER_F90,fld_z,dim,decomp(1),glen(1),llen(1))
360	CALL rsl_build_message(msg_y,RSL_INTEGER_F90,fld_x,dim,decomp(1),glen(1),llen_tx(1)) ! msg_y->msg_x 20020908
361	CALL rsl_build_message(msg_x,RSL_INTEGER_F90,fld_y,dim,decomp(1),glen(1),llen_ty(1)) ! msg_x->msg_y 20020908
362	endif
363	END SUBROUTINE add_msg_xpose_integer
364
365	SUBROUTINE define_xpose ( did, xp )
366	IMPLICIT NONE
367	INTEGER did , xp
368	CALL rsl_create_xpose ( xp )
369	CALL rsl_describe_xpose ( did , xp , msg_z , msg_x , msg_y )
370	END SUBROUTINE define_xpose
371
372	! end xpose additions, 20000302
373
374	! n5w5 ,n5w4 ,n5w3 ,n5w2 ,n5w ,n5 ,n5e ,n5e2 ,n5e3 ,n5e4 ,n5e5 &
375	! ,n4w5 ,n4w4 ,n4w3 ,n4w2 ,n4w ,n4 ,n4e ,n4e2 ,n4e3 ,n4e4 ,n4e5 &
376	! ,n3w5 ,n3w4 ,n3w3 ,n3w2 ,n3w ,n3 ,n3e ,n3e2 ,n3e3 ,n3e4 ,n3e5 &
377	! ,n2w5 ,n2w4 ,n2w3 ,n2w2 ,n2w ,n2 ,n2e ,n2e2 ,n2e3 ,n2e4 ,n2e5 &
378	! ,nw5 ,nw4 ,nw3 ,nw2 ,nw ,n1 ,ne ,ne2 ,ne3 ,ne4 ,ne5 &
379	! ,w5 ,w4 ,w3 ,w2 ,w1 ,e1 ,e2 ,e3 ,e4 ,e5 &
380	! ,sw5 ,sw4 ,sw3 ,sw2 ,sw ,s1 ,se ,se2 ,se3 ,se4 ,se5 &
381	! ,s2w5 ,s2w4 ,s2w3 ,s2w2 ,s2w ,s2 ,s2e ,s2e2 ,s2e3 ,s2e4 ,s2e5 &
382	! ,s3w5 ,s3w4 ,s3w3 ,s3w2 ,s3w ,s3 ,s3e ,s3e2 ,s3e3 ,s3e4 ,s3e5 &
383	! ,s4w5 ,s4w4 ,s4w3 ,s4w2 ,s4w ,s4 ,s4e ,s4e2 ,s4e3 ,s4e4 ,s4e5 &
384	! ,s5w5 ,s5w4 ,s5w3 ,s5w2 ,s5w ,s5 ,s5e ,s5e2 ,s5e3 ,s5e4 ,s5e5
385
386	SUBROUTINE reset_msgs_120pt
387	CALL reset_msgs_80pt
388	#if 0
389	CALL rsl_create_message(n5w5)
390	CALL rsl_create_message(n5w4)
391	CALL rsl_create_message(n5w3)
392	CALL rsl_create_message(n5w2)
393	CALL rsl_create_message(n5w )
394	CALL rsl_create_message(n5)
395	CALL rsl_create_message(n5e )
396	CALL rsl_create_message(n5e2)
397	CALL rsl_create_message(n5e3)
398	CALL rsl_create_message(n5e4)
399	CALL rsl_create_message(n5e5)
400	CALL rsl_create_message(n4w5)
401	CALL rsl_create_message(n3w5)
402	CALL rsl_create_message(n2w5)
403	CALL rsl_create_message(nw5)
404	CALL rsl_create_message(w5)
405	CALL rsl_create_message(sw5)
406	CALL rsl_create_message(s2w5)
407	CALL rsl_create_message(s3w5)
408	CALL rsl_create_message(s4w5)
409	CALL rsl_create_message(n4e5)
410	CALL rsl_create_message(n3e5)
411	CALL rsl_create_message(n2e5)
412	CALL rsl_create_message(ne5)
413	CALL rsl_create_message(e5)
414	CALL rsl_create_message(se5)
415	CALL rsl_create_message(s2e5)
416	CALL rsl_create_message(s3e5)
417	CALL rsl_create_message(s4e5)
418	CALL rsl_create_message(s5w5)
419	CALL rsl_create_message(s5w4)
420	CALL rsl_create_message(s5w3)
421	CALL rsl_create_message(s5w2)
422	CALL rsl_create_message(s5w )
423	CALL rsl_create_message(s5)
424	CALL rsl_create_message(s5e )
425	CALL rsl_create_message(s5e2)
426	CALL rsl_create_message(s5e3)
427	CALL rsl_create_message(s5e4)
428	CALL rsl_create_message(s5e5)
429	#endif
430	END SUBROUTINE reset_msgs_120pt
431
432	SUBROUTINE reset_msgs_80pt
433	#if 1
434	CALL rsl_create_message(msg_msg)
435	#else
436	CALL reset_msgs_48pt
437	CALL rsl_create_message(n4w4)
438	CALL rsl_create_message(n4w3)
439	CALL rsl_create_message(n4w2)
440	CALL rsl_create_message(n4w )
441	CALL rsl_create_message(n4)
442	CALL rsl_create_message(n4e )
443	CALL rsl_create_message(n4e2)
444	CALL rsl_create_message(n4e3)
445	CALL rsl_create_message(n4e4)
446	CALL rsl_create_message(n3w4)
447	CALL rsl_create_message(n2w4)
448	CALL rsl_create_message(nw4)
449	CALL rsl_create_message(w4)
450	CALL rsl_create_message(sw4)
451	CALL rsl_create_message(s2w4)
452	CALL rsl_create_message(s3w4)
453	CALL rsl_create_message(n3e4)
454	CALL rsl_create_message(n2e4)
455	CALL rsl_create_message(ne4)
456	CALL rsl_create_message(e4)
457	CALL rsl_create_message(se4)
458	CALL rsl_create_message(s2e4)
459	CALL rsl_create_message(s3e4)
460	CALL rsl_create_message(s4w4)
461	CALL rsl_create_message(s4w3)
462	CALL rsl_create_message(s4w2)
463	CALL rsl_create_message(s4w )
464	CALL rsl_create_message(s4)
465	CALL rsl_create_message(s4e )
466	CALL rsl_create_message(s4e2)
467	CALL rsl_create_message(s4e3)
468	CALL rsl_create_message(s4e4)
469	#endif
470	END SUBROUTINE reset_msgs_80pt
471
472	SUBROUTINE reset_msgs_48pt
473	CALL reset_msgs_24pt
474	CALL rsl_create_message(n3w3)
475	CALL rsl_create_message(n3w2)
476	CALL rsl_create_message(n3w )
477	CALL rsl_create_message(n3)
478	CALL rsl_create_message(n3e )
479	CALL rsl_create_message(n3e2)
480	CALL rsl_create_message(n3e3)
481	CALL rsl_create_message(n2w3)
482	CALL rsl_create_message(n2e3)
483	CALL rsl_create_message(nw3)
484	CALL rsl_create_message(ne3)
485	CALL rsl_create_message(w3)
486	CALL rsl_create_message(e3)
487	CALL rsl_create_message(sw3)
488	CALL rsl_create_message(se3)
489	CALL rsl_create_message(s2w3)
490	CALL rsl_create_message(s2e3)
491	CALL rsl_create_message(s3w3)
492	CALL rsl_create_message(s3w2)
493	CALL rsl_create_message(s3w )
494	CALL rsl_create_message(s3)
495	CALL rsl_create_message(s3e )
496	CALL rsl_create_message(s3e2)
497	CALL rsl_create_message(s3e3)
498	RETURN
499	END SUBROUTINE reset_msgs_48pt
500
501	SUBROUTINE reset_msgs_24pt
502	CALL reset_msgs_12pt
503	CALL rsl_create_message(n2w2)
504	CALL rsl_create_message(n2w)
505	CALL rsl_create_message(n2e)
506	CALL rsl_create_message(n2e2)
507	CALL rsl_create_message(nw2)
508	CALL rsl_create_message(ne2)
509	CALL rsl_create_message(sw2)
510	CALL rsl_create_message(se2)
511	CALL rsl_create_message(s2w2)
512	CALL rsl_create_message(s2w)
513	CALL rsl_create_message(s2e)
514	CALL rsl_create_message(s2e2)
515	RETURN
516	END SUBROUTINE reset_msgs_24pt
517
518	SUBROUTINE reset_msgs_12pt
519	CALL reset_msgs_8pt
520	call rsl_create_message(n2)
521	call rsl_create_message(w2)
522	call rsl_create_message(e2)
523	call rsl_create_message(s2)
524	RETURN
525	END SUBROUTINE reset_msgs_12pt
526
527	SUBROUTINE reset_msgs_8pt
528	call reset_msgs_4pt
529	call rsl_create_message(ne)
530	call rsl_create_message(nw)
531	call rsl_create_message(se)
532	call rsl_create_message(sw)
533	RETURN
534	END SUBROUTINE reset_msgs_8pt
535
536	SUBROUTINE reset_msgs_4pt
537	call rsl_create_message(n1)
538	call rsl_create_message(w1)
539	call rsl_create_message(e1)
540	call rsl_create_message(s1)
541	RETURN
542	END SUBROUTINE reset_msgs_4pt
543
544	SUBROUTINE reset_msgs_y_shift
545	call rsl_create_message(s5)
546	call rsl_create_message(s4)
547	call rsl_create_message(s3)
548	call rsl_create_message(s2)
549	call rsl_create_message(s1)
550	call rsl_create_message(n1)
551	call rsl_create_message(n2)
552	call rsl_create_message(n3)
553	call rsl_create_message(n4)
554	call rsl_create_message(n5)
555	RETURN
556	END SUBROUTINE reset_msgs_y_shift
557
558	SUBROUTINE reset_msgs_x_shift
559	call rsl_create_message(w5)
560	call rsl_create_message(w4)
561	call rsl_create_message(w3)
562	call rsl_create_message(w2)
563	call rsl_create_message(w1)
564	call rsl_create_message(e1)
565	call rsl_create_message(e2)
566	call rsl_create_message(e3)
567	call rsl_create_message(e4)
568	call rsl_create_message(e5)
569	RETURN
570	END SUBROUTINE reset_msgs_x_shift
571
572	SUBROUTINE add_msg_x_shift_real ( fld, kdim )
573	IMPLICIT NONE
574	integer kdim, gl(3), ll(3)
575	real fld(*)
576	SELECT CASE ( model_data_order )
577	! need to finish other cases
578	CASE ( DATA_ORDER_XZY )
579	gl(1) = glen(1) ; ll(1) = llen(1)
580	gl(2) = kdim ; ll(2) = kdim
581	gl(3) = glen(3) ; ll(3) = llen(3)
582	CASE ( DATA_ORDER_XYZ )
583	gl(1) = glen(1) ; ll(1) = llen(1)
584	gl(2) = glen(2) ; ll(2) = llen(2)
585	gl(3) = kdim ; ll(3) = kdim
586	CASE DEFAULT
587	END SELECT
588	if ( kdim > 1 ) then
589	CALL rsl_build_message(w5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
590	CALL rsl_build_message(w4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
591	CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
592	CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
593	CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
594	CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
595	CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
596	CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
597	CALL rsl_build_message(e4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
598	CALL rsl_build_message(e5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
599	else if ( kdim == 1 ) then
600	CALL rsl_build_message(w5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
601	CALL rsl_build_message(w4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
602	CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
603	CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
604	CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
605	CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
606	CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
607	CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
608	CALL rsl_build_message(e4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
609	CALL rsl_build_message(e5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
610	endif
611	RETURN
612	END SUBROUTINE add_msg_x_shift_real
613	SUBROUTINE add_msg_y_shift_real ( fld, kdim )
614	IMPLICIT NONE
615	integer kdim, gl(3), ll(3)
616	real fld(*)
617	SELECT CASE ( model_data_order )
618	! need to finish other cases
619	CASE ( DATA_ORDER_XZY )
620	gl(1) = glen(1) ; ll(1) = llen(1)
621	gl(2) = kdim ; ll(2) = kdim
622	gl(3) = glen(3) ; ll(3) = llen(3)
623	CASE ( DATA_ORDER_XYZ )
624	gl(1) = glen(1) ; ll(1) = llen(1)
625	gl(2) = glen(2) ; ll(2) = llen(2)
626	gl(3) = kdim ; ll(3) = kdim
627	CASE DEFAULT
628	END SELECT
629	if ( kdim > 1 ) then
630	CALL rsl_build_message(s5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
631	CALL rsl_build_message(s4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
632	CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
633	CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
634	CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
635	CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
636	CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
637	CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
638	CALL rsl_build_message(n4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
639	CALL rsl_build_message(n5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
640	else if ( kdim == 1 ) then
641	CALL rsl_build_message(s5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
642	CALL rsl_build_message(s4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
643	CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
644	CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
645	CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
646	CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
647	CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
648	CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
649	CALL rsl_build_message(n4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
650	CALL rsl_build_message(n5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
651	endif
652	RETURN
653	END SUBROUTINE add_msg_y_shift_real
654
655	SUBROUTINE add_msg_x_shift_integer ( fld, kdim )
656	IMPLICIT NONE
657	integer kdim, gl(3), ll(3)
658	integer fld(*)
659	SELECT CASE ( model_data_order )
660	! need to finish other cases
661	CASE ( DATA_ORDER_XZY )
662	gl(1) = glen(1) ; ll(1) = llen(1)
663	gl(2) = kdim ; ll(2) = kdim
664	gl(3) = glen(3) ; ll(3) = llen(3)
665	CASE ( DATA_ORDER_XYZ )
666	gl(1) = glen(1) ; ll(1) = llen(1)
667	gl(2) = glen(2) ; ll(2) = llen(2)
668	gl(3) = kdim ; ll(3) = kdim
669	CASE DEFAULT
670	END SELECT
671	if ( kdim > 1 ) then
672	CALL rsl_build_message(w5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
673	CALL rsl_build_message(w4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
674	CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
675	CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
676	CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
677	CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
678	CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
679	CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
680	CALL rsl_build_message(e4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
681	CALL rsl_build_message(e5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
682	else if ( kdim == 1 ) then
683	CALL rsl_build_message(w5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
684	CALL rsl_build_message(w4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
685	CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
686	CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
687	CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
688	CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
689	CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
690	CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
691	CALL rsl_build_message(e4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
692	CALL rsl_build_message(e5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
693	endif
694	RETURN
695	END SUBROUTINE add_msg_x_shift_integer
696	SUBROUTINE add_msg_y_shift_integer ( fld, kdim )
697	IMPLICIT NONE
698	integer kdim, gl(3), ll(3)
699	integer fld(*)
700	SELECT CASE ( model_data_order )
701	! need to finish other cases
702	CASE ( DATA_ORDER_XZY )
703	gl(1) = glen(1) ; ll(1) = llen(1)
704	gl(2) = kdim ; ll(2) = kdim
705	gl(3) = glen(3) ; ll(3) = llen(3)
706	CASE ( DATA_ORDER_XYZ )
707	gl(1) = glen(1) ; ll(1) = llen(1)
708	gl(2) = glen(2) ; ll(2) = llen(2)
709	gl(3) = kdim ; ll(3) = kdim
710	CASE DEFAULT
711	END SELECT
712	if ( kdim > 1 ) then
713	CALL rsl_build_message(s5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
714	CALL rsl_build_message(s4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
715	CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
716	CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
717	CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
718	CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
719	CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
720	CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
721	CALL rsl_build_message(n4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
722	CALL rsl_build_message(n5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
723	else if ( kdim == 1 ) then
724	CALL rsl_build_message(s5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
725	CALL rsl_build_message(s4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
726	CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
727	CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
728	CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
729	CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
730	CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
731	CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
732	CALL rsl_build_message(n4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
733	CALL rsl_build_message(n5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
734	endif
735	RETURN
736	END SUBROUTINE add_msg_y_shift_integer
737
738	SUBROUTINE add_msg_x_shift_doubleprecision ( fld, kdim )
739	IMPLICIT NONE
740	integer kdim, gl(3), ll(3)
741	doubleprecision fld(*)
742	SELECT CASE ( model_data_order )
743	! need to finish other cases
744	CASE ( DATA_ORDER_XZY )
745	gl(1) = glen(1) ; ll(1) = llen(1)
746	gl(2) = kdim ; ll(2) = kdim
747	gl(3) = glen(3) ; ll(3) = llen(3)
748	CASE ( DATA_ORDER_XYZ )
749	gl(1) = glen(1) ; ll(1) = llen(1)
750	gl(2) = glen(2) ; ll(2) = llen(2)
751	gl(3) = kdim ; ll(3) = kdim
752	CASE DEFAULT
753	END SELECT
754	if ( kdim > 1 ) then
755	CALL rsl_build_message(w5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
756	CALL rsl_build_message(w4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
757	CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
758	CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
759	CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
760	CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
761	CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
762	CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
763	CALL rsl_build_message(e4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
764	CALL rsl_build_message(e5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
765	else if ( kdim == 1 ) then
766	CALL rsl_build_message(w5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
767	CALL rsl_build_message(w4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
768	CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
769	CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
770	CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
771	CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
772	CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
773	CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
774	CALL rsl_build_message(e4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
775	CALL rsl_build_message(e5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
776	endif
777	RETURN
778	END SUBROUTINE add_msg_x_shift_doubleprecision
779	SUBROUTINE add_msg_y_shift_doubleprecision ( fld, kdim )
780	IMPLICIT NONE
781	integer kdim, gl(3), ll(3)
782	doubleprecision fld(*)
783	SELECT CASE ( model_data_order )
784	! need to finish other cases
785	CASE ( DATA_ORDER_XZY )
786	gl(1) = glen(1) ; ll(1) = llen(1)
787	gl(2) = kdim ; ll(2) = kdim
788	gl(3) = glen(3) ; ll(3) = llen(3)
789	CASE ( DATA_ORDER_XYZ )
790	gl(1) = glen(1) ; ll(1) = llen(1)
791	gl(2) = glen(2) ; ll(2) = llen(2)
792	gl(3) = kdim ; ll(3) = kdim
793	CASE DEFAULT
794	END SELECT
795	if ( kdim > 1 ) then
796	CALL rsl_build_message(s5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
797	CALL rsl_build_message(s4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
798	CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
799	CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
800	CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
801	CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
802	CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
803	CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
804	CALL rsl_build_message(n4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
805	CALL rsl_build_message(n5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
806	else if ( kdim == 1 ) then
807	CALL rsl_build_message(s5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
808	CALL rsl_build_message(s4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
809	CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
810	CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
811	CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
812	CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
813	CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
814	CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
815	CALL rsl_build_message(n4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
816	CALL rsl_build_message(n5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
817	endif
818	RETURN
819	END SUBROUTINE add_msg_y_shift_doubleprecision
820
821	SUBROUTINE add_msg_4pt_real ( fld , kdim )
822	IMPLICIT NONE
823	integer kdim, gl(3), ll(3)
824	real fld(*)
825	SELECT CASE ( model_data_order )
826	! need to finish other cases
827	CASE ( DATA_ORDER_XZY )
828	gl(1) = glen(1) ; ll(1) = llen(1)
829	gl(2) = kdim ; ll(2) = kdim
830	gl(3) = glen(3) ; ll(3) = llen(3)
831	CASE ( DATA_ORDER_XYZ )
832	gl(1) = glen(1) ; ll(1) = llen(1)
833	gl(2) = glen(2) ; ll(2) = llen(2)
834	gl(3) = kdim ; ll(3) = kdim
835	CASE DEFAULT
836	END SELECT
837	if ( kdim > 1 ) then
838	CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
839	CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
840	CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
841	CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
842	else if ( kdim == 1 ) then
843	CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
844	CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
845	CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
846	CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
847	endif
848	RETURN
849	END SUBROUTINE add_msg_4pt_real
850
851	#if ( RWORDSIZE != DWORDSIZE )
852	SUBROUTINE add_msg_4pt_doubleprecision ( fld , kdim )
853	IMPLICIT NONE
854	integer kdim, gl(3), ll(3)
855	doubleprecision fld(*)
856	SELECT CASE ( model_data_order )
857	! need to finish other cases
858	CASE ( DATA_ORDER_XZY )
859	gl(1) = glen(1) ; ll(1) = llen(1)
860	gl(2) = kdim ; ll(2) = kdim
861	gl(3) = glen(3) ; ll(3) = llen(3)
862	CASE ( DATA_ORDER_XYZ )
863	gl(1) = glen(1) ; ll(1) = llen(1)
864	gl(2) = glen(2) ; ll(2) = llen(2)
865	gl(3) = kdim ; ll(3) = kdim
866	CASE DEFAULT
867	END SELECT
868	if ( kdim > 1 ) then
869	CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
870	CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
871	CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
872	CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
873	else if ( kdim == 1 ) then
874	CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
875	CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
876	CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
877	CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
878	endif
879	RETURN
880	END SUBROUTINE add_msg_4pt_doubleprecision
881	#endif
882
883
884	SUBROUTINE add_msg_4pt_integer ( fld , kdim )
885	IMPLICIT NONE
886	integer kdim, gl(3), ll(3)
887	integer fld(*)
888	SELECT CASE ( model_data_order )
889	! need to finish other cases
890	CASE ( DATA_ORDER_XZY )
891	gl(1) = glen(1) ; ll(1) = llen(1)
892	gl(2) = kdim ; ll(2) = kdim
893	gl(3) = glen(3) ; ll(3) = llen(3)
894	CASE ( DATA_ORDER_XYZ )
895	gl(1) = glen(1) ; ll(1) = llen(1)
896	gl(2) = glen(2) ; ll(2) = llen(2)
897	gl(3) = kdim ; ll(3) = kdim
898	CASE DEFAULT
899	END SELECT
900	if ( kdim > 1 ) then
901	CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
902	CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
903	CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
904	CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
905	else if ( kdim == 1 ) then
906	CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
907	CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
908	CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
909	CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
910	endif
911	RETURN
912	END SUBROUTINE add_msg_4pt_integer
913
914	SUBROUTINE add_msg_8pt_real ( fld , kdim )
915	IMPLICIT NONE
916	integer kdim, gl(3), ll(3)
917	real fld(*)
918	SELECT CASE ( model_data_order )
919	! need to finish other cases
920	CASE ( DATA_ORDER_XZY )
921	gl(1) = glen(1) ; ll(1) = llen(1)
922	gl(2) = kdim ; ll(2) = kdim
923	gl(3) = glen(3) ; ll(3) = llen(3)
924	CASE ( DATA_ORDER_XYZ )
925	gl(1) = glen(1) ; ll(1) = llen(1)
926	gl(2) = glen(2) ; ll(2) = llen(2)
927	gl(3) = kdim ; ll(3) = kdim
928	CASE DEFAULT
929	END SELECT
930	CALL add_msg_4pt ( fld , kdim )
931	if ( kdim > 1 ) then
932	CALL rsl_build_message(nw,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
933	CALL rsl_build_message(sw,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
934	CALL rsl_build_message(ne,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
935	CALL rsl_build_message(se,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
936	else if ( kdim == 1 ) then
937	CALL rsl_build_message(nw,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
938	CALL rsl_build_message(sw,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
939	CALL rsl_build_message(ne,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
940	CALL rsl_build_message(se,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
941	endif
942	RETURN
943	END SUBROUTINE add_msg_8pt_real
944
945	#if ( RWORDSIZE != DWORDSIZE )
946	SUBROUTINE add_msg_8pt_doubleprecision ( fld , kdim )
947	IMPLICIT NONE
948	integer kdim, gl(3), ll(3)
949	doubleprecision fld(*)
950	SELECT CASE ( model_data_order )
951	! need to finish other cases
952	CASE ( DATA_ORDER_XZY )
953	gl(1) = glen(1) ; ll(1) = llen(1)
954	gl(2) = kdim ; ll(2) = kdim
955	gl(3) = glen(3) ; ll(3) = llen(3)
956	CASE ( DATA_ORDER_XYZ )
957	gl(1) = glen(1) ; ll(1) = llen(1)
958	gl(2) = glen(2) ; ll(2) = llen(2)
959	gl(3) = kdim ; ll(3) = kdim
960	CASE DEFAULT
961	END SELECT
962	CALL add_msg_4pt ( fld , kdim )
963	if ( kdim > 1 ) then
964	CALL rsl_build_message(nw,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
965	CALL rsl_build_message(sw,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
966	CALL rsl_build_message(ne,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
967	CALL rsl_build_message(se,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
968	else if ( kdim == 1 ) then
969	CALL rsl_build_message(nw,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
970	CALL rsl_build_message(sw,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
971	CALL rsl_build_message(ne,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
972	CALL rsl_build_message(se,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
973	endif
974	RETURN
975	END SUBROUTINE add_msg_8pt_doubleprecision
976	#endif
977
978
979	SUBROUTINE add_msg_8pt_integer( fld , kdim )
980	IMPLICIT NONE
981	integer kdim, gl(3), ll(3)
982	integer fld(*)
983	SELECT CASE ( model_data_order )
984	! need to finish other cases
985	CASE ( DATA_ORDER_XZY )
986	gl(1) = glen(1) ; ll(1) = llen(1)
987	gl(2) = kdim ; ll(2) = kdim
988	gl(3) = glen(3) ; ll(3) = llen(3)
989	CASE ( DATA_ORDER_XYZ )
990	gl(1) = glen(1) ; ll(1) = llen(1)
991	gl(2) = glen(2) ; ll(2) = llen(2)
992	gl(3) = kdim ; ll(3) = kdim
993	CASE DEFAULT
994	END SELECT
995	CALL add_msg_4pt ( fld , kdim )
996	if ( kdim > 1 ) then
997	CALL rsl_build_message(nw,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
998	CALL rsl_build_message(sw,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
999	CALL rsl_build_message(ne,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1000	CALL rsl_build_message(se,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1001	else if ( kdim == 1 ) then
1002	CALL rsl_build_message(nw,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1003	CALL rsl_build_message(sw,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1004	CALL rsl_build_message(ne,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1005	CALL rsl_build_message(se,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1006	endif
1007	RETURN
1008	END SUBROUTINE add_msg_8pt_integer
1009
1010	SUBROUTINE add_msg_12pt_real ( fld , kdim )
1011	IMPLICIT NONE
1012	integer kdim, gl(3), ll(3)
1013	real fld(*)
1014	SELECT CASE ( model_data_order )
1015	! need to finish other cases
1016	CASE ( DATA_ORDER_XZY )
1017	gl(1) = glen(1) ; ll(1) = llen(1)
1018	gl(2) = kdim ; ll(2) = kdim
1019	gl(3) = glen(3) ; ll(3) = llen(3)
1020	CASE ( DATA_ORDER_XYZ )
1021	gl(1) = glen(1) ; ll(1) = llen(1)
1022	gl(2) = glen(2) ; ll(2) = llen(2)
1023	gl(3) = kdim ; ll(3) = kdim
1024	CASE DEFAULT
1025	END SELECT
1026	CALL add_msg_8pt ( fld , kdim )
1027	if ( kdim > 1 ) then
1028	CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1029	CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1030	CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1031	CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1032	else if ( kdim == 1 ) then
1033	CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1034	CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1035	CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1036	CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1037	endif
1038	RETURN
1039	END SUBROUTINE add_msg_12pt_real
1040
1041	#if ( RWORDSIZE != DWORDSIZE )
1042	SUBROUTINE add_msg_12pt_doubleprecision ( fld , kdim )
1043	IMPLICIT NONE
1044	integer kdim, gl(3), ll(3)
1045	doubleprecision fld(*)
1046	SELECT CASE ( model_data_order )
1047	! need to finish other cases
1048	CASE ( DATA_ORDER_XZY )
1049	gl(1) = glen(1) ; ll(1) = llen(1)
1050	gl(2) = kdim ; ll(2) = kdim
1051	gl(3) = glen(3) ; ll(3) = llen(3)
1052	CASE ( DATA_ORDER_XYZ )
1053	gl(1) = glen(1) ; ll(1) = llen(1)
1054	gl(2) = glen(2) ; ll(2) = llen(2)
1055	gl(3) = kdim ; ll(3) = kdim
1056	CASE DEFAULT
1057	END SELECT
1058	CALL add_msg_8pt ( fld , kdim )
1059	if ( kdim > 1 ) then
1060	CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1061	CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1062	CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1063	CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1064	else if ( kdim == 1 ) then
1065	CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1066	CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1067	CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1068	CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1069	endif
1070	RETURN
1071	END SUBROUTINE add_msg_12pt_doubleprecision
1072	#endif
1073
1074
1075	SUBROUTINE add_msg_12pt_integer ( fld , kdim )
1076	IMPLICIT NONE
1077	integer kdim, gl(3), ll(3)
1078	integer fld(*)
1079	SELECT CASE ( model_data_order )
1080	! need to finish other cases
1081	CASE ( DATA_ORDER_XZY )
1082	gl(1) = glen(1) ; ll(1) = llen(1)
1083	gl(2) = kdim ; ll(2) = kdim
1084	gl(3) = glen(3) ; ll(3) = llen(3)
1085	CASE ( DATA_ORDER_XYZ )
1086	gl(1) = glen(1) ; ll(1) = llen(1)
1087	gl(2) = glen(2) ; ll(2) = llen(2)
1088	gl(3) = kdim ; ll(3) = kdim
1089	CASE DEFAULT
1090	END SELECT
1091	CALL add_msg_8pt ( fld , kdim )
1092	if ( kdim > 1 ) then
1093	CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1094	CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1095	CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1096	CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1097	else if ( kdim == 1 ) then
1098	CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1099	CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1100	CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1101	CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1102	endif
1103	RETURN
1104	END SUBROUTINE add_msg_12pt_integer
1105
1106	SUBROUTINE add_msg_24pt_real ( fld , kdim )
1107	IMPLICIT NONE
1108	integer kdim, gl(3), ll(3)
1109	real fld(*)
1110	SELECT CASE ( model_data_order )
1111	! need to finish other cases
1112	CASE ( DATA_ORDER_XZY )
1113	gl(1) = glen(1) ; ll(1) = llen(1)
1114	gl(2) = kdim ; ll(2) = kdim
1115	gl(3) = glen(3) ; ll(3) = llen(3)
1116	CASE ( DATA_ORDER_XYZ )
1117	gl(1) = glen(1) ; ll(1) = llen(1)
1118	gl(2) = glen(2) ; ll(2) = llen(2)
1119	gl(3) = kdim ; ll(3) = kdim
1120	CASE DEFAULT
1121	END SELECT
1122	CALL add_msg_8pt ( fld , kdim )
1123	if ( kdim > 1 ) then
1124	CALL rsl_build_message(n2w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1125	CALL rsl_build_message(n2w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1126	CALL rsl_build_message(n2e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1127	CALL rsl_build_message(n2e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1128	CALL rsl_build_message(nw2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1129	CALL rsl_build_message(ne2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1130	CALL rsl_build_message(sw2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1131	CALL rsl_build_message(se2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1132	CALL rsl_build_message(s2w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1133	CALL rsl_build_message(s2w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1134	CALL rsl_build_message(s2e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1135	CALL rsl_build_message(s2e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1136	else if ( kdim == 1 ) then
1137	CALL rsl_build_message(n2w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1138	CALL rsl_build_message(n2w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1139	CALL rsl_build_message(n2e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1140	CALL rsl_build_message(n2e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1141	CALL rsl_build_message(nw2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1142	CALL rsl_build_message(ne2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1143	CALL rsl_build_message(sw2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1144	CALL rsl_build_message(se2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1145	CALL rsl_build_message(s2w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1146	CALL rsl_build_message(s2w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1147	CALL rsl_build_message(s2e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1148	CALL rsl_build_message(s2e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1149	endif
1150	RETURN
1151	END SUBROUTINE add_msg_24pt_real
1152
1153	#if ( RWORDSIZE != DWORDSIZE )
1154	SUBROUTINE add_msg_24pt_doubleprecision ( fld , kdim )
1155	IMPLICIT NONE
1156	integer kdim, gl(3), ll(3)
1157	doubleprecision fld(*)
1158	SELECT CASE ( model_data_order )
1159	! need to finish other cases
1160	CASE ( DATA_ORDER_XZY )
1161	gl(1) = glen(1) ; ll(1) = llen(1)
1162	gl(2) = kdim ; ll(2) = kdim
1163	gl(3) = glen(3) ; ll(3) = llen(3)
1164	CASE ( DATA_ORDER_XYZ )
1165	gl(1) = glen(1) ; ll(1) = llen(1)
1166	gl(2) = glen(2) ; ll(2) = llen(2)
1167	gl(3) = kdim ; ll(3) = kdim
1168	CASE DEFAULT
1169	END SELECT
1170	CALL add_msg_8pt ( fld , kdim )
1171	if ( kdim > 1 ) then
1172	CALL rsl_build_message(n2w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1173	CALL rsl_build_message(n2w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1174	CALL rsl_build_message(n2e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1175	CALL rsl_build_message(n2e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1176	CALL rsl_build_message(nw2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1177	CALL rsl_build_message(ne2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1178	CALL rsl_build_message(sw2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1179	CALL rsl_build_message(se2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1180	CALL rsl_build_message(s2w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1181	CALL rsl_build_message(s2w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1182	CALL rsl_build_message(s2e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1183	CALL rsl_build_message(s2e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1184	else if ( kdim == 1 ) then
1185	CALL rsl_build_message(n2w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1186	CALL rsl_build_message(n2w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1187	CALL rsl_build_message(n2e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1188	CALL rsl_build_message(n2e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1189	CALL rsl_build_message(nw2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1190	CALL rsl_build_message(ne2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1191	CALL rsl_build_message(sw2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1192	CALL rsl_build_message(se2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1193	CALL rsl_build_message(s2w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1194	CALL rsl_build_message(s2w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1195	CALL rsl_build_message(s2e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1196	CALL rsl_build_message(s2e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1197	endif
1198	RETURN
1199	END SUBROUTINE add_msg_24pt_doubleprecision
1200	#endif
1201
1202
1203	SUBROUTINE add_msg_24pt_integer ( fld , kdim )
1204	IMPLICIT NONE
1205	integer kdim, gl(3), ll(3)
1206	integer fld(*)
1207	SELECT CASE ( model_data_order )
1208	! need to finish other cases
1209	CASE ( DATA_ORDER_XZY )
1210	gl(1) = glen(1) ; ll(1) = llen(1)
1211	gl(2) = kdim ; ll(2) = kdim
1212	gl(3) = glen(3) ; ll(3) = llen(3)
1213	CASE ( DATA_ORDER_XYZ )
1214	gl(1) = glen(1) ; ll(1) = llen(1)
1215	gl(2) = glen(2) ; ll(2) = llen(2)
1216	gl(3) = kdim ; ll(3) = kdim
1217	CASE DEFAULT
1218	END SELECT
1219	CALL add_msg_8pt ( fld , kdim )
1220	if ( kdim > 1 ) then
1221	CALL rsl_build_message(n2w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1222	CALL rsl_build_message(n2w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1223	CALL rsl_build_message(n2e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1224	CALL rsl_build_message(n2e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1225	CALL rsl_build_message(nw2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1226	CALL rsl_build_message(ne2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1227	CALL rsl_build_message(sw2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1228	CALL rsl_build_message(se2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1229	CALL rsl_build_message(s2w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1230	CALL rsl_build_message(s2w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1231	CALL rsl_build_message(s2e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1232	CALL rsl_build_message(s2e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1233	else if ( kdim == 1 ) then
1234	CALL rsl_build_message(n2w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1235	CALL rsl_build_message(n2w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1236	CALL rsl_build_message(n2e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1237	CALL rsl_build_message(n2e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1238	CALL rsl_build_message(nw2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1239	CALL rsl_build_message(ne2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1240	CALL rsl_build_message(sw2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1241	CALL rsl_build_message(se2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1242	CALL rsl_build_message(s2w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1243	CALL rsl_build_message(s2w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1244	CALL rsl_build_message(s2e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1245	CALL rsl_build_message(s2e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1246	endif
1247	RETURN
1248	END SUBROUTINE add_msg_24pt_integer
1249
1250	SUBROUTINE add_msg_48pt_real ( fld , kdim )
1251	IMPLICIT NONE
1252	integer kdim, gl(3), ll(3)
1253	real fld(*)
1254	SELECT CASE ( model_data_order )
1255	! need to finish other cases
1256	CASE ( DATA_ORDER_XZY )
1257	gl(1) = glen(1) ; ll(1) = llen(1)
1258	gl(2) = kdim ; ll(2) = kdim
1259	gl(3) = glen(3) ; ll(3) = llen(3)
1260	CASE ( DATA_ORDER_XYZ )
1261	gl(1) = glen(1) ; ll(1) = llen(1)
1262	gl(2) = glen(2) ; ll(2) = llen(2)
1263	gl(3) = kdim ; ll(3) = kdim
1264	CASE DEFAULT
1265	END SELECT
1266	CALL add_msg_24pt ( fld , kdim )
1267	if ( kdim > 1 ) then
1268	CALL rsl_build_message(n3w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1269	CALL rsl_build_message(n3w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1270	CALL rsl_build_message(n3w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1271	CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1272	CALL rsl_build_message(n3e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1273	CALL rsl_build_message(n3e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1274	CALL rsl_build_message(n3e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1275	CALL rsl_build_message(n2w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1276	CALL rsl_build_message(n2e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1277	CALL rsl_build_message(nw3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1278	CALL rsl_build_message(ne3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1279	CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1280	CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1281	CALL rsl_build_message(sw3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1282	CALL rsl_build_message(se3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1283	CALL rsl_build_message(s2w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1284	CALL rsl_build_message(s2e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1285	CALL rsl_build_message(s3w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1286	CALL rsl_build_message(s3w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1287	CALL rsl_build_message(s3w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1288	CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1289	CALL rsl_build_message(s3e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1290	CALL rsl_build_message(s3e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1291	CALL rsl_build_message(s3e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1292	else if ( kdim == 1 ) then
1293	CALL rsl_build_message(n3w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1294	CALL rsl_build_message(n3w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1295	CALL rsl_build_message(n3w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1296	CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1297	CALL rsl_build_message(n3e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1298	CALL rsl_build_message(n3e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1299	CALL rsl_build_message(n3e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1300	CALL rsl_build_message(n2w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1301	CALL rsl_build_message(n2e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1302	CALL rsl_build_message(nw3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1303	CALL rsl_build_message(ne3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1304	CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1305	CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1306	CALL rsl_build_message(sw3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1307	CALL rsl_build_message(se3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1308	CALL rsl_build_message(s2w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1309	CALL rsl_build_message(s2e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1310	CALL rsl_build_message(s3w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1311	CALL rsl_build_message(s3w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1312	CALL rsl_build_message(s3w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1313	CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1314	CALL rsl_build_message(s3e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1315	CALL rsl_build_message(s3e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1316	CALL rsl_build_message(s3e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1317	endif
1318	RETURN
1319	END SUBROUTINE add_msg_48pt_real
1320
1321	#if ( RWORDSIZE != DWORDSIZE )
1322	SUBROUTINE add_msg_48pt_doubleprecision ( fld , kdim )
1323	IMPLICIT NONE
1324	integer kdim, gl(3), ll(3)
1325	doubleprecision fld(*)
1326	SELECT CASE ( model_data_order )
1327	! need to finish other cases
1328	CASE ( DATA_ORDER_XZY )
1329	gl(1) = glen(1) ; ll(1) = llen(1)
1330	gl(2) = kdim ; ll(2) = kdim
1331	gl(3) = glen(3) ; ll(3) = llen(3)
1332	CASE ( DATA_ORDER_XYZ )
1333	gl(1) = glen(1) ; ll(1) = llen(1)
1334	gl(2) = glen(2) ; ll(2) = llen(2)
1335	gl(3) = kdim ; ll(3) = kdim
1336	CASE DEFAULT
1337	END SELECT
1338	CALL add_msg_24pt ( fld , kdim )
1339	if ( kdim > 1 ) then
1340	CALL rsl_build_message(n3w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1341	CALL rsl_build_message(n3w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1342	CALL rsl_build_message(n3w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1343	CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1344	CALL rsl_build_message(n3e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1345	CALL rsl_build_message(n3e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1346	CALL rsl_build_message(n3e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1347	CALL rsl_build_message(n2w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1348	CALL rsl_build_message(n2e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1349	CALL rsl_build_message(nw3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1350	CALL rsl_build_message(ne3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1351	CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1352	CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1353	CALL rsl_build_message(sw3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1354	CALL rsl_build_message(se3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1355	CALL rsl_build_message(s2w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1356	CALL rsl_build_message(s2e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1357	CALL rsl_build_message(s3w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1358	CALL rsl_build_message(s3w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1359	CALL rsl_build_message(s3w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1360	CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1361	CALL rsl_build_message(s3e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1362	CALL rsl_build_message(s3e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1363	CALL rsl_build_message(s3e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1364	else if ( kdim == 1 ) then
1365	CALL rsl_build_message(n3w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1366	CALL rsl_build_message(n3w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1367	CALL rsl_build_message(n3w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1368	CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1369	CALL rsl_build_message(n3e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1370	CALL rsl_build_message(n3e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1371	CALL rsl_build_message(n3e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1372	CALL rsl_build_message(n2w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1373	CALL rsl_build_message(n2e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1374	CALL rsl_build_message(nw3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1375	CALL rsl_build_message(ne3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1376	CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1377	CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1378	CALL rsl_build_message(sw3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1379	CALL rsl_build_message(se3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1380	CALL rsl_build_message(s2w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1381	CALL rsl_build_message(s2e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1382	CALL rsl_build_message(s3w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1383	CALL rsl_build_message(s3w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1384	CALL rsl_build_message(s3w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1385	CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1386	CALL rsl_build_message(s3e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1387	CALL rsl_build_message(s3e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1388	CALL rsl_build_message(s3e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1389	endif
1390	RETURN
1391	END SUBROUTINE add_msg_48pt_doubleprecision
1392	#endif
1393
1394	SUBROUTINE add_msg_48pt_integer ( fld , kdim )
1395	IMPLICIT NONE
1396	integer kdim, gl(3), ll(3)
1397	integer fld(*)
1398	SELECT CASE ( model_data_order )
1399	! need to finish other cases
1400	CASE ( DATA_ORDER_XZY )
1401	gl(1) = glen(1) ; ll(1) = llen(1)
1402	gl(2) = kdim ; ll(2) = kdim
1403	gl(3) = glen(3) ; ll(3) = llen(3)
1404	CASE ( DATA_ORDER_XYZ )
1405	gl(1) = glen(1) ; ll(1) = llen(1)
1406	gl(2) = glen(2) ; ll(2) = llen(2)
1407	gl(3) = kdim ; ll(3) = kdim
1408	CASE DEFAULT
1409	END SELECT
1410	CALL add_msg_24pt ( fld , kdim )
1411	if ( kdim > 1 ) then
1412	CALL rsl_build_message(n3w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1413	CALL rsl_build_message(n3w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1414	CALL rsl_build_message(n3w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1415	CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1416	CALL rsl_build_message(n3e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1417	CALL rsl_build_message(n3e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1418	CALL rsl_build_message(n3e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1419	CALL rsl_build_message(n2w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1420	CALL rsl_build_message(n2e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1421	CALL rsl_build_message(nw3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1422	CALL rsl_build_message(ne3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1423	CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1424	CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1425	CALL rsl_build_message(sw3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1426	CALL rsl_build_message(se3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1427	CALL rsl_build_message(s2w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1428	CALL rsl_build_message(s2e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1429	CALL rsl_build_message(s3w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1430	CALL rsl_build_message(s3w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1431	CALL rsl_build_message(s3w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1432	CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1433	CALL rsl_build_message(s3e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1434	CALL rsl_build_message(s3e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1435	CALL rsl_build_message(s3e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1436	else if ( kdim == 1 ) then
1437	CALL rsl_build_message(n3w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1438	CALL rsl_build_message(n3w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1439	CALL rsl_build_message(n3w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1440	CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1441	CALL rsl_build_message(n3e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1442	CALL rsl_build_message(n3e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1443	CALL rsl_build_message(n3e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1444	CALL rsl_build_message(n2w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1445	CALL rsl_build_message(n2e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1446	CALL rsl_build_message(nw3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1447	CALL rsl_build_message(ne3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1448	CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1449	CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1450	CALL rsl_build_message(sw3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1451	CALL rsl_build_message(se3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1452	CALL rsl_build_message(s2w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1453	CALL rsl_build_message(s2e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1454	CALL rsl_build_message(s3w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1455	CALL rsl_build_message(s3w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1456	CALL rsl_build_message(s3w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1457	CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1458	CALL rsl_build_message(s3e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1459	CALL rsl_build_message(s3e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1460	CALL rsl_build_message(s3e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1461	endif
1462	RETURN
1463	END SUBROUTINE add_msg_48pt_integer
1464
1465
1466	SUBROUTINE add_msg_80pt_real ( fld , kdim )
1467	IMPLICIT NONE
1468	integer kdim, gl(3), ll(3)
1469	real fld(*)
1470	SELECT CASE ( model_data_order )
1471	! need to finish other cases
1472	CASE ( DATA_ORDER_XZY )
1473	gl(1) = glen(1) ; ll(1) = llen(1)
1474	gl(2) = kdim ; ll(2) = kdim
1475	gl(3) = glen(3) ; ll(3) = llen(3)
1476	CASE ( DATA_ORDER_XYZ )
1477	gl(1) = glen(1) ; ll(1) = llen(1)
1478	gl(2) = glen(2) ; ll(2) = llen(2)
1479	gl(3) = kdim ; ll(3) = kdim
1480	CASE DEFAULT
1481	END SELECT
1482	if ( kdim > 1 ) then
1483	CALL rsl_build_message(msg_msg,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
1484	else if ( kdim == 1 ) then
1485	CALL rsl_build_message(msg_msg,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1486	endif
1487	RETURN
1488	END SUBROUTINE add_msg_80pt_real
1489
1490	#if ( RWORDSIZE != DWORDSIZE )
1491	SUBROUTINE add_msg_80pt_doubleprecision ( fld , kdim )
1492	IMPLICIT NONE
1493	integer kdim, gl(3), ll(3)
1494	doubleprecision fld(*)
1495	SELECT CASE ( model_data_order )
1496	! need to finish other cases
1497	CASE ( DATA_ORDER_XZY )
1498	gl(1) = glen(1) ; ll(1) = llen(1)
1499	gl(2) = kdim ; ll(2) = kdim
1500	gl(3) = glen(3) ; ll(3) = llen(3)
1501	CASE ( DATA_ORDER_XYZ )
1502	gl(1) = glen(1) ; ll(1) = llen(1)
1503	gl(2) = glen(2) ; ll(2) = llen(2)
1504	gl(3) = kdim ; ll(3) = kdim
1505	CASE DEFAULT
1506	END SELECT
1507	if ( kdim > 1 ) then
1508	CALL rsl_build_message(msg_msg,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
1509	else if ( kdim == 1 ) then
1510	CALL rsl_build_message(msg_msg,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1511	endif
1512	RETURN
1513	END SUBROUTINE add_msg_80pt_doubleprecision
1514	#endif
1515
1516	SUBROUTINE add_msg_80pt_integer ( fld , kdim )
1517	IMPLICIT NONE
1518	integer kdim, gl(3), ll(3)
1519	integer fld(*)
1520	SELECT CASE ( model_data_order )
1521	! need to finish other cases
1522	CASE ( DATA_ORDER_XZY )
1523	gl(1) = glen(1) ; ll(1) = llen(1)
1524	gl(2) = kdim ; ll(2) = kdim
1525	gl(3) = glen(3) ; ll(3) = llen(3)
1526	CASE ( DATA_ORDER_XYZ )
1527	gl(1) = glen(1) ; ll(1) = llen(1)
1528	gl(2) = glen(2) ; ll(2) = llen(2)
1529	gl(3) = kdim ; ll(3) = kdim
1530	CASE DEFAULT
1531	END SELECT
1532	if ( kdim > 1 ) then
1533	CALL rsl_build_message(msg_msg,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
1534	else if ( kdim == 1 ) then
1535	CALL rsl_build_message(msg_msg,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
1536	endif
1537	RETURN
1538	END SUBROUTINE add_msg_80pt_integer
1539
1540	SUBROUTINE add_msg_120pt_real ( fld , kdim )
1541	IMPLICIT NONE
1542	integer kdim, gl(3), ll(3)
1543	real fld(*)
1544	CALL add_msg_80pt ( fld , kdim )
1545	RETURN
1546	END SUBROUTINE add_msg_120pt_real
1547
1548	#if ( RWORDSIZE != DWORDSIZE )
1549	SUBROUTINE add_msg_120pt_doubleprecision ( fld , kdim )
1550	IMPLICIT NONE
1551	integer kdim, gl(3), ll(3)
1552	doubleprecision fld(*)
1553	CALL add_msg_80pt ( fld , kdim )
1554	RETURN
1555	END SUBROUTINE add_msg_120pt_doubleprecision
1556	#endif
1557
1558	SUBROUTINE add_msg_120pt_integer ( fld , kdim )
1559	IMPLICIT NONE
1560	integer kdim, gl(3), ll(3)
1561	integer fld(*)
1562	CALL add_msg_80pt ( fld , kdim )
1563	RETURN
1564	END SUBROUTINE add_msg_120pt_integer
1565
1566	SUBROUTINE stencil_y_shift ( did , stenid )
1567	IMPLICIT NONE
1568	INTEGER did, stenid
1569	INTEGER i
1570	DO i = 1, 48
1571	messages(i) = n1
1572	ENDDO
1573	CALL rsl_create_stencil( stenid )
1574	CALL rsl_describe_stencil ( did, stenid, RSL_48PT, messages )
1575	RETURN
1576	END SUBROUTINE stencil_y_shift
1577
1578	SUBROUTINE stencil_x_shift ( did , stenid )
1579	IMPLICIT NONE
1580	INTEGER did, stenid
1581	INTEGER i
1582	DO i = 1, 48
1583	messages(i) = w1
1584	ENDDO
1585	CALL rsl_create_stencil( stenid )
1586	CALL rsl_describe_stencil ( did, stenid, RSL_48PT, messages )
1587	RETURN
1588	END SUBROUTINE stencil_x_shift
1589
1590	SUBROUTINE stencil_4pt ( did, stenid )
1591	IMPLICIT NONE
1592	INTEGER did, stenid
1593	messages(1) = n1
1594	messages(2) = w1
1595	messages(3) = e1
1596	messages(4) = s1
1597	CALL rsl_create_stencil( stenid )
1598	CALL rsl_describe_stencil ( did, stenid, RSL_4PT, messages )
1599	RETURN
1600	END SUBROUTINE stencil_4pt
1601
1602	SUBROUTINE stencil_8pt ( did, stenid )
1603	IMPLICIT NONE
1604	INTEGER did, stenid
1605	messages(1) = nw
1606	messages(2) = n1
1607	messages(3) = ne
1608	messages(4) = w1
1609	messages(5) = e1
1610	messages(6) = sw
1611	messages(7) = s1
1612	messages(8) = se
1613	CALL rsl_create_stencil( stenid )
1614	CALL rsl_describe_stencil ( did, stenid, RSL_8PT, messages )
1615	RETURN
1616	END SUBROUTINE stencil_8pt
1617
1618	SUBROUTINE stencil_12pt ( did, stenid )
1619	IMPLICIT NONE
1620	INTEGER did, stenid
1621	messages(1) = n2
1622	messages(2) = nw
1623	messages(3) = n1
1624	messages(4) = ne
1625	messages(5) = w2
1626	messages(6) = w1
1627	messages(7) = e1
1628	messages(8) = e2
1629	messages(9) = sw
1630	messages(10) = s1
1631	messages(11) = se
1632	messages(12) = s2
1633	CALL rsl_create_stencil( stenid )
1634	CALL rsl_describe_stencil ( did, stenid, RSL_12PT, messages )
1635	RETURN
1636	END SUBROUTINE stencil_12pt
1637
1638	SUBROUTINE stencil_24pt ( did, stenid )
1639	IMPLICIT NONE
1640	INTEGER did, stenid, i
1641	messages( 1) = n2w2
1642	messages( 2) = n2w
1643	messages( 3) = n2
1644	messages( 4) = n2e
1645	messages( 5) = n2e2
1646	messages( 6) = nw2
1647	messages( 7) = nw
1648	messages( 8) = n1
1649	messages( 9) = ne
1650	messages(10) = ne2
1651	messages(11) = w2
1652	messages(12) = w1
1653	messages(13) = e1
1654	messages(14) = e2
1655	messages(15) = sw2
1656	messages(16) = sw
1657	messages(17) = s1
1658	messages(18) = se
1659	messages(19) = se2
1660	messages(20) = s2w2
1661	messages(21) = s2w
1662	messages(22) = s2
1663	messages(23) = s2e
1664	messages(24) = s2e2
1665	CALL rsl_create_stencil( stenid )
1666	CALL rsl_describe_stencil ( did, stenid, RSL_24PT, messages )
1667	RETURN
1668	END SUBROUTINE stencil_24pt
1669
1670	SUBROUTINE stencil_48pt ( did, stenid )
1671	IMPLICIT NONE
1672	INTEGER did, stenid, i
1673	messages( 1) = n3w3
1674	messages( 2) = n3w2
1675	messages( 3) = n3w
1676	messages( 4) = n3
1677	messages( 5) = n3e
1678	messages( 6) = n3e2
1679	messages( 7) = n3e3
1680	messages( 8) = n2w3
1681	messages( 9) = n2w2
1682	messages(10) = n2w
1683	messages(11) = n2
1684	messages(12) = n2e
1685	messages(13) = n2e2
1686	messages(14) = n2e3
1687	messages(15) = nw3
1688	messages(16) = nw2
1689	messages(17) = nw
1690	messages(18) = n1
1691	messages(19) = ne
1692	messages(20) = ne2
1693	messages(21) = ne3
1694	messages(22) = w3
1695	messages(23) = w2
1696	messages(24) = w1
1697	messages(25) = e1
1698	messages(26) = e2
1699	messages(27) = e3
1700	messages(28) = sw3
1701	messages(29) = sw2
1702	messages(30) = sw
1703	messages(31) = s1
1704	messages(32) = se
1705	messages(33) = se2
1706	messages(34) = se3
1707	messages(35) = s2w3
1708	messages(36) = s2w2
1709	messages(37) = s2w
1710	messages(38) = s2
1711	messages(39) = s2e
1712	messages(40) = s2e2
1713	messages(41) = s2e3
1714	messages(42) = s3w3
1715	messages(43) = s3w2
1716	messages(44) = s3w
1717	messages(45) = s3
1718	messages(46) = s3e
1719	messages(47) = s3e2
1720	messages(48) = s3e3
1721	CALL rsl_create_stencil( stenid )
1722	CALL rsl_describe_stencil ( did, stenid, RSL_48PT, messages )
1723	RETURN
1724	END SUBROUTINE stencil_48pt
1725
1726	SUBROUTINE stencil_80pt ( did, stenid )
1727	IMPLICIT NONE
1728	INTEGER did, stenid, i
1729	#if 1
1730	do i = 1, 80
1731	messages(i) = msg_msg
1732	enddo
1733	#else
1734	messages(1)= n4w4
1735	messages(2)= n4w3
1736	messages(3)= n4w2
1737	messages(4)= n4w
1738	messages(5)= n4
1739	messages(6)= n4e
1740	messages(7)= n4e2
1741	messages(8)= n4e3
1742	messages(9)= n4e4
1743	messages(10)= n3w4
1744	messages(11)= n3w3
1745	messages(12)= n3w2
1746	messages(13)= n3w
1747	messages(14)= n3
1748	messages(15)= n3e
1749	messages(16)= n3e2
1750	messages(17)= n3e3
1751	messages(18)= n3e4
1752	messages(19)= n2w4
1753	messages(20)= n2w3
1754	messages(21)= n2w2
1755	messages(22)= n2w
1756	messages(23)= n2
1757	messages(24)= n2e
1758	messages(25)= n2e2
1759	messages(26)= n2e3
1760	messages(27)= n2e4
1761	messages(28)= nw4
1762	messages(29)= nw3
1763	messages(30)= nw2
1764	messages(31)= nw
1765	messages(32)= n1
1766	messages(33)= ne
1767	messages(34)= ne2
1768	messages(35)= ne3
1769	messages(36)= ne4
1770	messages(37)= w4
1771	messages(38)= w3
1772	messages(39)= w2
1773	messages(40)= w1
1774	messages(41)= e1
1775	messages(42)= e2
1776	messages(43)= e3
1777	messages(44)= e4
1778	messages(45)= sw4
1779	messages(46)= sw3
1780	messages(47)= sw2
1781	messages(48)= sw
1782	messages(49)= s1
1783	messages(50)= se
1784	messages(51)= se2
1785	messages(52)= se3
1786	messages(53)= se4
1787	messages(54)= s2w4
1788	messages(55)= s2w3
1789	messages(56)= s2w2
1790	messages(57)= s2w
1791	messages(58)= s2
1792	messages(59)= s2e
1793	messages(60)= s2e2
1794	messages(61)= s2e3
1795	messages(62)= s2e4
1796	messages(63)= s3w4
1797	messages(64)= s3w3
1798	messages(65)= s3w2
1799	messages(66)= s3w
1800	messages(67)= s3
1801	messages(68)= s3e
1802	messages(69)= s3e2
1803	messages(70)= s3e3
1804	messages(71)= s3e4
1805	messages(72)= s4w4
1806	messages(73)= s4w3
1807	messages(74)= s4w2
1808	messages(75)= s4w
1809	messages(76)= s4
1810	messages(77)= s4e
1811	messages(78)= s4e2
1812	messages(79)= s4e3
1813	messages(80)= s4e4
1814	#endif
1815	CALL rsl_create_stencil( stenid )
1816	CALL rsl_describe_stencil ( did, stenid, RSL_80PT, messages )
1817	RETURN
1818	END SUBROUTINE stencil_80pt
1819
1820	SUBROUTINE stencil_120pt ( did, stenid )
1821	IMPLICIT NONE
1822	INTEGER did, stenid, i
1823	#if 1
1824	do i = 1, 120
1825	messages(i) = msg_msg
1826	enddo
1827	#else
1828	messages(1)= n5w5
1829	messages(2)= n5w4
1830	messages(3)= n5w3
1831	messages(4)= n5w2
1832	messages(5)= n5w
1833	messages(6)= n5
1834	messages(7)= n5e
1835	messages(8)= n5e2
1836	messages(9)= n5e3
1837	messages(10)= n5e4
1838	messages(11)= n5e5
1839	messages(12)= n4w5
1840	messages(13)= n4w4
1841	messages(14)= n4w3
1842	messages(15)= n4w2
1843	messages(16)= n4w
1844	messages(17)= n4
1845	messages(18)= n4e
1846	messages(19)= n4e2
1847	messages(20)= n4e3
1848	messages(21)= n4e4
1849	messages(22)= n4e5
1850	messages(23)= n3w5
1851	messages(24)= n3w4
1852	messages(25)= n3w3
1853	messages(26)= n3w2
1854	messages(27)= n3w
1855	messages(28)= n3
1856	messages(29)= n3e
1857	messages(30)= n3e2
1858	messages(31)= n3e3
1859	messages(32)= n3e4
1860	messages(33)= n3e5
1861	messages(34)= n2w5
1862	messages(35)= n2w4
1863	messages(36)= n2w3
1864	messages(37)= n2w2
1865	messages(38)= n2w
1866	messages(39)= n2
1867	messages(40)= n2e
1868	messages(41)= n2e2
1869	messages(42)= n2e3
1870	messages(43)= n2e4
1871	messages(44)= n2e5
1872	messages(45)= nw5
1873	messages(46)= nw4
1874	messages(47)= nw3
1875	messages(48)= nw2
1876	messages(49)= nw
1877	messages(50)= n1
1878	messages(51)= ne
1879	messages(52)= ne2
1880	messages(53)= ne3
1881	messages(54)= ne4
1882	messages(55)= ne5
1883	messages(56)= w5
1884	messages(57)= w4
1885	messages(58)= w3
1886	messages(59)= w2
1887	messages(60)= w1
1888	messages(61)= e1
1889	messages(62)= e2
1890	messages(63)= e3
1891	messages(64)= e4
1892	messages(65)= e5
1893	messages(66)= sw5
1894	messages(67)= sw4
1895	messages(68)= sw3
1896	messages(69)= sw2
1897	messages(70)= sw
1898	messages(71)= s1
1899	messages(72)= se
1900	messages(73)= se2
1901	messages(74)= se3
1902	messages(75)= se4
1903	messages(76)= se5
1904	messages(77)= s2w5
1905	messages(78)= s2w4
1906	messages(79)= s2w3
1907	messages(80)= s2w2
1908	messages(81)= s2w
1909	messages(82)= s2
1910	messages(83)= s2e
1911	messages(84)= s2e2
1912	messages(85)= s2e3
1913	messages(86)= s2e4
1914	messages(87)= s2e5
1915	messages(88)= s3w5
1916	messages(89)= s3w4
1917	messages(90)= s3w3
1918	messages(91)= s3w2
1919	messages(92)= s3w
1920	messages(93)= s3
1921	messages(94)= s3e
1922	messages(95)= s3e2
1923	messages(96)= s3e3
1924	messages(97)= s3e4
1925	messages(98)= s3e5
1926	messages(99)= s4w5
1927	messages(100)= s4w4
1928	messages(101)= s4w3
1929	messages(102)= s4w2
1930	messages(103)= s4w
1931	messages(104)= s4
1932	messages(105)= s4e
1933	messages(106)= s4e2
1934	messages(107)= s4e3
1935	messages(108)= s4e4
1936	messages(109)= s4e5
1937	messages(110)= s5w5
1938	messages(111)= s5w4
1939	messages(112)= s5w3
1940	messages(113)= s5w2
1941	messages(114)= s5w
1942	messages(115)= s5
1943	messages(116)= s5e
1944	messages(117)= s5e2
1945	messages(118)= s5e3
1946	messages(119)= s5e4
1947	messages(120)= s5e5
1948	#endif
1949	CALL rsl_create_stencil( stenid )
1950	CALL rsl_describe_stencil ( did, stenid, RSL_120PT, messages )
1951	RETURN
1952	END SUBROUTINE stencil_120pt
1953
1954	SUBROUTINE period_def ( did, perid, w )
1955	IMPLICIT NONE
1956	INTEGER did, perid, w
1957	CALL rsl_create_period( perid )
1958	CALL rsl_describe_period ( did, perid, w, msg )
1959	RETURN
1960	END SUBROUTINE period_def
1961
1962	SUBROUTINE setup_halo_rsl( grid )
1963	USE module_domain
1964	IMPLICIT NONE
1965	TYPE(domain) , INTENT (INOUT) :: grid
1966	INTEGER i, kms, ims, jms
1967	! executable
1968	SELECT CASE ( model_data_order )
1969	! need to finish other cases
1970	CASE ( DATA_ORDER_ZXY )
1971	kms = grid%sm31
1972	ims = grid%sm32
1973	jms = grid%sm33
1974	decomp(1) = RSL_NOTDECOMPOSED
1975	decomp(2) = RSL_M
1976	decomp(3) = RSL_N
1977	decomp2d(1) = RSL_M
1978	decomp2d(2) = RSL_N
1979	glen2d(1) = grid%ed32 - grid%sd32 + 1
1980	glen2d(2) = grid%ed33 - grid%sd33 + 1
1981	llen2d(1) = grid%em32 - grid%sm32 + 1
1982	llen2d(2) = grid%em33 - grid%sm33 + 1
1983	CASE ( DATA_ORDER_XYZ )
1984	kms = grid%sm33
1985	ims = grid%sm31
1986	jms = grid%sm32
1987	decomp(1) = RSL_M
1988	decomp(2) = RSL_N
1989	decomp(3) = RSL_NOTDECOMPOSED
1990	decomp2d(1) = RSL_M
1991	decomp2d(2) = RSL_N
1992	glen2d(1) = grid%ed31 - grid%sd31 + 1
1993	glen2d(2) = grid%ed32 - grid%sd32 + 1
1994	llen2d(1) = grid%em31 - grid%sm31 + 1
1995	llen2d(2) = grid%em32 - grid%sm32 + 1
1996	CASE ( DATA_ORDER_XZY )
1997	kms = grid%sm32
1998	ims = grid%sm31
1999	jms = grid%sm33
2000	decomp(1) = RSL_M
2001	decomp(2) = RSL_NOTDECOMPOSED
2002	decomp(3) = RSL_N
2003	decomp2d(1) = RSL_M
2004	decomp2d(2) = RSL_N
2005	glen2d(1) = grid%ed31 - grid%sd31 + 1
2006	glen2d(2) = grid%ed33 - grid%sd33 + 1
2007	llen2d(1) = grid%em31 - grid%sm31 + 1
2008	llen2d(2) = grid%em33 - grid%sm33 + 1
2009	CASE ( DATA_ORDER_YXZ )
2010	kms = grid%sm33
2011	ims = grid%sm32
2012	jms = grid%sm31
2013	decomp(1) = RSL_N
2014	decomp(2) = RSL_M
2015	decomp(3) = RSL_NOTDECOMPOSED
2016	decomp2d(1) = RSL_N
2017	decomp2d(2) = RSL_M
2018	glen2d(1) = grid%ed32 - grid%sd32 + 1
2019	glen2d(2) = grid%ed31 - grid%sd31 + 1
2020	llen2d(1) = grid%em32 - grid%sm32 + 1
2021	llen2d(2) = grid%em31 - grid%sm31 + 1
2022	END SELECT
2023
2024	glen(1) = grid%ed31 - grid%sd31 + 1
2025	glen(2) = grid%ed32 - grid%sd32 + 1
2026	glen(3) = grid%ed33 - grid%sd33 + 1
2027	llen(1) = grid%em31 - grid%sm31 + 1
2028	llen(2) = grid%em32 - grid%sm32 + 1
2029	llen(3) = grid%em33 - grid%sm33 + 1
2030
2031	END SUBROUTINE setup_halo_rsl
2032
2033
2034	SUBROUTINE setup_xpose_rsl( grid )
2035	USE module_domain
2036	IMPLICIT NONE
2037	TYPE(domain) , INTENT (INOUT) :: grid
2038	INTEGER i, kms, ims, jms
2039
2040	CALL setup_halo_rsl ( grid )
2041
2042	llen_tx(1) = grid%em31x - grid%sm31x + 1
2043	llen_tx(2) = grid%em32x - grid%sm32x + 1
2044	llen_tx(3) = grid%em33x - grid%sm33x + 1
2045	llen_ty(1) = grid%em31y - grid%sm31y + 1
2046	llen_ty(2) = grid%em32y - grid%sm32y + 1
2047	llen_ty(3) = grid%em33y - grid%sm33y + 1
2048
2049	END SUBROUTINE setup_xpose_rsl
2050
2051	SUBROUTINE setup_period_rsl( grid )
2052	USE module_domain
2053	IMPLICIT NONE
2054	TYPE(domain) , INTENT (INOUT) :: grid
2055	INTEGER i, kms, ims, jms
2056
2057	CALL setup_xpose_rsl ( grid )
2058
2059	! Define periodic BC's -- for the period routines, the glen
2060	! array contains the actual logical size of the field (that is,
2061	! staggering is explicitly stated). Llen is not affected.
2062
2063	SELECT CASE ( model_data_order )
2064	! need to finish other cases
2065	CASE ( DATA_ORDER_XZY )
2066
2067	glen(1) = grid%ed31 - grid%sd31
2068	glen(2) = grid%ed32 - grid%sd32 + 1
2069	glen(3) = grid%ed33 - grid%sd33
2070	glenx(1) = glen(1)
2071	glenx(2) = glen(2)
2072	glenx(3) = glen(3)
2073	gleny(1) = glen(1)
2074	gleny(2) = glen(2)
2075	gleny(3) = glen(3)
2076	glenxy(1) = glen(1)
2077	glenxy(2) = glen(2)
2078	glenxy(3) = glen(3)
2079	llenx(1) = llen(1)
2080	llenx(2) = llen(2)
2081	llenx(3) = llen(3)
2082	lleny(1) = llen(1)
2083	lleny(2) = llen(2)
2084	lleny(3) = llen(3)
2085	llenxy(1) = llen(1)
2086	llenxy(2) = llen(2)
2087	llenxy(3) = llen(3)
2088
2089	glen2d(1) = grid%ed31 - grid%sd31
2090	glen2d(2) = grid%ed33 - grid%sd33
2091	glenx2d(1) = glen2d(1)
2092	glenx2d(2) = glen2d(2)
2093	gleny2d(1) = glen2d(1)
2094	gleny2d(2) = glen2d(2)
2095	glenxy2d(1) = glen2d(1)
2096	glenxy2d(2) = glen2d(2)
2097	llenx2d(1) = llen2d(1)
2098	llenx2d(2) = llen2d(2)
2099	lleny2d(1) = llen2d(1)
2100	lleny2d(2) = llen2d(2)
2101	llenxy2d(1) = llen2d(1)
2102	llenxy2d(2) = llen2d(2)
2103
2104	decompx(1) = RSL_M_STAG
2105	decompx(2) = RSL_NOTDECOMPOSED
2106	decompx(3) = RSL_N
2107	decompy(1) = RSL_M
2108	decompy(2) = RSL_NOTDECOMPOSED
2109	decompy(3) = RSL_N_STAG
2110	decompxy(1) = RSL_M_STAG
2111	decompxy(2) = RSL_NOTDECOMPOSED
2112	decompxy(3) = RSL_N_STAG
2113
2114	decomp2d(1) = RSL_M
2115	decomp2d(2) = RSL_N
2116
2117	decompx2d(1) = RSL_M_STAG
2118	decompx2d(2) = RSL_N
2119
2120	decompy2d(1) = RSL_M
2121	decompy2d(2) = RSL_N_STAG
2122
2123	decompxy2d(1) = RSL_M_STAG
2124	decompxy2d(2) = RSL_N_STAG
2125
2126	CASE DEFAULT
2127	CALL wrf_error_fatal ( "module_dm: setup_period_rsl: unsuppported data order" )
2128
2129	END SELECT
2130
2131	RETURN
2132	END SUBROUTINE setup_period_rsl
2133
2134	!------------------------------------------------------------------
2135	INTEGER FUNCTION intermediate_mapping ( w1, w2, info, m, n, py, px )
2136	IMPLICIT NONE
2137	INTEGER, DIMENSION(*) :: w1, w2
2138	REAL, DIMENSION(*) :: info
2139	INTEGER, INTENT(IN) :: m, n, py, px
2140	INTEGER :: nest_m, nest_n, nri, nrj, nest_domdesc, shw
2141	! <DESCRIPTION>
2142	! This is a routine provided by the rsl external comm layer.
2143	! and is defined in external/RSL/module_dm.F, which is copied
2144	! into frame/module_dm.F at compile time. Changes to frame/module_dm.F
2145	! will be lost.
2146	!
2147	! This routine is related to nesting and is used by the rsl domain
2148	! decomposition algorithm to decompose an domain that serves as an
2149	! intermediary between the parent domain and the nest. This intermediate
2150	! domain is at the coarse domain's resolution but it is only large enough
2151	! to cover the region of the nested domain plus an extra number of cells
2152	! out onto the coarse domain around the region of the nest (this number
2153	! is specified by the namelist variable shw, default 2). The intermediate
2154	! domain is decomposed using the nested domain's decomposition
2155	! information so that all interpolations from coarse domain data to the
2156	! nest may be done locally on the processor without communication. (The
2157	! communication occurs during the transfer of data between the parent
2158	! domain and the intermediate domain. See <a
2159	! href=interp_domain_em_part1.html>interp_domain_em_part1</a>, <a
2160	! href=interp_domain_em_part2.html>interp_domain_em_part2</a>, <a
2161	! href=force_domain_em_part2.html>force_domain_em_part2</a>, <a
2162	! href=feedback_domain_em_part1.html>feedback_domain_em_part1</a>, and <a
2163	! href=feedback_domain_em_part2.html>feedback_domain_em_part2</a>.)
2164	!
2165	! This routine and it's companion intermediate_mapping2 call the rsl
2166	! routine GET_DOMAIN_DECOMP passing it the rsl domain descriptor for the
2167	! nest to retrieve from rsl the nested decomposition. This information
2168	! is then used to decomposed the intermediate domain.
2169	!
2170	! Rsl is given the intermediate_mapping function to use when decomposing
2171	! the intermediate domain with a call to:
2172	!
2173	! <tt>CALL set_def_decomp_fcn1 ( intermediate_domdesc, intermediate_mapping )</tt>
2174	!
2175	! inside the routine <a href=patch_domain_rsl.html>patch_domain_rsl</a>
2176	! that is also defined in external/RSL/module_dm.F.
2177	!
2178	! </DESCRIPTION>
2179
2180	nest_m = int(info(1)+.01) ; nest_n = int(info(2)+.01) ; nest_domdesc = int(info(3)+.01)
2181	nri = int(info(4)+.01) ; nrj = int(info(5)+.01)
2182	shw = int(info(6)+.01)
2183	CALL intermediate_mapping2 ( w1, w2, info, m, n, nest_m, nest_n, nest_domdesc, py, px, nri, nrj, shw )
2184	intermediate_mapping = 0
2185	RETURN
2186	END FUNCTION intermediate_mapping
2187
2188	SUBROUTINE intermediate_mapping2 ( w1, w2, info, m, n, nest_m, nest_n, nest_domdesc, py, px, nri, nrj, shw )
2189	IMPLICIT NONE
2190	INTEGER, DIMENSION(*) :: w1, w2
2191	REAL, DIMENSION(*) :: info
2192	INTEGER, INTENT(IN) :: m, n, nest_m, nest_n, nest_domdesc, py, px, nri, nrj, shw
2193	INTEGER :: nest_decomp( nest_m, nest_n )
2194	INTEGER :: i, j
2195	! <DESCRIPTION>
2196	! See <a href=intermediate_mapping.html>intermediate_mapping</a>.
2197	! </DESCRIPTION>
2198
2199
2200	CALL GET_DOMAIN_DECOMP ( nest_domdesc, nest_decomp, nest_m*nest_n )
2201	DO j = 1, nest_n, nrj
2202	DO i = 1, nest_m, nri
2203	w2((i/nri+1+shw) + (j/nrj+1-1+shw)*m) = nest_decomp(i,j)
2204	ENDDO
2205	ENDDO
2206	#if 1
2207	! fill out the stencil to the edges of the intermediate domain
2208	do j = 1,n
2209	do i = 1,shw
2210	w2(i+(j-1)m) = w2(shw+1+(j-1)m)
2211	enddo
2212	do i = m,m-shw-1,-1
2213	w2(i+(j-1)m) = w2(m-shw-2+(j-1)m)
2214	enddo
2215	enddo
2216	do i = 1,m
2217	do j = 1,shw
2218	w2(i+(j-1)m) = w2(i+(shw+1-1)m)
2219	enddo
2220	do j = n,n-shw-1,-1
2221	w2(i+(j-1)m) = w2(i+(n-shw-2-1)m)
2222	enddo
2223	enddo
2224	#endif
2225
2226	RETURN
2227	END SUBROUTINE intermediate_mapping2
2228
2229	!------------------------------------------------------------------
2230
2231	SUBROUTINE patch_domain_rsl( id , domdesc , parent, parent_id , parent_domdesc , &
2232	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
2233	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
2234	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
2235	sp1x , ep1x , sm1x , em1x , &
2236	sp2x , ep2x , sm2x , em2x , &
2237	sp3x , ep3x , sm3x , em3x , &
2238	sp1y , ep1y , sm1y , em1y , &
2239	sp2y , ep2y , sm2y , em2y , &
2240	sp3y , ep3y , sm3y , em3y , &
2241	bdx , bdy )
2242
2243	USE module_domain
2244	USE module_machine
2245
2246	IMPLICIT NONE
2247	INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
2248	INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
2249	sm1 , em1 , sm2 , em2 , sm3 , em3
2250	INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
2251	sm1x , em1x , sm2x , em2x , sm3x , em3x
2252	INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
2253	sm1y , em1y , sm2y , em2y , sm3y , em3y
2254	INTEGER, INTENT(IN) :: id
2255	INTEGER, INTENT(OUT) :: domdesc
2256	INTEGER, INTENT(IN) :: parent_id
2257	INTEGER, INTENT(IN) :: parent_domdesc
2258	TYPE(domain),POINTER :: parent
2259
2260	! <DESCRIPTION>
2261	! This is a routine provided by the rsl external comm layer.
2262	! and is defined in external/RSL/module_dm.F, which is copied
2263	! into frame/module_dm.F at compile time. Changes to frame/module_dm.F
2264	! will be lost.
2265	!
2266	! This routine is called by <a
2267	! href=wrf_dm_patch_domain.html>wrf_dm_patch_domain</a>, the rsl
2268	! package-supplied routine that is called by <a
2269	! href=wrf_patch_domain.html>wrf_patch_domain</a> in the course of
2270	! setting up a new domain when running WRF on distributed memory parallel
2271	! computers. This provides the rsl-specific mechanisms for defining and
2272	! decomposing a domain, and for associating it within rsl to it's parent
2273	! domain (in the case of a nest).
2274	!
2275	! The routine takes as input arguments the domain id, the index of the
2276	! domain in the namelist (top-most domain is id=1) the parent's id and
2277	! rsl domain descriptor (if there is a parent), and the the global
2278	! (undecomposed) dimensions of the new domain. The routine returns the
2279	! patch dimensions (computational extent), memory dimensions (local
2280	! array sizes on each task), and an rsl domain descriptor for the new
2281	! domain. The width of the x and y boundary regions is also passed in
2282	! (defined in <a href=../../share/module_bc.f>share/module_bc.F</a>) and
2283	! are used in the calculation of the memory dimensions.
2284	!
2285	! <b>Nesting </b>
2286	!
2287	! This routine also defines, decomposes, and associates the intermediate
2288	! domain that is used to transfer forcing and feedback data between a
2289	! nest and its parent domain.
2290	!
2291	! The relationship between a parent domain, the nest, and this
2292	! intermediate domain is stored partly in rsl and partly in WRF as fields
2293	! in the TYPE(domain) data structure (defined in <a
2294	! href=../../frame/module_domain.f>frame/module_domain.F</a>).
2295	!
2296	! Basically, the rsl-maintained relationship is between the parent domain
2297	! and the intermediate domain; for purposes of interprocessor
2298	! communication and forcing and feedback, rsl considers the nest a
2299	! standalone domain. This is because all of the rsl-mediated
2300	! communication for moving data between processors for forcing and
2301	! feedback is between the parent and the intermediate domain. The
2302	! movement of data between the intermediate domain and the nest is all
2303	! on-processor, and therefore does not involve rsl to a large extent.
2304	!
2305	! The WRF-maintained relationship between a parent and a nest is
2306	! represented through pointers in TYPE(domain). The parent domain
2307	! maintains an array of pointers to its children through the
2308	! <em>nests</em> field of TYPE(domain). The nest has a back-pointer to
2309	! its parent through <em>parents</em> (there is only ever one parent of a
2310	! nest in WRF). The nest also holds the pointer to the intermediate
2311	! domain, called <em>intermediate_grid</em>.
2312	!
2313	! The actual forcing and feedback between parent, nest, and intermediate
2314	! domains are handled by other routines defined in
2315	! external/RSL/module_dm.F. See See <a
2316	! href=interp_domain_em_part1.html>interp_domain_em_part1</a>, <a
2317	! href=interp_domain_em_part2.html>interp_domain_em_part2</a>, <a
2318	! href=force_domain_em_part2.html>force_domain_em_part2</a>, <a
2319	! href=feedback_domain_em_part1.html>feedback_domain_em_part1</a>, and <a
2320	! href=feedback_domain_em_part2.html>feedback_domain_em_part2</a>.)
2321	!
2322	! </DESCRIPTION>
2323
2324	! Local variables
2325	INTEGER :: c_sd1 , c_ed1 , c_sd2 , c_ed2 , c_sd3 , c_ed3
2326	INTEGER :: c_sp1 , c_ep1 , c_sp2 , c_ep2 , c_sp3 , c_ep3 , &
2327	c_sm1 , c_em1 , c_sm2 , c_em2 , c_sm3 , c_em3
2328	INTEGER :: c_sp1x , c_ep1x , c_sp2x , c_ep2x , c_sp3x , c_ep3x , &
2329	c_sm1x , c_em1x , c_sm2x , c_em2x , c_sm3x , c_em3x
2330	INTEGER :: c_sp1y , c_ep1y , c_sp2y , c_ep2y , c_sp3y , c_ep3y , &
2331	c_sm1y , c_em1y , c_sm2y , c_em2y , c_sm3y , c_em3y
2332
2333	INTEGER :: mloc , nloc , zloc ! all k on same proc
2334	INTEGER :: mloc_x , nloc_x , zloc_x ! all x on same proc
2335	INTEGER :: mloc_y , nloc_y , zloc_y ! all y on same proc
2336	INTEGER :: c_mloc , c_nloc , c_zloc ! all k on same proc
2337	INTEGER :: c_mloc_x , c_nloc_x , c_zloc_x ! all x on same proc
2338	INTEGER :: c_mloc_y , c_nloc_y , c_zloc_y ! all y on same proc
2339	INTEGER :: mglob , nglob
2340	INTEGER :: idim , jdim , kdim , i
2341	INTEGER , PARAMETER :: rsl_jjx_x = 2047
2342	INTEGER , DIMENSION( rsl_jjx_x ) :: rsl_js_x0 , rsl_je_x0 , rsl_is_x0 , rsl_ie_x0
2343	INTEGER :: rsl_xinest_x0 , rsl_idif_x0 , rsl_jdif_x0
2344	INTEGER :: i_parent_start , j_parent_start
2345	INTEGER :: ids, ide, jds, jde, kds, kde
2346	INTEGER :: c_ids, c_ide, c_jds, c_jde, c_kds, c_kde
2347	INTEGER :: parent_grid_ratio
2348	INTEGER :: shw
2349	INTEGER :: idim_cd, jdim_cd, intermediate_domdesc
2350	INTEGER :: intermediate_mloc, intermediate_nloc
2351	INTEGER :: intermediate_mglob, intermediate_nglob
2352	REAL :: info(7)
2353	TYPE(domain), POINTER :: intermediate_grid
2354	TYPE(domain), POINTER :: nest_grid
2355
2356	SELECT CASE ( model_data_order )
2357	! need to finish other cases
2358	CASE ( DATA_ORDER_ZXY )
2359	idim = ed2-sd2+1
2360	jdim = ed3-sd3+1
2361	kdim = ed1-sd1+1
2362	CASE ( DATA_ORDER_XYZ )
2363	idim = ed1-sd1+1
2364	jdim = ed2-sd2+1
2365	kdim = ed3-sd3+1
2366	CASE ( DATA_ORDER_XZY )
2367	idim = ed1-sd1+1
2368	jdim = ed3-sd3+1
2369	kdim = ed2-sd2+1
2370	CASE ( DATA_ORDER_YXZ)
2371	idim = ed2-sd2+1
2372	jdim = ed1-sd1+1
2373	kdim = ed3-sd3+1
2374	END SELECT
2375	if ( id == 1 ) then
2376	! <DESCRIPTION>
2377	! <b> Main Domain </b>
2378	!
2379	! The top-level WRF domain (id = 1) is set up when <a
2380	! href=alloc_and_configure_domain.html>alloc_and_configure_domain</a> is
2381	! called from <a href=wrf.html>wrf</a>. This is done here in
2382	! rsl_patch_domain with a call to RSL_MOTHER_DOMAIN3D. The global domain
2383	! dimensions are converted to the length of each dimension in i, j, and k
2384	! for the domain (based on model_data_order, which is defined in <a
2385	! href=../../frame/module_driver_constants.f>frame/module_driver_constants.F</a>,
2386	! based on the dimspec entries in the Registry. In WRF the X/I dimension
2387	! corresponds to the the first dimension, the Z/K dimension the second,
2388	! and the Y/J the third.
2389	!
2390	! An rsl tag denoting the largest stencil to be used on the domain is
2391	! also provided. This is RSL_24PT for the EM core; the NMM core uses a
2392	! wider maximum stencil, RSL_120PT. On return, the RSL domain descriptor
2393	! for the domain will be defined along with rsl's advice on the minimum
2394	! memory required for the memory dimensions on this task.
2395	!
2396	! Rsl supports
2397	! alternate decompositions of the domain -- X/Z and Y/Z -- and
2398	! transposition operations between these decompositions. These are used
2399	! in WRF 3DVAR but not in the EM version of the WRF model itself, which
2400	! is always only an X/Y decomposition.
2401	!
2402	! As a diagnostic, the rsl routine SHOW_DOMAIN_DECOMP is called, which
2403	! outputs a text file with information on the decomposition to the
2404	! file show_domain_0000 from processor zero.
2405	!
2406	! The actual memory dimensions that patch_domain_rsl are computed in a
2407	! call to <a
2408	! href=compute_memory_dims_using_rsl.html>compute_memory_dims_using_rsl</a>,
2409	! also defined in external/RSL/module_dm.F. Once these have been computed
2410	! the patch_domain_rsl returns.
2411	!
2412	! </DESCRIPTION>
2413
2414	#ifndef NMM_CORE
2415	CALL rsl_mother_domain3d(domdesc, RSL_24PT, &
2416	#else
2417	CALL rsl_mother_domain3d(domdesc, RSL_120PT, &
2418	#endif
2419	idim , jdim , kdim , &
2420	mloc , nloc , zloc , &
2421	mloc_y , nloc_y , zloc_y , & ! x->y 20020908
2422	mloc_x , nloc_x , zloc_x ) ! y->x 20020908
2423	CALL show_domain_decomp(domdesc)
2424	! this computes the dimension information for the
2425	! nest and passes these back
2426	CALL compute_memory_dims_using_rsl ( &
2427	domdesc , &
2428	mloc , nloc , zloc , &
2429	mloc_x , nloc_x , zloc_x , &
2430	mloc_y , nloc_y , zloc_y , &
2431	sd1, ed1, sd2, ed2, sd3, ed3, &
2432	sp1, ep1, sp2, ep2, sp3, ep3, &
2433	sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
2434	sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
2435	sm1, em1, sm2, em2, sm3, em3, &
2436	sm1x, em1x, sm2x, em2x, sm3x, em3x, &
2437	sm1y, em1y, sm2y, em2y, sm3y, em3y )
2438
2439	else
2440
2441	! <DESCRIPTION>
2442	! <b> Nested Domain </b>
2443	! For nested domains (id greater than 1), the patch_domain_rsl first
2444	! defines the nest itself in rsl as a stand-alone domain (as far as RSL
2445	! knows it has no parent), then sets up the the intermediate domain that,
2446	! from rsl's point of view, is a nest of the parent with a refinement
2447	! ratio of 1 to 1 (same resolution).
2448	!
2449	! As with the top-most domain, the nested domain is defined using
2450	! RSL_MOTHER_DOMAIN3D and its memory dimensions are computed calling
2451	! compute_memory_dims_using_rsl, as above.
2452	!
2453	! </DESCRIPTION>
2454	!
2455	! first spawn the actual nest. It is not
2456	! directly associated in rsl with the parent
2457	! so we spawn it as an unassociated domain
2458	! (another "mother")
2459	!
2460	#ifndef NMM_CORE
2461	CALL rsl_mother_domain3d(domdesc, RSL_24PT, &
2462	#else
2463	CALL rsl_mother_domain3d(domdesc, RSL_120PT, &
2464	#endif
2465	idim , jdim , kdim , &
2466	mloc , nloc , zloc , &
2467	mloc_y , nloc_y , zloc_y , & ! x->y 20020910
2468	mloc_x , nloc_x , zloc_x ) ! y->x 20020910
2469	CALL show_domain_decomp(domdesc)
2470	! this computes the dimension information for the
2471	! nest and passes these back
2472	CALL compute_memory_dims_using_rsl ( &
2473	domdesc , &
2474	mloc , nloc , zloc , &
2475	mloc_x , nloc_x , zloc_x , &
2476	mloc_y , nloc_y , zloc_y , &
2477	sd1, ed1, sd2, ed2, sd3, ed3, &
2478	sp1, ep1, sp2, ep2, sp3, ep3, &
2479	sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
2480	sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
2481	sm1, em1, sm2, em2, sm3, em3, &
2482	sm1x, em1x, sm2x, em2x, sm3x, em3x, &
2483	sm1y, em1y, sm2y, em2y, sm3y, em3y )
2484
2485	! <DESCRIPTION>
2486	! Once the nest is defined, the intermediate
2487	! domain is defined and associated as a nest with the parent.
2488	! Here, SET_DEF_DECOMP_FCN1 is called, which directs rsl to use a special decomposition function,
2489	! <a href=intermediate_mapping.html>intermediate_mapping</a>, that
2490	! generates a decomposition of the intermediate domain in which
2491	! intermediate domain points are assigned to the same task as the nested
2492	! points they overlay (allowing the interpolation to be task-local).
2493	! This applies only to the intermediate domain; the default decmposition function
2494	! for other domains is not affected.
2495	! This decomposition algorithm also requires knowledge of the dimensions
2496	! of the nest, the nests rsl descriptor (defined above), the nesting
2497	! ratio, and the extra amount the intermediate domain should cover in the
2498	! coarse domain to allow for the stencil of the interpolator (the <a
2499	! href=sint.html>sint</a> routine. This information is packed into an
2500	! "info" vector that is provided to rsl with a call to
2501	! SET_DEF_DECOMP_INFO.
2502	!
2503	! </DESCRIPTION>
2504
2505
2506	CALL nl_get_shw( id, shw )
2507	CALL nl_get_i_parent_start( id , i_parent_start )
2508	CALL nl_get_j_parent_start( id , j_parent_start )
2509	CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
2510
2511	info(1) = idim ! nest i dimension for intermediate mapping
2512	info(2) = jdim ! nest j dimension for intermediate mapping
2513	info(3) = domdesc ! nest domain descriptor
2514	info(4) = parent_grid_ratio ! nesting ratio in i
2515	info(5) = parent_grid_ratio ! nesting ratio in j
2516	info(6) = shw ! stencil half-width
2517
2518	# if 1
2519	! tells which descriptor will be given back next when intermediate domain is spawned below
2520	! that is used to associate the decomposition information from the nested domain with
2521	! this intermediate domain, so that it will be decomposed identically, through
2522	! the intermediate mapping function.
2523	CALL get_next_domain_descriptor ( intermediate_domdesc )
2524	CALL set_def_decomp_fcn1 ( intermediate_domdesc, intermediate_mapping )
2525	CALL set_def_decomp_info ( intermediate_domdesc, info )
2526	# endif
2527
2528	! now spawn the intermediate domain that will serve as the
2529	! nest-decomposed area of the CD domain, onto which data
2530	! will be transferred from the CD for interpolation
2531	! ** need to make sure the decomposition matches the
2532	! ** nested decomposition
2533
2534	! <DESCRIPTION>
2535	! The undecomposed dimensions of the intermediate domain are computed along
2536	! with the location of the intermediate domain's lower left-hand point and these
2537	! are passed to the RSL_SPAWN_REGULAR_NEST1 routine, which defines the intermediate
2538	! domain as a nest with 1:1 refinement within the parent domain. The memory dimensions
2539	! of the intermediate domain are computed by calling COMPUTE_MEMORY_DIMS_USING_RSL
2540	! and then the intermediate domain is allocated as a WRF grid of TYPE(domain).
2541	! The flow of control here resembles that of <a href=alloc_and_configure_domain.html>
2542	! alloc_and_configure_domain</a>, in <a href=../../frame/module_domain.f>
2543	! frame/module_domain.F</a>.
2544	! </DESCRIPTION>
2545
2546	idim_cd = idim / parent_grid_ratio + 1 + 2*shw + 1
2547	jdim_cd = jdim / parent_grid_ratio + 1 + 2*shw + 1
2548
2549	c_ids = i_parent_start-shw ; c_ide = c_ids + idim_cd - 1
2550	c_jds = j_parent_start-shw ; c_jde = c_jds + jdim_cd - 1
2551	c_kds = sd2 ; c_kde = ed2 ! IKJ ONLY
2552
2553	CALL RSL_SPAWN_REGULAR_NEST1( &
2554	intermediate_domdesc, &
2555	parent_domdesc, &
2556	#ifndef NMM_CORE
2557	RSL_24PT, &
2558	#else
2559	RSL_120PT, &
2560	#endif
2561	c_ids, c_jds, &
2562	idim_cd,jdim_cd, &
2563	1, 1, &
2564	intermediate_mloc,intermediate_nloc, &
2565	intermediate_mglob,intermediate_nglob)
2566
2567	zloc = kdim
2568	! compute dims for intermediate domain
2569	CALL show_domain_decomp(intermediate_domdesc)
2570	CALL compute_memory_dims_using_rsl ( &
2571	intermediate_domdesc , &
2572	intermediate_mloc , intermediate_nloc , zloc , &
2573	c_mloc_x , c_nloc_x , c_zloc_x , &
2574	c_mloc_y , c_nloc_y , c_zloc_y , &
2575	c_ids, c_ide, c_kds, c_kde, c_jds, c_jde, & ! IKJ ONLY
2576	c_sp1, c_ep1, c_sp2, c_ep2, c_sp3, c_ep3, &
2577	c_sp1x, c_ep1x, c_sp2x, c_ep2x, c_sp3x, c_ep3x, &
2578	c_sp1y, c_ep1y, c_sp2y, c_ep2y, c_sp3y, c_ep3y, &
2579	c_sm1, c_em1, c_sm2, c_em2, c_sm3, c_em3, &
2580	c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, &
2581	c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y )
2582	! since the RSL_SPAWN_REGULAR_NEST1 does not do the vert dimension
2583	! we need to set that manually >>>>> IKJ ONLY
2584	c_sp2 = c_kds !IKJ ONLY
2585	c_ep2 = c_kde !IKJ ONLY
2586	c_sm2 = c_kds !IKJ ONLY
2587	c_em2 = c_kde !IKJ ONLY
2588
2589	! global dims are same as CD
2590	! good for IKJ only
2591	c_sd1 = parent%sd31 ; c_ed1 = parent%ed31
2592	c_sd2 = parent%sd32 ; c_ed2 = parent%ed32
2593	c_sd3 = parent%sd33 ; c_ed3 = parent%ed33
2594
2595
2596	! Sequence of calls to create a new, intermediate domain
2597	! data structures that can be used to store the CD data
2598	! that will be used as input to the forcing interpolation
2599	! on each processor.
2600	ALLOCATE ( intermediate_grid )
2601	ALLOCATE ( intermediate_grid%parents( max_parents ) )
2602	ALLOCATE ( intermediate_grid%nests( max_nests ) )
2603
2604	NULLIFY( intermediate_grid%sibling )
2605	DO i = 1, max_nests
2606	NULLIFY( intermediate_grid%nests(i)%ptr )
2607	ENDDO
2608	NULLIFY (intermediate_grid%next)
2609	NULLIFY (intermediate_grid%same_level)
2610	NULLIFY (intermediate_grid%i_start)
2611	NULLIFY (intermediate_grid%j_start)
2612	NULLIFY (intermediate_grid%i_end)
2613	NULLIFY (intermediate_grid%j_end)
2614
2615	intermediate_grid%id = id
2616	intermediate_grid%domdesc = intermediate_domdesc
2617	intermediate_grid%num_nests = 0
2618	intermediate_grid%num_siblings = 0
2619	intermediate_grid%num_parents = 1
2620	intermediate_grid%max_tiles = 0
2621	intermediate_grid%num_tiles_spec = 0
2622	! hook up some pointers
2623
2624	! <DESCRIPTION>
2625	! However, the pointers in the nested hierachy must be set up differently
2626	! in this case. First, the pointer to the nests TYPE(domain) is
2627	! retrieved in a somewhat roundabout way, by searching the domain
2628	! hierarcy rooted at head_grid (defined in frame/module_domain.F) with a
2629	! call to <a href=find_grid_by_id.html>find_grid_by_id</a>. The nested
2630	! grid has already been added to the hierarchy by WRF because that is
2631	! done in <a
2632	! href=alloc_and_configure_domain.html>alloc_and_configure_domain</a>
2633	! before <a href=wrf_patch_domain.html>wrf_patch_domain</a> is called,
2634	! but the arguments to patch_domain_rsl, here, do not include a pointer to
2635	! the nest domain, only the id (could be changed). Once the pointer
2636	! to the nested grid's domain data structure is located, the nest's
2637	! intermediate_grid pointer is set to the the domain data struture for
2638	! the newly created created intermediate_domain. In a curious twist of
2639	! geneology, however, the intermediate_grid (from WRF domain hierarchy
2640	! point of view) is set to consider the nest its parent. This is because,
2641	! from the WRF framework's point of view, the intermediate domain does
2642	! not exist (it only exists because of code in external/RSL/module_dm.F,
2643	! an external-package supplied module). It remains only to allocate
2644	! the fields in the intermediate domain's domain data type, set a few
2645	! other fields such as dx, dy, and dt (to the parent domain's values) and
2646	! return.
2647	!
2648	! </DESCRIPTION>
2649
2650	CALL find_grid_by_id ( id, head_grid, nest_grid )
2651	nest_grid%intermediate_grid => intermediate_grid ! nest grid now has a pointer to this baby
2652	intermediate_grid%parents(1)%ptr => nest_grid ! the intermediate grid considers nest its parent
2653	intermediate_grid%num_parents = 1
2654
2655	c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
2656	c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
2657
2658	intermediate_grid%sm31x = c_sm1x
2659	intermediate_grid%em31x = c_em1x
2660	intermediate_grid%sm32x = c_sm2x
2661	intermediate_grid%em32x = c_em2x
2662	intermediate_grid%sm33x = c_sm3x
2663	intermediate_grid%em33x = c_em3x
2664	intermediate_grid%sm31y = c_sm1y
2665	intermediate_grid%em31y = c_em1y
2666	intermediate_grid%sm32y = c_sm2y
2667	intermediate_grid%em32y = c_em2y
2668	intermediate_grid%sm33y = c_sm3y
2669	intermediate_grid%em33y = c_em3y
2670
2671
2672	#if 0
2673	! allocate space for the intermediate domain
2674	CALL alloc_space_field ( intermediate_grid, id , 3 , .TRUE. , & ! use same id as nest
2675	c_sd1, c_ed1, c_sd2, c_ed2, c_sd3, c_ed3, &
2676	c_sm1, c_em1, c_sm2, c_em2, c_sm3, c_em3, &
2677	c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, & ! x-xpose
2678	c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y ) ! y-xpose
2679	#endif
2680
2681	intermediate_grid%sd31 = c_sd1
2682	intermediate_grid%ed31 = c_ed1
2683	intermediate_grid%sp31 = c_sp1
2684	intermediate_grid%ep31 = c_ep1
2685	intermediate_grid%sm31 = c_sm1
2686	intermediate_grid%em31 = c_em1
2687	intermediate_grid%sd32 = c_sd2
2688	intermediate_grid%ed32 = c_ed2
2689	intermediate_grid%sp32 = c_sp2
2690	intermediate_grid%ep32 = c_ep2
2691	intermediate_grid%sm32 = c_sm2
2692	intermediate_grid%em32 = c_em2
2693	intermediate_grid%sd33 = c_sd3
2694	intermediate_grid%ed33 = c_ed3
2695	intermediate_grid%sp33 = c_sp3
2696	intermediate_grid%ep33 = c_ep3
2697	intermediate_grid%sm33 = c_sm3
2698	intermediate_grid%em33 = c_em3
2699
2700	CALL med_add_config_info_to_grid ( intermediate_grid )
2701
2702	intermediate_grid%dx = parent%dx
2703	intermediate_grid%dy = parent%dy
2704	intermediate_grid%dt = parent%dt
2705
2706	CALL wrf_dm_define_comms ( intermediate_grid )
2707
2708	endif
2709
2710	RETURN
2711	END SUBROUTINE patch_domain_rsl
2712
2713	SUBROUTINE compute_memory_dims_using_rsl ( &
2714	domdesc , &
2715	mloc , nloc , zloc , &
2716	mloc_x , nloc_x , zloc_x , &
2717	mloc_y , nloc_y , zloc_y , &
2718	sd1, ed1, sd2, ed2, sd3, ed3, &
2719	sp1, ep1, sp2, ep2, sp3, ep3, &
2720	sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
2721	sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
2722	sm1, em1, sm2, em2, sm3, em3, &
2723	sm1x, em1x, sm2x, em2x, sm3x, em3x, &
2724	sm1y, em1y, sm2y, em2y, sm3y, em3y )
2725	USE module_machine
2726	IMPLICIT NONE
2727	! Arguments
2728	INTEGER, INTENT(IN ) :: domdesc
2729	INTEGER, INTENT(IN ) :: mloc , nloc , zloc ! all k on same proc
2730	INTEGER, INTENT(IN ) :: mloc_x , nloc_x , zloc_x ! all x on same proc
2731	INTEGER, INTENT(IN ) :: mloc_y , nloc_y , zloc_y ! all y on same proc
2732	INTEGER, INTENT(IN ) :: sd1, ed1, sd2, ed2, sd3, ed3
2733	INTEGER, INTENT(OUT) :: sp1, ep1, sp2, ep2, sp3, ep3
2734	INTEGER, INTENT(OUT) :: sp1x, ep1x, sp2x, ep2x, sp3x, ep3x
2735	INTEGER, INTENT(OUT) :: sp1y, ep1y, sp2y, ep2y, sp3y, ep3y
2736	INTEGER, INTENT(OUT) :: sm1, em1, sm2, em2, sm3, em3
2737	INTEGER, INTENT(OUT) :: sm1x, em1x, sm2x, em2x, sm3x, em3x
2738	INTEGER, INTENT(OUT) :: sm1y, em1y, sm2y, em2y, sm3y, em3y
2739	! <DESCRIPTION>
2740	! For a given domain (referred to by it's rsl domain descriptor) interrogate
2741	! rsl and compute the patch and memory dimensions for the section of the
2742	! domain that is computed on this task. rsl has this information already
2743	! and it is necessary only to (1) assign the information to the correct
2744	! dimension in WRF, based on the setting of model_data_order (
2745	! defined in <a href=../../frame/module_driver_constants.f>frame/module_driver_constants.F</a>,
2746	! based on the dimspec entries in the Registry), and (2) convert the
2747	! start and end of each dimension
2748	! from local (as they are carried in rsl, a holdover from MM5) to global.
2749	!
2750	! </DESCRIPTION>
2751	! Local data
2752	INTEGER , PARAMETER :: rsl_jjx_x = 2047
2753	INTEGER , DIMENSION( rsl_jjx_x ) :: rsl_js_x0 , rsl_je_x0 , rsl_is_x0 , rsl_ie_x0
2754	INTEGER :: rsl_xinest_x0 , rsl_idif_x0 , rsl_jdif_x0
2755
2756	CALL RSL_REG_RUN_INFOP(domdesc , 0 , &
2757	rsl_jjx_x , &
2758	rsl_xinest_x0 , &
2759	rsl_is_x0 , rsl_ie_x0 , &
2760	rsl_js_x0 , rsl_je_x0 , &
2761	rsl_idif_x0 , rsl_jdif_x0 )
2762
2763	SELECT CASE ( model_data_order )
2764	CASE ( DATA_ORDER_ZXY )
2765
2766	CALL rsl_reg_patchinfo_mn ( domdesc , &
2767	sp2 , ep2 , sp3 , ep3 , sp1 , ep1 )
2768	sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 ) ! adjust if domain start not 1
2769	sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
2770	sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
2771	sm2 = sp2 - rsl_padarea
2772	em2 = sm2 + mloc - 1
2773	sm3 = sp3 - rsl_padarea
2774	em3 = sm3 + nloc - 1
2775	sm1 = sp1
2776	em1 = sm1 + zloc - 1
2777
2778	CALL rsl_reg_patchinfo_nz ( domdesc , & ! switched m->n 20020910
2779	sp2x , ep2x , sp3x , ep3x , sp1x , ep1x )
2780	sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 ) ! adjust if domain start not 1
2781	sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
2782	sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
2783	sm2x = sp2x - rsl_padarea
2784	em2x = sm2x + mloc_x - 1
2785	sm3x = sp3x - rsl_padarea
2786	em3x = sm3x + nloc_x - 1
2787	sm1x = sp1x
2788	em1x = sm1x + zloc_x - 1
2789
2790	CALL rsl_reg_patchinfo_mz ( domdesc , & ! switched n->m 20020910
2791	sp2y , ep2y , sp3y , ep3y , sp1y , ep1y )
2792	sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 ) ! adjust if domain start not 1
2793	sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
2794	sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
2795	sm2y = sp2y - rsl_padarea
2796	em2y = sm2y + mloc_y - 1
2797	sm3y = sp3y - rsl_padarea
2798	em3y = sm3y + nloc_y - 1
2799	sm1y = sp1y
2800	em1y = sm1y + zloc_y - 1
2801
2802	CASE ( DATA_ORDER_XZY )
2803
2804	CALL rsl_reg_patchinfo_mn ( domdesc , &
2805	sp1 , ep1 , sp3 , ep3 , sp2 , ep2 )
2806
2807	sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 ) ! adjust if domain start not 1
2808	sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
2809	sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
2810
2811	sm1 = sp1 - rsl_padarea
2812	em1 = sm1 + mloc - 1
2813	sm3 = sp3 - rsl_padarea
2814	em3 = sm3 + nloc - 1
2815	sm2 = sp2
2816	em2 = sm2 + zloc - 1
2817
2818	CALL rsl_reg_patchinfo_nz ( domdesc , & ! switched m->n 20020908
2819	sp1x , ep1x , sp3x , ep3x , sp2x , ep2x )
2820	sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 ) ! adjust if domain start not 1
2821	sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
2822	sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
2823	sm1x = sp1x - rsl_padarea
2824	em1x = sm1x + mloc_x - 1
2825	sm3x = sp3x - rsl_padarea
2826	em3x = sm3x + nloc_x - 1
2827	sm2x = sp2x
2828	em2x = sm2x + zloc_x - 1
2829
2830	CALL rsl_reg_patchinfo_mz ( domdesc , & ! switched n->m 20020908
2831	sp1y , ep1y , sp3y , ep3y , sp2y , ep2y )
2832	sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 ) ! adjust if domain start not 1
2833	sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
2834	sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
2835	sm1y = sp1y - rsl_padarea
2836	em1y = sm1y + mloc_y - 1
2837	sm3y = sp3y - rsl_padarea
2838	em3y = sm3y + nloc_y - 1
2839	sm2y = sp2y
2840	em2y = sm2y + zloc_y - 1
2841
2842	CASE ( DATA_ORDER_XYZ )
2843
2844	CALL rsl_reg_patchinfo_mn ( domdesc , &
2845	sp1 , ep1 , sp2 , ep2 , sp3 , ep3 )
2846	sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 ) ! adjust if domain start not 1
2847	sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
2848	sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
2849	sm1 = sp1 - rsl_padarea
2850	em1 = sm1 + mloc - 1
2851	sm2 = sp2 - rsl_padarea
2852	em2 = sm2 + nloc - 1
2853	sm3 = sp3
2854	em3 = sm3 + zloc - 1
2855
2856	CALL rsl_reg_patchinfo_nz ( domdesc , & ! switched m->n 20020910
2857	sp1x , ep1x , sp2x , ep2x , sp3x , ep3x )
2858	sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 ) ! adjust if domain start not 1
2859	sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
2860	sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
2861	sm1x = sp1x - rsl_padarea
2862	em1x = sm1x + mloc_x - 1
2863	sm2x = sp2x - rsl_padarea
2864	em2x = sm2x + nloc_x - 1
2865	sm3x = sp3x
2866	em3x = sm3x + zloc_x - 1
2867
2868	CALL rsl_reg_patchinfo_mz ( domdesc , & ! switched n->m 20020910
2869	sp1y , ep1y , sp2y , ep2y , sp3y , ep3y )
2870	sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 ) ! adjust if domain start not 1
2871	sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
2872	sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
2873	sm1y = sp1y - rsl_padarea
2874	em1y = sm1y + mloc_y - 1
2875	sm2y = sp2y - rsl_padarea
2876	em2y = sm2y + nloc_y - 1
2877	sm3y = sp3y
2878	em3y = sm3y + zloc_y - 1
2879
2880	CASE ( DATA_ORDER_YXZ )
2881
2882	CALL rsl_reg_patchinfo_mn ( domdesc , &
2883	sp2 , ep2 , sp1 , ep1 , sp3 , ep3 )
2884
2885	sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 ) ! adjust if domain start not 1
2886	sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
2887	sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
2888	sm2 = sp2 - rsl_padarea
2889	em2 = sm2 + mloc - 1
2890	sm1 = sp1 - rsl_padarea
2891	em1 = sm1 + nloc - 1
2892	sm3 = sp3
2893	em3 = sm3 + zloc - 1
2894
2895	CALL rsl_reg_patchinfo_nz ( domdesc , & ! switched n->m 20020910
2896	sp2x , ep2x , sp1x , ep1x , sp3x , ep3x )
2897	sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 ) ! adjust if domain start not 1
2898	sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
2899	sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
2900	sm2x = sp2x - rsl_padarea
2901	em2x = sm2x + mloc_x - 1
2902	sm1x = sp1x - rsl_padarea
2903	em1x = sm1x + nloc_x - 1
2904	sm3x = sp3x
2905	em3x = sm3x + zloc_x - 1
2906
2907	CALL rsl_reg_patchinfo_mz ( domdesc , & ! switched m->n 20020910
2908	sp2y , ep2y , sp1y , ep1y , sp3y , ep3y )
2909	sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 ) ! adjust if domain start not 1
2910	sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
2911	sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
2912	sm2y = sp2y - rsl_padarea
2913	em2y = sm2y + mloc_y - 1
2914	sm1y = sp1y - rsl_padarea
2915	em1y = sm1y + nloc_y - 1
2916	sm3y = sp3y
2917	em3y = sm3y + zloc_y - 1
2918
2919	END SELECT
2920
2921	RETURN
2922	END SUBROUTINE compute_memory_dims_using_rsl
2923
2924	SUBROUTINE init_module_dm
2925	IMPLICIT NONE
2926	INTEGER ierr, mytask
2927	EXTERNAL rsl_patch_decomp
2928	! <DESCRIPTION>
2929	! This is the first part of the initialization of rsl for distributed
2930	! memory parallel execution. The routine first interrogates MPI to find
2931	! out if it needs to be intialized (it may not, since
2932	! <a href=init_module_wrf_quilt.html>init_module_wrf_quilt</a> may
2933	! have done this already) and if so, calls mpi_init. Standard output
2934	! and standard error on each process is directed to a separate file
2935	! with a call to <a href=wrf_termio_dup.html>wrf_termio_dup</a> and,
2936	! in the case where we <em>are</em> calling mpi_init here, MPI_COMM_WORLD
2937	! is set as the communicator (it would not be in the case of quilting).
2938	!
2939	! Finally, rsl itself is initialized and the default decomposition
2940	! algorithm in rsl is set to the rsl-provided algorithm RSL_PATCH_DECOMP.
2941	!
2942	! Certain parts of this algorithm are #ifdef'd out in case -DSTUBMPI
2943	! is specified in the configure.wrf file at compile time. This allows
2944	! rsl's nesting functionality to be used on a single processor (for nesting, for example) without using MPI.
2945	!
2946	! </DESCRIPTION>
2947	#ifndef STUBMPI
2948	INCLUDE 'mpif.h'
2949	LOGICAL mpi_inited
2950	CALL mpi_initialized( mpi_inited, ierr )
2951	IF ( .NOT. mpi_inited ) THEN
2952	! If MPI has not been initialized then initialize it and
2953	! make comm_world the communicator
2954	! Otherwise, something else (e.g. quilt-io) has already
2955	! initialized MPI, so just grab the communicator that
2956	! should already be stored and use that.
2957	CALL mpi_init ( ierr )
2958	CALL wrf_termio_dup
2959	CALL wrf_set_dm_communicator ( MPI_COMM_WORLD )
2960	ENDIF
2961	CALL wrf_get_dm_communicator( mpi_comm_local )
2962	CALL wrf_termio_dup
2963	#endif
2964	CALL rsl_initialize1( mpi_comm_local )
2965	CALL set_def_decomp_fcn ( rsl_patch_decomp )
2966	END SUBROUTINE init_module_dm
2967
2968	! internal, used below for switching the argument to MPI calls
2969	! if reals are being autopromoted to doubles in the build of WRF
2970	INTEGER function getrealmpitype()
2971	#ifndef STUBMPI
2972	IMPLICIT NONE
2973	INCLUDE 'mpif.h'
2974	INTEGER rtypesize, dtypesize, ierr
2975	CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
2976	CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
2977	IF ( RWORDSIZE .EQ. rtypesize ) THEN
2978	getrealmpitype = MPI_REAL
2979	ELSE IF ( RWORDSIZE .EQ. dtypesize ) THEN
2980	getrealmpitype = MPI_DOUBLE_PRECISION
2981	ELSE
2982	CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' )
2983	ENDIF
2984	#else
2985	! required dummy initialization for function that is never called
2986	getrealmpitype = 1
2987	#endif
2988	RETURN
2989	END FUNCTION getrealmpitype
2990
2991	REAL FUNCTION wrf_dm_max_real ( inval )
2992	IMPLICIT NONE
2993	REAL inval, retval
2994	INTEGER ierr
2995	! <DESCRIPTION>
2996	! Collective operation. Each processor calls passing a local value; on return
2997	! all processors are passed back the maximum of all values passed.
2998	!
2999	! </DESCRIPTION>
3000	#ifndef STUBMPI
3001	INCLUDE 'mpif.h'
3002	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_MAX, mpi_comm_local, ierr )
3003	wrf_dm_max_real = retval
3004	#else
3005	wrf_dm_max_real = inval
3006	#endif
3007	END FUNCTION wrf_dm_max_real
3008
3009	REAL FUNCTION wrf_dm_min_real ( inval )
3010	IMPLICIT NONE
3011	REAL inval, retval
3012	INTEGER typesize, op
3013	INTEGER ierr
3014	! <DESCRIPTION>
3015	! Collective operation. Each processor calls passing a local value; on return
3016	! all processors are passed back the minumum of all values passed.
3017	!
3018	! </DESCRIPTION>
3019	#ifndef STUBMPI
3020	INCLUDE 'mpif.h'
3021	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_MIN, mpi_comm_local, ierr )
3022	wrf_dm_min_real = retval
3023	#else
3024	wrf_dm_min_real = inval
3025	#endif
3026	END FUNCTION wrf_dm_min_real
3027
3028	REAL FUNCTION wrf_dm_sum_real ( inval )
3029	IMPLICIT NONE
3030	INTEGER ierr
3031	INTEGER typesize, op
3032	REAL inval, retval
3033	! <DESCRIPTION>
3034	! Collective operation. Each processor calls passing a local value; on return
3035	! all processors are passed back the sum of all values passed.
3036	!
3037	! </DESCRIPTION>
3038	#ifndef STUBMPI
3039	INCLUDE 'mpif.h'
3040	CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_SUM, mpi_comm_local, ierr )
3041	wrf_dm_sum_real = retval
3042	#else
3043	wrf_dm_sum_real = inval
3044	#endif
3045	END FUNCTION wrf_dm_sum_real
3046
3047	INTEGER FUNCTION wrf_dm_sum_integer ( inval )
3048	IMPLICIT NONE
3049	INTEGER inval, retval, ierr
3050	! <DESCRIPTION>
3051	! Collective operation. Each processor calls passing a local value; on return
3052	! all processors are passed back the sum of all values passed.
3053	!
3054	! </DESCRIPTION>
3055	#ifndef STUBMPI
3056	INCLUDE 'mpif.h'
3057	CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, mpi_comm_local, ierr )
3058	wrf_dm_sum_integer = retval
3059	#else
3060	wrf_dm_sum_integer = inval
3061	#endif
3062	END FUNCTION wrf_dm_sum_integer
3063
3064
3065	SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
3066	IMPLICIT NONE
3067	REAL val, val_all( rsl_nproc )
3068	INTEGER idex, jdex, ierr
3069	INTEGER dex(2)
3070	INTEGER dex_all (2,rsl_nproc)
3071	! <DESCRIPTION>
3072	! Collective operation. Each processor calls passing a local value and its index; on return
3073	! all processors are passed back the maximum of all values passed and its index.
3074	!
3075	! </DESCRIPTION>
3076	INTEGER i, comm
3077	#ifndef STUBMPI
3078	INCLUDE 'mpif.h'
3079
3080	CALL wrf_get_dm_communicator ( comm )
3081	dex(1) = idex ; dex(2) = jdex
3082	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3083	CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
3084	val = val_all(1)
3085	idex = dex_all(1,1) ; jdex = dex_all(2,1)
3086	DO i = 2, rsl_nproc
3087	IF ( val_all(i) .GT. val ) THEN
3088	val = val_all(i)
3089	idex = dex_all(1,i)
3090	jdex = dex_all(2,i)
3091	ENDIF
3092	ENDDO
3093	#endif
3094	END SUBROUTINE wrf_dm_maxval_real
3095
3096	SUBROUTINE wrf_dm_minval_real ( val, idex, jdex )
3097	IMPLICIT NONE
3098	REAL val, val_all( rsl_nproc )
3099	INTEGER idex, jdex, ierr
3100	INTEGER dex(2)
3101	INTEGER dex_all (2,rsl_nproc)
3102	! <DESCRIPTION>
3103	! Collective operation. Each processor calls passing a local value and its index; on return
3104	! all processors are passed back the minimum of all values passed and its index.
3105	!
3106	! </DESCRIPTION>
3107	INTEGER i, comm
3108	#ifndef STUBMPI
3109	INCLUDE 'mpif.h'
3110
3111	CALL wrf_get_dm_communicator ( comm )
3112	dex(1) = idex ; dex(2) = jdex
3113	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3114	CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
3115	val = val_all(1)
3116	idex = dex_all(1,1) ; jdex = dex_all(2,1)
3117	DO i = 2, rsl_nproc
3118	IF ( val_all(i) .LT. val ) THEN
3119	val = val_all(i)
3120	idex = dex_all(1,i)
3121	jdex = dex_all(2,i)
3122	ENDIF
3123	ENDDO
3124	#endif
3125	END SUBROUTINE wrf_dm_minval_real
3126
3127	SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
3128	IMPLICIT NONE
3129	DOUBLE PRECISION val, val_all( rsl_nproc )
3130	INTEGER idex, jdex, ierr
3131	INTEGER dex(2)
3132	INTEGER dex_all (2,rsl_nproc)
3133	! <DESCRIPTION>
3134	! Collective operation. Each processor calls passing a local value and its index; on return
3135	! all processors are passed back the maximum of all values passed and its index.
3136	!
3137	! </DESCRIPTION>
3138	INTEGER i, comm
3139	#ifndef STUBMPI
3140	INCLUDE 'mpif.h'
3141
3142	CALL wrf_get_dm_communicator ( comm )
3143	dex(1) = idex ; dex(2) = jdex
3144	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3145	CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
3146	val = val_all(1)
3147	idex = dex_all(1,1) ; jdex = dex_all(2,1)
3148	DO i = 2, rsl_nproc
3149	IF ( val_all(i) .GT. val ) THEN
3150	val = val_all(i)
3151	idex = dex_all(1,i)
3152	jdex = dex_all(2,i)
3153	ENDIF
3154	ENDDO
3155	#endif
3156	END SUBROUTINE wrf_dm_maxval_doubleprecision
3157
3158	SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex )
3159	IMPLICIT NONE
3160	DOUBLE PRECISION val, val_all( rsl_nproc )
3161	INTEGER idex, jdex, ierr
3162	INTEGER dex(2)
3163	INTEGER dex_all (2,rsl_nproc)
3164	! <DESCRIPTION>
3165	! Collective operation. Each processor calls passing a local value and its index; on return
3166	! all processors are passed back the minimum of all values passed and its index.
3167	!
3168	! </DESCRIPTION>
3169	INTEGER i, comm
3170	#ifndef STUBMPI
3171	INCLUDE 'mpif.h'
3172
3173	CALL wrf_get_dm_communicator ( comm )
3174	dex(1) = idex ; dex(2) = jdex
3175	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3176	CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
3177	val = val_all(1)
3178	idex = dex_all(1,1) ; jdex = dex_all(2,1)
3179	DO i = 2, rsl_nproc
3180	IF ( val_all(i) .LT. val ) THEN
3181	val = val_all(i)
3182	idex = dex_all(1,i)
3183	jdex = dex_all(2,i)
3184	ENDIF
3185	ENDDO
3186	#endif
3187	END SUBROUTINE wrf_dm_minval_doubleprecision
3188
3189
3190	SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
3191	IMPLICIT NONE
3192	INTEGER val, val_all( rsl_nproc )
3193	INTEGER idex, jdex, ierr
3194	INTEGER dex(2)
3195	INTEGER dex_all (2,rsl_nproc)
3196	! <DESCRIPTION>
3197	! Collective operation. Each processor calls passing a local value and its index; on return
3198	! all processors are passed back the maximum of all values passed and its index.
3199	!
3200	! </DESCRIPTION>
3201	INTEGER i, comm
3202	#ifndef STUBMPI
3203	INCLUDE 'mpif.h'
3204
3205	CALL wrf_get_dm_communicator ( comm )
3206	dex(1) = idex ; dex(2) = jdex
3207	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3208	CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
3209	val = val_all(1)
3210	idex = dex_all(1,1) ; jdex = dex_all(2,1)
3211	DO i = 2, rsl_nproc
3212	IF ( val_all(i) .GT. val ) THEN
3213	val = val_all(i)
3214	idex = dex_all(1,i)
3215	jdex = dex_all(2,i)
3216	ENDIF
3217	ENDDO
3218	#endif
3219	END SUBROUTINE wrf_dm_maxval_integer
3220
3221	SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex )
3222	IMPLICIT NONE
3223	INTEGER val, val_all( rsl_nproc )
3224	INTEGER idex, jdex, ierr
3225	INTEGER dex(2)
3226	INTEGER dex_all (2,rsl_nproc)
3227	! <DESCRIPTION>
3228	! Collective operation. Each processor calls passing a local value and its index; on return
3229	! all processors are passed back the minimum of all values passed and its index.
3230	!
3231	! </DESCRIPTION>
3232	INTEGER i, comm
3233	#ifndef STUBMPI
3234	INCLUDE 'mpif.h'
3235
3236	CALL wrf_get_dm_communicator ( comm )
3237	dex(1) = idex ; dex(2) = jdex
3238	CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3239	CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
3240	val = val_all(1)
3241	idex = dex_all(1,1) ; jdex = dex_all(2,1)
3242	DO i = 2, rsl_nproc
3243	IF ( val_all(i) .LT. val ) THEN
3244	val = val_all(i)
3245	idex = dex_all(1,i)
3246	jdex = dex_all(2,i)
3247	ENDIF
3248	ENDDO
3249	#endif
3250	END SUBROUTINE wrf_dm_minval_integer
3251
3252	SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
3253	USE module_domain
3254	TYPE (domain),INTENT(INOUT) :: parent, nest
3255	INTEGER, INTENT(IN) :: dx, dy
3256	CALL rsl_move_nest ( parent%domdesc, nest%domdesc, dx, dy )
3257	END SUBROUTINE wrf_dm_move_nest
3258
3259	!------------------------------------------------------------------------------
3260	SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, &
3261	mp_local_uobmask, &
3262	mp_local_vobmask, &
3263	mp_local_cobmask, errf )
3264
3265	!------------------------------------------------------------------------------
3266	! PURPOSE: Do MPI allgatherv operation across processors to get the
3267	! errors at each observation point on all processors.
3268	!
3269	!------------------------------------------------------------------------------
3270	#ifndef STUBMPI
3271	INCLUDE 'mpif.h'
3272
3273	INTEGER, INTENT(IN) :: nsta ! Observation index.
3274	INTEGER, INTENT(IN) :: nerrf ! Number of error fields.
3275	INTEGER, INTENT(IN) :: niobf ! Number of observations.
3276	LOGICAL, INTENT(IN) :: MP_LOCAL_UOBMASK(NIOBF)
3277	LOGICAL, INTENT(IN) :: MP_LOCAL_VOBMASK(NIOBF)
3278	LOGICAL, INTENT(IN) :: MP_LOCAL_COBMASK(NIOBF)
3279	REAL, INTENT(INOUT) :: errf(nerrf, niobf)
3280
3281	! Local declarations
3282	integer i, n, nlocal_dot, nlocal_crs
3283	REAL UVT_BUFFER(NIOBF) ! Buffer for holding U, V, or T
3284	REAL QRK_BUFFER(NIOBF) ! Buffer for holding Q or RKO
3285	REAL SFP_BUFFER(NIOBF) ! Buffer for holding Surface pressure
3286	INTEGER N_BUFFER(NIOBF)
3287	REAL FULL_BUFFER(NIOBF)
3288	INTEGER IFULL_BUFFER(NIOBF)
3289	INTEGER IDISPLACEMENT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
3290	INTEGER ICOUNT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
3291
3292	INTEGER :: MPI_COMM_COMP ! MPI group communicator
3293	INTEGER :: NPROCS ! Number of processors
3294	INTEGER :: IERR ! Error code from MPI routines
3295
3296	! Get communicator for MPI operations.
3297	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
3298
3299	! Get rank of monitor processor and broadcast to others.
3300	CALL MPI_COMM_SIZE( MPI_COMM_COMP, NPROCS, IERR )
3301
3302	! DO THE U FIELD
3303	NLOCAL_DOT = 0
3304	DO N = 1, NSTA
3305	IF ( MP_LOCAL_UOBMASK(N) ) THEN ! USE U-POINT MASK
3306	NLOCAL_DOT = NLOCAL_DOT + 1
3307	UVT_BUFFER(NLOCAL_DOT) = ERRF(1,N) ! U WIND COMPONENT
3308	SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N) ! SURFACE PRESSURE
3309	QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N) ! RKO
3310	N_BUFFER(NLOCAL_DOT) = N
3311	ENDIF
3312	ENDDO
3313	CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
3314	ICOUNT,1,MPI_INTEGER, &
3315	MPI_COMM_COMP,IERR)
3316	I = 1
3317
3318	IDISPLACEMENT(1) = 0
3319	DO I = 2, NPROCS
3320	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
3321	ENDDO
3322	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
3323	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3324	MPI_INTEGER, MPI_COMM_COMP, IERR)
3325	! U
3326	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
3327	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3328	MPI_REAL, MPI_COMM_COMP, IERR)
3329	DO N = 1, NSTA
3330	ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3331	ENDDO
3332	! SURF PRESS AT U-POINTS
3333	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
3334	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3335	MPI_REAL, MPI_COMM_COMP, IERR)
3336	DO N = 1, NSTA
3337	ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3338	ENDDO
3339	! RKO
3340	CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL, &
3341	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3342	MPI_REAL, MPI_COMM_COMP, IERR)
3343	DO N = 1, NSTA
3344	ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3345	ENDDO
3346
3347	! DO THE V FIELD
3348	NLOCAL_DOT = 0
3349	DO N = 1, NSTA
3350	IF ( MP_LOCAL_VOBMASK(N) ) THEN ! USE V-POINT MASK
3351	NLOCAL_DOT = NLOCAL_DOT + 1
3352	UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N) ! V WIND COMPONENT
3353	SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N) ! SURFACE PRESSURE
3354	N_BUFFER(NLOCAL_DOT) = N
3355	ENDIF
3356	ENDDO
3357	CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
3358	ICOUNT,1,MPI_INTEGER, &
3359	MPI_COMM_COMP,IERR)
3360	I = 1
3361
3362	IDISPLACEMENT(1) = 0
3363	DO I = 2, NPROCS
3364	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
3365	ENDDO
3366	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
3367	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3368	MPI_INTEGER, MPI_COMM_COMP, IERR)
3369	! V
3370	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
3371	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3372	MPI_REAL, MPI_COMM_COMP, IERR)
3373	DO N = 1, NSTA
3374	ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3375	ENDDO
3376	! SURF PRESS AT V-POINTS
3377	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
3378	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3379	MPI_REAL, MPI_COMM_COMP, IERR)
3380	DO N = 1, NSTA
3381	ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3382	ENDDO
3383
3384	! DO THE CROSS FIELDS, T AND Q
3385	NLOCAL_CRS = 0
3386	DO N = 1, NSTA
3387	IF ( MP_LOCAL_COBMASK(N) ) THEN ! USE MASS-POINT MASK
3388	NLOCAL_CRS = NLOCAL_CRS + 1
3389	UVT_BUFFER(NLOCAL_CRS) = ERRF(3,N) ! TEMPERATURE
3390	QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N) ! MOISTURE
3391	SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N) ! SURFACE PRESSURE
3392	N_BUFFER(NLOCAL_CRS) = N
3393	ENDIF
3394	ENDDO
3395	CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, &
3396	ICOUNT,1,MPI_INTEGER, &
3397	MPI_COMM_COMP,IERR)
3398	IDISPLACEMENT(1) = 0
3399	DO I = 2, NPROCS
3400	IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
3401	ENDDO
3402	CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER, &
3403	IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3404	MPI_INTEGER, MPI_COMM_COMP, IERR)
3405	! T
3406	CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_CRS, MPI_REAL, &
3407	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3408	MPI_REAL, MPI_COMM_COMP, IERR)
3409
3410	DO N = 1, NSTA
3411	ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3412	ENDDO
3413	! Q
3414	CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL, &
3415	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3416	MPI_REAL, MPI_COMM_COMP, IERR)
3417	DO N = 1, NSTA
3418	ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3419	ENDDO
3420	! SURF PRESS AT MASS POINTS
3421	CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL, &
3422	FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3423	MPI_REAL, MPI_COMM_COMP, IERR)
3424	DO N = 1, NSTA
3425	ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3426	ENDDO
3427	#endif
3428	END SUBROUTINE get_full_obs_vector
3429
3430	END MODULE module_dm
3431
3432	!=========================================================================
3433	! wrf_dm_patch_domain has to be outside the module because it is called
3434	! by a routine in module_domain but depends on module domain
3435
3436
3437	SUBROUTINE wrf_dm_patch_domain ( id , domdesc , parent_id , parent_domdesc , &
3438	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
3439	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
3440	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
3441	sp1x , ep1x , sm1x , em1x , &
3442	sp2x , ep2x , sm2x , em2x , &
3443	sp3x , ep3x , sm3x , em3x , &
3444	sp1y , ep1y , sm1y , em1y , &
3445	sp2y , ep2y , sm2y , em2y , &
3446	sp3y , ep3y , sm3y , em3y , &
3447	bdx , bdy )
3448	USE module_domain
3449	USE module_dm
3450	IMPLICIT NONE
3451
3452	INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
3453	INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
3454	sm1 , em1 , sm2 , em2 , sm3 , em3
3455	INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
3456	sm1x , em1x , sm2x , em2x , sm3x , em3x
3457	INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
3458	sm1y , em1y , sm2y , em2y , sm3y , em3y
3459	INTEGER, INTENT(INOUT):: id , domdesc , parent_id , parent_domdesc
3460
3461	TYPE(domain), POINTER :: parent, grid_ptr
3462
3463	! <DESCRIPTION>
3464	! The rsl-package supplied routine that computes the patch and memory dimensions
3465	! for this task. See also <a href=patch_domain_rsl.html>patch_domain_rsl</a>
3466	!
3467	! </DESCRIPTION>
3468
3469	! this is necessary because we cannot pass parent directly into
3470	! wrf_dm_patch_domain because creating the correct interface definitions
3471	! would generate a circular USE reference between module_domain and module_dm
3472	! see comment this date in module_domain for more information. JM 20020416
3473
3474	NULLIFY( parent )
3475	grid_ptr => head_grid
3476	CALL find_grid_by_id( parent_id , grid_ptr , parent )
3477
3478	CALL patch_domain_rsl ( id , domdesc , parent, parent_id , parent_domdesc , &
3479	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
3480	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
3481	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
3482	sp1x , ep1x , sm1x , em1x , &
3483	sp2x , ep2x , sm2x , em2x , &
3484	sp3x , ep3x , sm3x , em3x , &
3485	sp1y , ep1y , sm1y , em1y , &
3486	sp2y , ep2y , sm2y , em2y , &
3487	sp3y , ep3y , sm3y , em3y , &
3488	bdx , bdy )
3489
3490
3491	RETURN
3492	END SUBROUTINE wrf_dm_patch_domain
3493
3494	SUBROUTINE wrf_termio_dup
3495	IMPLICIT NONE
3496	INTEGER mytask, ntasks, ierr
3497	! <DESCRIPTION>
3498	! Redirect standard output and standard error to separate files for each processor.
3499	!
3500	! </DESCRIPTION>
3501	#ifndef STUBMPI
3502	INCLUDE 'mpif.h'
3503	CALL mpi_comm_size(MPI_COMM_WORLD, ntasks, ierr )
3504	CALL mpi_comm_rank(MPI_COMM_WORLD, mytask, ierr )
3505	#else
3506	ntasks = 1
3507	mytask = 0
3508	#endif
3509	write(0,*)'starting wrf task ',mytask,' of ',ntasks
3510	CALL rsl_error_dup1( mytask )
3511	END SUBROUTINE wrf_termio_dup
3512
3513	SUBROUTINE wrf_get_myproc( myproc )
3514	IMPLICIT NONE
3515	! <DESCRIPTION>
3516	! Pass back the task number (usually MPI rank) on this process.
3517	!
3518	! </DESCRIPTION>
3519	# include "rsl.inc"
3520	INTEGER myproc
3521	myproc = rsl_myproc
3522	RETURN
3523	END SUBROUTINE wrf_get_myproc
3524
3525	SUBROUTINE wrf_get_nproc( nproc )
3526	IMPLICIT NONE
3527	# include "rsl.inc"
3528	INTEGER nproc
3529	! <DESCRIPTION>
3530	! Pass back the number of distributed-memory tasks.
3531	!
3532	! </DESCRIPTION>
3533	nproc = rsl_nproc_all
3534	RETURN
3535	END SUBROUTINE wrf_get_nproc
3536
3537	SUBROUTINE wrf_get_nprocx( nprocx )
3538	IMPLICIT NONE
3539	# include "rsl.inc"
3540	INTEGER nprocx
3541	! <DESCRIPTION>
3542	! Pass back the number of distributed-memory tasks decomposing the X dimension of the domain.
3543	!
3544	! </DESCRIPTION>
3545	nprocx = rsl_nproc_min
3546	RETURN
3547	END SUBROUTINE wrf_get_nprocx
3548
3549	SUBROUTINE wrf_get_nprocy( nprocy )
3550	IMPLICIT NONE
3551	# include "rsl.inc"
3552	INTEGER nprocy
3553	! <DESCRIPTION>
3554	! Pass back the number of distributed-memory tasks decomposing the Y dimension of the domain.
3555	!
3556	! </DESCRIPTION>
3557	nprocy = rsl_nproc_maj
3558	RETURN
3559	END SUBROUTINE wrf_get_nprocy
3560
3561	SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
3562	USE module_dm
3563	IMPLICIT NONE
3564	INTEGER size
3565	#ifndef NEC
3566	INTEGER*1 BUF(size)
3567	#else
3568	CHARACTER*1 BUF(size)
3569	#endif
3570	! <DESCRIPTION>
3571	! Collective operation. Given a buffer and a size in bytes on task zero, broadcast and return that buffer on all tasks.
3572	!
3573	! </DESCRIPTION>
3574	CALL rsl_mon_bcast( buf , size )
3575	RETURN
3576	END SUBROUTINE wrf_dm_bcast_bytes
3577
3578	SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
3579	IMPLICIT NONE
3580	INTEGER n1
3581	! <DESCRIPTION>
3582	! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
3583	!
3584	! </DESCRIPTION>
3585	CHARACTER() buf
3586	INTEGER ibuf(256),i,n
3587	CHARACTER*256 tstr
3588	n = n1
3589	! Root task is required to have the correct value of N1, other tasks
3590	! might not have the correct value.
3591	CALL wrf_dm_bcast_integer( n , 1 )
3592	IF (n .GT. 256) n = 256
3593	IF (n .GT. 0 ) then
3594	DO i = 1, n
3595	ibuf(I) = ichar(buf(I:I))
3596	ENDDO
3597	CALL wrf_dm_bcast_integer( ibuf, n )
3598	buf = ''
3599	DO i = 1, n
3600	buf(i:i) = char(ibuf(i))
3601	ENDDO
3602	ENDIF
3603	RETURN
3604	END SUBROUTINE wrf_dm_bcast_string
3605
3606	SUBROUTINE wrf_dm_bcast_integer( BUF, N1 )
3607	IMPLICIT NONE
3608	INTEGER n1
3609	INTEGER buf(*)
3610	! <DESCRIPTION>
3611	! Collective operation. Given an array of integers and length on task zero, broadcast and return that array of values on all tasks.
3612	!
3613	! </DESCRIPTION>
3614	CALL rsl_mon_bcast( BUF , N1 * IWORDSIZE )
3615	RETURN
3616	END SUBROUTINE wrf_dm_bcast_integer
3617
3618	SUBROUTINE wrf_dm_bcast_double( BUF, N1 )
3619	IMPLICIT NONE
3620	INTEGER n1
3621	! <DESCRIPTION>
3622	! Collective operation. Given an array of doubles and length on task zero, broadcast and return that array of values on all tasks.
3623	!
3624	! </DESCRIPTION>
3625	DOUBLEPRECISION buf(*)
3626	CALL rsl_mon_bcast( BUF , N1 * DWORDSIZE )
3627	RETURN
3628	END SUBROUTINE wrf_dm_bcast_double
3629
3630	SUBROUTINE wrf_dm_bcast_real( BUF, N1 )
3631	IMPLICIT NONE
3632	INTEGER n1
3633	! <DESCRIPTION>
3634	! Collective operation. Given an array of reals and length on task zero, broadcast and return that array of values on all tasks.
3635	!
3636	! </DESCRIPTION>
3637	REAL buf(*)
3638	CALL rsl_mon_bcast( BUF , N1 * RWORDSIZE )
3639	RETURN
3640	END SUBROUTINE wrf_dm_bcast_real
3641
3642	SUBROUTINE wrf_dm_bcast_logical( BUF, N1 )
3643	IMPLICIT NONE
3644	INTEGER n1
3645	! <DESCRIPTION>
3646	! Collective operation. Given an array of logicals and length on task zero, broadcast and return that array of values on all tasks.
3647	!
3648	! </DESCRIPTION>
3649	LOGICAL buf(*)
3650	CALL rsl_mon_bcast( BUF , N1 * LWORDSIZE )
3651	RETURN
3652	END SUBROUTINE wrf_dm_bcast_logical
3653
3654	SUBROUTINE wrf_dm_halo ( domdesc , comms , stencil_id )
3655	USE module_dm
3656	IMPLICIT NONE
3657	INTEGER domdesc , comms(*) , stencil_id
3658	CALL rsl_exch_stencil ( domdesc , comms( stencil_id ) )
3659	RETURN
3660	END SUBROUTINE wrf_dm_halo
3661
3662	SUBROUTINE wrf_dm_xpose_z2y ( domdesc , comms , xpose_id )
3663	USE module_dm
3664	IMPLICIT NONE
3665	INTEGER domdesc , comms(*) , xpose_id
3666	CALL rsl_xpose_mn_mz ( domdesc , comms( xpose_id ) ) ! switched nz->mz 20020910
3667	RETURN
3668	END SUBROUTINE wrf_dm_xpose_z2y
3669
3670	SUBROUTINE wrf_dm_xpose_y2z ( domdesc , comms , xpose_id )
3671	USE module_dm
3672	IMPLICIT NONE
3673	INTEGER domdesc , comms(*) , xpose_id
3674	CALL rsl_xpose_mz_mn ( domdesc , comms( xpose_id ) ) ! switched nz->mz 20020910
3675	RETURN
3676	END SUBROUTINE wrf_dm_xpose_y2z
3677
3678	SUBROUTINE wrf_dm_xpose_y2x ( domdesc , comms , xpose_id )
3679	USE module_dm
3680	IMPLICIT NONE
3681	INTEGER domdesc , comms(*) , xpose_id
3682	CALL rsl_xpose_mz_nz ( domdesc , comms( xpose_id ) ) ! switched nz<->mz 20020910
3683	RETURN
3684	END SUBROUTINE wrf_dm_xpose_y2x
3685
3686	SUBROUTINE wrf_dm_xpose_x2y ( domdesc , comms , xpose_id )
3687	USE module_dm
3688	IMPLICIT NONE
3689	INTEGER domdesc , comms(*) , xpose_id
3690	CALL rsl_xpose_nz_mz ( domdesc , comms( xpose_id ) ) ! switched nz<->mz 20020910
3691	RETURN
3692	END SUBROUTINE wrf_dm_xpose_x2y
3693
3694	SUBROUTINE wrf_dm_xpose_x2z ( domdesc , comms , xpose_id )
3695	USE module_dm
3696	IMPLICIT NONE
3697	INTEGER domdesc , comms(*) , xpose_id
3698	CALL rsl_xpose_nz_mn ( domdesc , comms( xpose_id ) ) ! switched mz->nz 20020910
3699	RETURN
3700	END SUBROUTINE wrf_dm_xpose_x2z
3701
3702	SUBROUTINE wrf_dm_xpose_z2x ( domdesc , comms , xpose_id )
3703	USE module_dm
3704	IMPLICIT NONE
3705	INTEGER domdesc , comms(*) , xpose_id
3706	CALL rsl_xpose_mn_nz ( domdesc , comms( xpose_id ) ) ! switched mz->nz 20020910
3707	RETURN
3708	END SUBROUTINE wrf_dm_xpose_z2x
3709
3710	#if 0
3711	SUBROUTINE wrf_dm_boundary ( domdesc , comms , period_id , &
3712	periodic_x , periodic_y )
3713	USE module_dm
3714	IMPLICIT NONE
3715	INTEGER domdesc , comms(*) , period_id
3716	LOGICAL , INTENT(IN) :: periodic_x, periodic_y
3717	# include "rsl.inc"
3718
3719	IF ( periodic_x ) THEN
3720	CALL rsl_exch_period ( domdesc , comms( period_id ) , RSL_M )
3721	END IF
3722	IF ( periodic_y ) THEN
3723	CALL rsl_exch_period ( domdesc , comms( period_id ) , RSL_N )
3724	END IF
3725	RETURN
3726	END SUBROUTINE wrf_dm_boundary
3727	#endif
3728
3729	SUBROUTINE wrf_dm_define_comms ( grid )
3730	USE module_domain
3731	USE module_dm
3732	IMPLICIT NONE
3733	TYPE(domain) , INTENT (INOUT) :: grid
3734	INTEGER dyn_opt
3735	INTEGER idum1, idum2, icomm
3736
3737	#ifdef DEREF_KLUDGE
3738	! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3739	INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
3740	INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3741	INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3742	#endif
3743
3744	#include "deref_kludge.h"
3745
3746	CALL nl_get_dyn_opt( 1, dyn_opt )
3747
3748	CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
3749
3750	! rsl interface has been restructured so there is no longer a
3751	! need to call a dyncore specific define_comms routine here.
3752	! Removed 6/2001. JM
3753
3754	DO icomm = 1, max_comms
3755	grid%comms(icomm) = invalid_message_value
3756	ENDDO
3757	grid%shift_x = invalid_message_value
3758	grid%shift_y = invalid_message_value
3759
3760	RETURN
3761	END SUBROUTINE wrf_dm_define_comms
3762
3763	SUBROUTINE write_68( grid, v , s , &
3764	ids, ide, jds, jde, kds, kde, &
3765	ims, ime, jms, jme, kms, kme, &
3766	its, ite, jts, jte, kts, kte )
3767	USE module_domain
3768	IMPLICIT NONE
3769	TYPE(domain) , INTENT (INOUT) :: grid
3770	CHARACTER () s
3771	INTEGER ids, ide, jds, jde, kds, kde, &
3772	ims, ime, jms, jme, kms, kme, &
3773	its, ite, jts, jte, kts, kte
3774	REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) :: v
3775	# include "rsl.inc"
3776
3777	INTEGER i,j,k
3778
3779	logical, external :: wrf_dm_on_monitor
3780	real globbuf( ids:ide, kds:kde, jds:jde )
3781	character*3 ord, stag
3782
3783	if ( kds == kde ) then
3784	ord = 'xy'
3785	stag = 'xy'
3786	CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
3787	ids, ide, jds, jde, kds, kde, &
3788	ims, ime, jms, jme, kms, kme, &
3789	its, ite, jts, jte, kts, kte )
3790	else
3791
3792	stag = 'xyz'
3793	ord = 'xzy'
3794	CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
3795	ids, ide, kds, kde, jds, jde, &
3796	ims, ime, kms, kme, jms, jme, &
3797	its, ite, kts, kte, jts, jte )
3798	endif
3799
3800
3801	if ( wrf_dm_on_monitor() ) THEN
3802	WRITE(68,*) ide-ids+1, jde-jds+1 , s
3803	DO j = jds, jde
3804	DO i = ids, ide
3805	WRITE(68,*) globbuf(i,1,j)
3806	ENDDO
3807	ENDDO
3808	endif
3809
3810	RETURN
3811	END
3812
3813	SUBROUTINE wrf_abort
3814	! <DESCRIPTION>
3815	! Kill the run. Calls MPI_ABORT.
3816	!
3817	! </DESCRIPTION>
3818	#ifndef STUBMPI
3819	INCLUDE 'mpif.h'
3820	CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
3821	#else
3822	STOP
3823	#endif
3824	END SUBROUTINE wrf_abort
3825
3826	SUBROUTINE wrf_dm_shutdown
3827	# include "rsl.inc"
3828	! <DESCRIPTION>
3829	! Shutdown (gracefully) the underlying comm layer.
3830	!
3831	! </DESCRIPTION>
3832	CALL RSL_SHUTDOWN
3833	RETURN
3834	END SUBROUTINE wrf_dm_shutdown
3835
3836	LOGICAL FUNCTION wrf_dm_on_monitor()
3837	LOGICAL rsl_iammonitor
3838	EXTERNAL rsl_iammonitor
3839	! <DESCRIPTION>
3840	! Return true on task zero, false otherwise.
3841	!
3842	! </DESCRIPTION>
3843	wrf_dm_on_monitor = rsl_iammonitor()
3844	RETURN
3845	END FUNCTION wrf_dm_on_monitor
3846
3847	SUBROUTINE wrf_get_dm_communicator ( communicator )
3848	IMPLICIT NONE
3849	INTEGER , INTENT(OUT) :: communicator
3850	! <DESCRIPTION>
3851	! Return the communicator the underlying comm layer is using.
3852	!
3853	! </DESCRIPTION>
3854	CALL rsl_get_communicator ( communicator )
3855	RETURN
3856	END SUBROUTINE wrf_get_dm_communicator
3857
3858	SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
3859	IMPLICIT NONE
3860	INTEGER , INTENT(OUT) :: iocommunicator
3861	! <DESCRIPTION>
3862	! Return the io communicator the underlying comm layer is using. Not used.
3863	!
3864	! </DESCRIPTION>
3865	CALL rsl_get_communicator ( iocommunicator ) ! same as regular communicator
3866	RETURN
3867	END SUBROUTINE wrf_get_dm_iocommunicator
3868
3869	SUBROUTINE wrf_set_dm_communicator ( communicator )
3870	IMPLICIT NONE
3871	INTEGER , INTENT(IN) :: communicator
3872	! <DESCRIPTION>
3873	! Set the communicator the underlying comm layer is to use.
3874	!
3875	! </DESCRIPTION>
3876	CALL rsl_set_communicator ( communicator )
3877	RETURN
3878	END SUBROUTINE wrf_set_dm_communicator
3879
3880	SUBROUTINE wrf_set_dm_iocommunicator ( iocommunicator )
3881	IMPLICIT NONE
3882	INTEGER , INTENT(IN) :: iocommunicator
3883	! <DESCRIPTION>
3884	! Set the io communicator the underlying comm layer is to use. Not used.
3885	!
3886	! </DESCRIPTION>
3887	! CALL rsl_set_communicator ( iocommunicator ) ! same as regular communicator
3888	RETURN
3889	END SUBROUTINE wrf_set_dm_iocommunicator
3890
3891
3892	!!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3893
3894	SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,stagger,ordering,&
3895	DS1,DE1,DS2,DE2,DS3,DE3,&
3896	MS1,ME1,MS2,ME2,MS3,ME3,&
3897	PS1,PE1,PS2,PE2,PS3,PE3 )
3898	IMPLICIT NONE
3899	#include "rsl.inc"
3900	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
3901	MS1,ME1,MS2,ME2,MS3,ME3,&
3902	PS1,PE1,PS2,PE2,PS3,PE3
3903	CHARACTER () stagger,ordering
3904	INTEGER fid,domdesc
3905	REAL globbuf(*)
3906	REAL buf(*)
3907	! <DESCRIPTION>
3908	! Collective operation. Given a buffer of type real corresponding to a 2- or 3-dimensional patch on a local processor,
3909	! return on task zero the global array assembled from the pieces stored on each processor.
3910	!
3911	! </DESCRIPTION>
3912
3913	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,TRUE_RSL_REAL,&
3914	DS1,DE1,DS2,DE2,DS3,DE3,&
3915	MS1,ME1,MS2,ME2,MS3,ME3,&
3916	PS1,PE1,PS2,PE2,PS3,PE3 )
3917
3918	RETURN
3919	END SUBROUTINE wrf_patch_to_global_real
3920
3921	SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,stagger,ordering,&
3922	DS1,DE1,DS2,DE2,DS3,DE3,&
3923	MS1,ME1,MS2,ME2,MS3,ME3,&
3924	PS1,PE1,PS2,PE2,PS3,PE3 )
3925	IMPLICIT NONE
3926	#include "rsl.inc"
3927	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
3928	MS1,ME1,MS2,ME2,MS3,ME3,&
3929	PS1,PE1,PS2,PE2,PS3,PE3
3930	CHARACTER () stagger,ordering
3931	INTEGER fid,domdesc
3932	DOUBLEPRECISION globbuf(*)
3933	DOUBLEPRECISION buf(*)
3934	! <DESCRIPTION>
3935	! Collective operation. Given a buffer of type double corresponding to a 2- or 3-dimensional patch on a local processor,
3936	! return on task zero the global array assembled from the pieces stored on each processor.
3937	!
3938	! </DESCRIPTION>
3939
3940	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,RSL_DOUBLE,&
3941	DS1,DE1,DS2,DE2,DS3,DE3,&
3942	MS1,ME1,MS2,ME2,MS3,ME3,&
3943	PS1,PE1,PS2,PE2,PS3,PE3 )
3944
3945	RETURN
3946	END SUBROUTINE wrf_patch_to_global_double
3947
3948
3949	SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,stagger,ordering,&
3950	DS1,DE1,DS2,DE2,DS3,DE3,&
3951	MS1,ME1,MS2,ME2,MS3,ME3,&
3952	PS1,PE1,PS2,PE2,PS3,PE3 )
3953	IMPLICIT NONE
3954	#include "rsl.inc"
3955	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
3956	MS1,ME1,MS2,ME2,MS3,ME3,&
3957	PS1,PE1,PS2,PE2,PS3,PE3
3958	CHARACTER () stagger,ordering
3959	INTEGER fid,domdesc
3960	INTEGER globbuf(*)
3961	INTEGER buf(*)
3962	! <DESCRIPTION>
3963	! Collective operation. Given a buffer of type integer corresponding to a 2- or 3-dimensional patch on a local processor,
3964	! return on task zero the global array assembled from the pieces stored on each processor.
3965	!
3966	! </DESCRIPTION>
3967
3968	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,rsl_integer,&
3969	DS1,DE1,DS2,DE2,DS3,DE3,&
3970	MS1,ME1,MS2,ME2,MS3,ME3,&
3971	PS1,PE1,PS2,PE2,PS3,PE3 )
3972
3973	RETURN
3974	END SUBROUTINE wrf_patch_to_global_integer
3975
3976	SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,stagger,ordering,&
3977	DS1,DE1,DS2,DE2,DS3,DE3,&
3978	MS1,ME1,MS2,ME2,MS3,ME3,&
3979	PS1,PE1,PS2,PE2,PS3,PE3 )
3980	IMPLICIT NONE
3981	#include "rsl.inc"
3982	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
3983	MS1,ME1,MS2,ME2,MS3,ME3,&
3984	PS1,PE1,PS2,PE2,PS3,PE3
3985	CHARACTER () stagger,ordering
3986	INTEGER fid,domdesc
3987	INTEGER globbuf(*)
3988	INTEGER buf(*)
3989	! <DESCRIPTION>
3990	! Collective operation. Given a buffer of type integer corresponding to a 2- or 3-dimensional patch on a local processor,
3991	! return on task zero the global array assembled from the pieces stored on each processor.
3992	!
3993	! </DESCRIPTION>
3994
3995	IF ( LWORDSIZE .NE. IWORDSIZE ) THEN
3996	CALL wrf_error_fatal( "module_dm: LWORDSIZE != IWORDSIZE on this machine. RSL cannot cast" )
3997	ENDIF
3998
3999	CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,rsl_integer,&
4000	DS1,DE1,DS2,DE2,DS3,DE3,&
4001	MS1,ME1,MS2,ME2,MS3,ME3,&
4002	PS1,PE1,PS2,PE2,PS3,PE3 )
4003
4004	RETURN
4005	END SUBROUTINE wrf_patch_to_global_logical
4006
4007	SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,type,&
4008	DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4009	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4010	PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
4011	USE module_driver_constants
4012	USE module_timing
4013	USE module_wrf_error
4014	IMPLICIT NONE
4015	#include "rsl.inc"
4016	INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4017	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4018	PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
4019	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4020	MS1,ME1,MS2,ME2,MS3,ME3,&
4021	PS1,PE1,PS2,PE2,PS3,PE3
4022	CHARACTER () stagger,ordering
4023	INTEGER fid,domdesc,type
4024	REAL globbuf(*)
4025	REAL buf(*)
4026
4027	LOGICAL, EXTERNAL :: has_char
4028	INTEGER glen(3),llen(3),glen2d(3),llen2d(3)
4029	INTEGER i, j, k, ord, ord2d, ndim
4030	INTEGER mlen, nlen, zlen
4031
4032	DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
4033	MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
4034	PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
4035
4036	ndim = len(TRIM(ordering))
4037
4038	CALL rsl_get_glen( domdesc, glen(1), glen(2), glen(3) )
4039
4040	SELECT CASE ( TRIM(ordering) )
4041	CASE ( 'xyz','xy' )
4042	ord = io3d_ijk_internal ; ord2d = io2d_ij_internal
4043	! the non-staggered variables come in at one-less than
4044	! domain dimensions, but RSL wants full domain spec, so
4045	! adjust if not staggered
4046	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4047	IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
4048	IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4049	CASE ( 'yxz','yx' )
4050	ord = io3d_jik_internal ; ord2d = io2d_ji_internal
4051	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4052	IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
4053	IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4054	CASE ( 'zxy' )
4055	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4056	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4057	IF ( .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
4058	ord = io3d_kij_internal ; ord2d = io2d_ij_internal
4059	#if 0
4060	CASE ( 'zyx' )
4061	ord = io3d_kji_internal ; ord2d = io2d_ji_internal
4062	CASE ( 'yzx' )
4063	ord = io3d_jki_internal ; ord2d = io2d_ji_internal
4064	#endif
4065	CASE ( 'xzy' )
4066	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4067	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4068	IF ( .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
4069	ord = io3d_ikj_internal ; ord2d = io2d_ij_internal
4070	CASE DEFAULT
4071	ord = -1 ; ord2d = -1
4072	END SELECT
4073
4074
4075	glen(1) = DE1-DS1+1 ; glen(2) = DE2-DS2+1 ; glen(3) = DE3-DS3+1
4076	llen(1) = ME1-MS1+1 ; llen(2) = ME2-MS2+1 ; llen(3) = ME3-MS3+1
4077	glen2d(1) = DE1-DS1+1 ; glen2d(2) = DE2-DS2+1
4078	llen2d(1) = ME1-MS1+1 ; llen2d(2) = ME2-MS2+1
4079
4080	IF ( wrf_at_debug_level(500) ) THEN
4081	CALL start_timing
4082	ENDIF
4083
4084	IF ( ndim .EQ. 3 ) THEN
4085	CALL rsl_write(globbuf,ord,buf,domdesc,type,glen,llen)
4086	ELSE
4087	CALL rsl_write(globbuf,ord2d,buf,domdesc,type,glen2d,llen2d)
4088	ENDIF
4089	IF ( wrf_at_debug_level(500) ) THEN
4090	CALL end_timing('wrf_patch_to_global_generic')
4091	ENDIF
4092	RETURN
4093	END SUBROUTINE wrf_patch_to_global_generic
4094
4095	!!!!!!!!!!!!!!!!!!!!!!! GLOBAL TO PATCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4096
4097	SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
4098	DS1,DE1,DS2,DE2,DS3,DE3,&
4099	MS1,ME1,MS2,ME2,MS3,ME3,&
4100	PS1,PE1,PS2,PE2,PS3,PE3 )
4101	IMPLICIT NONE
4102	#include "rsl.inc"
4103	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4104	MS1,ME1,MS2,ME2,MS3,ME3,&
4105	PS1,PE1,PS2,PE2,PS3,PE3
4106	CHARACTER () stagger,ordering
4107	INTEGER fid,domdesc
4108	REAL globbuf(*)
4109	REAL buf(*)
4110	! <DESCRIPTION>
4111	! Collective operation. Given a global 2- or 3-dimensional array of type real on task zero,
4112	! return the appropriate decomposed section (patch) on each processor.
4113	!
4114	! </DESCRIPTION>
4115
4116	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,TRUE_RSL_REAL,&
4117	DS1,DE1,DS2,DE2,DS3,DE3,&
4118	MS1,ME1,MS2,ME2,MS3,ME3,&
4119	PS1,PE1,PS2,PE2,PS3,PE3 )
4120	RETURN
4121	END SUBROUTINE wrf_global_to_patch_real
4122
4123	SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,stagger,ordering,&
4124	DS1,DE1,DS2,DE2,DS3,DE3,&
4125	MS1,ME1,MS2,ME2,MS3,ME3,&
4126	PS1,PE1,PS2,PE2,PS3,PE3 )
4127	IMPLICIT NONE
4128	#include "rsl.inc"
4129	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4130	MS1,ME1,MS2,ME2,MS3,ME3,&
4131	PS1,PE1,PS2,PE2,PS3,PE3
4132	CHARACTER () stagger,ordering
4133	INTEGER fid,domdesc
4134	DOUBLEPRECISION globbuf(*)
4135	DOUBLEPRECISION buf(*)
4136	! <DESCRIPTION>
4137	! Collective operation. Given a global 2- or 3-dimensional array of type double on task zero,
4138	! return the appropriate decomposed section (patch) on each processor.
4139	!
4140	! </DESCRIPTION>
4141
4142	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,RSL_DOUBLE,&
4143	DS1,DE1,DS2,DE2,DS3,DE3,&
4144	MS1,ME1,MS2,ME2,MS3,ME3,&
4145	PS1,PE1,PS2,PE2,PS3,PE3 )
4146	RETURN
4147	END SUBROUTINE wrf_global_to_patch_double
4148
4149
4150	SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,stagger,ordering,&
4151	DS1,DE1,DS2,DE2,DS3,DE3,&
4152	MS1,ME1,MS2,ME2,MS3,ME3,&
4153	PS1,PE1,PS2,PE2,PS3,PE3 )
4154	IMPLICIT NONE
4155	#include "rsl.inc"
4156	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4157	MS1,ME1,MS2,ME2,MS3,ME3,&
4158	PS1,PE1,PS2,PE2,PS3,PE3
4159	CHARACTER () stagger,ordering
4160	INTEGER fid,domdesc
4161	INTEGER globbuf(*)
4162	INTEGER buf(*)
4163	! <DESCRIPTION>
4164	! Collective operation. Given a global 2- or 3-dimensional array of type integer on task zero,
4165	! return the appropriate decomposed section (patch) on each processor.
4166	!
4167	! </DESCRIPTION>
4168
4169	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,rsl_integer,&
4170	DS1,DE1,DS2,DE2,DS3,DE3,&
4171	MS1,ME1,MS2,ME2,MS3,ME3,&
4172	PS1,PE1,PS2,PE2,PS3,PE3 )
4173	RETURN
4174	END SUBROUTINE wrf_global_to_patch_integer
4175
4176	SUBROUTINE wrf_global_to_patch_logical (globbuf,buf,domdesc,stagger,ordering,&
4177	DS1,DE1,DS2,DE2,DS3,DE3,&
4178	MS1,ME1,MS2,ME2,MS3,ME3,&
4179	PS1,PE1,PS2,PE2,PS3,PE3 )
4180	IMPLICIT NONE
4181	#include "rsl.inc"
4182	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4183	MS1,ME1,MS2,ME2,MS3,ME3,&
4184	PS1,PE1,PS2,PE2,PS3,PE3
4185	CHARACTER () stagger,ordering
4186	INTEGER fid,domdesc
4187	LOGICAL globbuf(*)
4188	LOGICAL buf(*)
4189	! <DESCRIPTION>
4190	! Collective operation. Given a global 2- or 3-dimensional array of type integer on task zero,
4191	! return the appropriate decomposed section (patch) on each processor.
4192	!
4193	! </DESCRIPTION>
4194
4195	IF ( LWORDSIZE .NE. IWORDSIZE ) THEN
4196	CALL wrf_error_fatal( "RSL module_dm: LWORDSIZE != IWORDSIZE on this machine. RSL cannot cast" )
4197	ENDIF
4198
4199	CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,rsl_integer,&
4200	DS1,DE1,DS2,DE2,DS3,DE3,&
4201	MS1,ME1,MS2,ME2,MS3,ME3,&
4202	PS1,PE1,PS2,PE2,PS3,PE3 )
4203	RETURN
4204	END SUBROUTINE wrf_global_to_patch_logical
4205
4206	SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,type,&
4207	DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4208	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4209	PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
4210	USE module_driver_constants
4211	IMPLICIT NONE
4212	#include "rsl.inc"
4213	INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4214	MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4215	PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
4216	INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4217	MS1,ME1,MS2,ME2,MS3,ME3,&
4218	PS1,PE1,PS2,PE2,PS3,PE3
4219	CHARACTER () stagger,ordering
4220	INTEGER fid,domdesc,type
4221	REAL globbuf(*)
4222	REAL buf(*)
4223	LOGICAL, EXTERNAL :: has_char
4224
4225	INTEGER i,j,k,ord,ord2d,ndim
4226	INTEGER glen(3),llen(3),glen2d(3),llen2d(3)
4227
4228	DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
4229	MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
4230	PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
4231
4232	ndim = len(TRIM(ordering))
4233
4234	SELECT CASE ( TRIM(ordering) )
4235	CASE ( 'xyz','xy' )
4236	ord = io3d_ijk_internal ; ord2d = io2d_ij_internal
4237	! the non-staggered variables come in at one-less than
4238	! domain dimensions, but RSL wants full domain spec, so
4239	! adjust if not staggered
4240	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4241	IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
4242	IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4243	CASE ( 'yxz','yx' )
4244	ord = io3d_jik_internal ; ord2d = io2d_ji_internal
4245	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4246	IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
4247	IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4248	CASE ( 'zxy' )
4249	ord = io3d_kij_internal ; ord2d = io2d_ij_internal
4250	IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4251	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4252	IF ( .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
4253	#if 0
4254	CASE ( 'zyx' )
4255	ord = io3d_kji_internal ; ord2d = io2d_ji_internal
4256	CASE ( 'yzx' )
4257	ord = io3d_jki_internal ; ord2d = io2d_ji_internal
4258	#endif
4259	CASE ( 'xzy' )
4260	ord = io3d_ikj_internal ; ord2d = io2d_ij_internal
4261	IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4262	IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4263	IF ( .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
4264	CASE DEFAULT
4265	ord = -1 ; ord2d = -1
4266	END SELECT
4267
4268	glen(1) = DE1-DS1+1 ; glen(2) = DE2-DS2+1 ; glen(3) = DE3-DS3+1
4269	llen(1) = ME1-MS1+1 ; llen(2) = ME2-MS2+1 ; llen(3) = ME3-MS3+1
4270	glen2d(1) = DE1-DS1+1 ; glen2d(2) = DE2-DS2+1
4271	llen2d(1) = ME1-MS1+1 ; llen2d(2) = ME2-MS2+1
4272
4273	IF ( ndim .EQ. 3 ) THEN
4274	CALL rsl_read(globbuf,ord,buf,domdesc,type,glen,llen)
4275	ELSE
4276	CALL rsl_read(globbuf,ord2d,buf,domdesc,type,glen2d,llen2d)
4277	ENDIF
4278	RETURN
4279	END SUBROUTINE wrf_global_to_patch_generic
4280
4281
4282	!------------------------------------------------------------------
4283
4284	#if ( EM_CORE == 1 )
4285
4286	!------------------------------------------------------------------
4287
4288	SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags &
4289	!
4290	#include "em_dummy_new_args.inc"
4291	!
4292	)
4293	USE module_domain
4294	USE module_configure
4295	USE module_dm
4296	!
4297	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4298	TYPE(domain), POINTER :: ngrid
4299	#include "em_dummy_new_decl.inc"
4300	#include "em_i1_decl.inc"
4301	INTEGER nlev, msize
4302	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4303	TYPE (grid_config_rec_type) :: config_flags
4304	REAL xv(500)
4305	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4306	cims, cime, cjms, cjme, ckms, ckme, &
4307	cips, cipe, cjps, cjpe, ckps, ckpe
4308	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4309	nims, nime, njms, njme, nkms, nkme, &
4310	nips, nipe, njps, njpe, nkps, nkpe
4311	! <DESCRIPTION>
4312	! Description is to do...
4313	! </DESCRIPTION>
4314
4315	#ifdef DM_PARALLEL
4316	# define REGISTER_I1
4317	# include "em_data_calls.inc"
4318	#endif
4319
4320	CALL get_ijk_from_grid ( grid , &
4321	cids, cide, cjds, cjde, ckds, ckde, &
4322	cims, cime, cjms, cjme, ckms, ckme, &
4323	cips, cipe, cjps, cjpe, ckps, ckpe )
4324	CALL get_ijk_from_grid ( ngrid , &
4325	nids, nide, njds, njde, nkds, nkde, &
4326	nims, nime, njms, njme, nkms, nkme, &
4327	nips, nipe, njps, njpe, nkps, nkpe )
4328
4329	nlev = ckde - ckds + 1
4330
4331	# include "em_nest_interpdown_unpack.inc"
4332
4333	#include "HALO_EM_FORCE_DOWN.inc"
4334
4335	! code here to interpolate the data into the nested domain
4336	# include "em_nest_forcedown_interp.inc"
4337
4338	RETURN
4339	END SUBROUTINE force_domain_em_part2
4340
4341
4342
4343	!------------------------------------------------------------------
4344
4345	SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags &
4346	!
4347	#include "em_dummy_new_args.inc"
4348	!
4349	)
4350	USE module_domain
4351	USE module_configure
4352	USE module_dm
4353	USE module_timing
4354	!
4355	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4356	TYPE(domain), POINTER :: intermediate_grid
4357	TYPE(domain), POINTER :: ngrid
4358	#include "em_dummy_new_decl.inc"
4359	INTEGER nlev, msize
4360	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4361	TYPE (grid_config_rec_type) :: config_flags
4362	REAL xv(500)
4363	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4364	cims, cime, cjms, cjme, ckms, ckme, &
4365	cips, cipe, cjps, cjpe, ckps, ckpe
4366	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4367	nims, nime, njms, njme, nkms, nkme, &
4368	nips, nipe, njps, njpe, nkps, nkpe
4369
4370	!
4371
4372	CALL get_ijk_from_grid ( grid , &
4373	cids, cide, cjds, cjde, ckds, ckde, &
4374	cims, cime, cjms, cjme, ckms, ckme, &
4375	cips, cipe, cjps, cjpe, ckps, ckpe )
4376	CALL get_ijk_from_grid ( intermediate_grid , &
4377	nids, nide, njds, njde, nkds, nkde, &
4378	nims, nime, njms, njme, nkms, nkme, &
4379	nips, nipe, njps, njpe, nkps, nkpe )
4380
4381	nlev = ckde - ckds + 1
4382
4383	# include "em_nest_interpdown_pack.inc"
4384
4385	CALL rsl_bcast_msgs
4386
4387	RETURN
4388	END SUBROUTINE interp_domain_em_part1
4389
4390	SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags &
4391	!
4392	#include "em_dummy_new_args.inc"
4393	!
4394	)
4395	USE module_domain
4396	USE module_configure
4397	USE module_dm
4398	!
4399	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4400	TYPE(domain), POINTER :: ngrid
4401	#include "em_dummy_new_decl.inc"
4402	#include "em_i1_decl.inc"
4403	INTEGER nlev, msize
4404	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4405	TYPE (grid_config_rec_type) :: config_flags
4406	REAL xv(500)
4407	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4408	cims, cime, cjms, cjme, ckms, ckme, &
4409	cips, cipe, cjps, cjpe, ckps, ckpe
4410	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4411	nims, nime, njms, njme, nkms, nkme, &
4412	nips, nipe, njps, njpe, nkps, nkpe
4413
4414	#ifdef DM_PARALLEL
4415	# define REGISTER_I1
4416	# include "em_data_calls.inc"
4417	#endif
4418	CALL get_ijk_from_grid ( grid , &
4419	cids, cide, cjds, cjde, ckds, ckde, &
4420	cims, cime, cjms, cjme, ckms, ckme, &
4421	cips, cipe, cjps, cjpe, ckps, ckpe )
4422	CALL get_ijk_from_grid ( ngrid , &
4423	nids, nide, njds, njde, nkds, nkde, &
4424	nims, nime, njms, njme, nkms, nkme, &
4425	nips, nipe, njps, njpe, nkps, nkpe )
4426
4427	nlev = ckde - ckds + 1
4428
4429	# include "em_nest_interpdown_unpack.inc"
4430
4431	#include "HALO_EM_INTERP_DOWN.inc"
4432	! code here to interpolate the data into the nested domain
4433
4434	# include "em_nest_interpdown_interp.inc"
4435
4436	RETURN
4437	END SUBROUTINE interp_domain_em_part2
4438
4439	!------------------------------------------------------------------
4440	! This routine exists only to call a halo on a domain (the nest)
4441	! gets called from feedback_domain_em_part1, below. This is needed
4442	! because the halo code expects the fields being exchanged to have
4443	! been dereferenced from the grid data structure, but in feedback_domain_em_part1
4444	! the grid data structure points to the coarse domain, not the nest.
4445	! And we want the halo exchange on the nest, so that the code in
4446	! em_nest_feedbackup_interp.inc will work correctly on multi-p. JM 20040308
4447	!
4448	SUBROUTINE feedback_nest_prep ( grid, config_flags &
4449	!
4450	#include "em_dummy_new_args.inc"
4451	!
4452	)
4453	USE module_domain
4454	USE module_configure
4455	USE module_dm
4456	USE module_state_description
4457	!
4458	TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid")
4459	TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
4460	! soil temp, moisture, etc., has vertical dim
4461	! of soil categories
4462	#include "em_dummy_new_decl.inc"
4463
4464	#ifdef DM_PARALLEL
4465	# include "em_data_calls.inc"
4466	#endif
4467
4468	#ifdef DM_PARALLEL
4469	# include "HALO_EM_INTERP_UP.inc"
4470	#endif
4471
4472	END SUBROUTINE feedback_nest_prep
4473
4474	SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags &
4475	!
4476	#include "em_dummy_new_args.inc"
4477	!
4478	)
4479	USE module_domain
4480	USE module_configure
4481	USE module_dm
4482	!
4483	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4484	TYPE(domain), POINTER :: ngrid
4485	#include "em_dummy_new_decl.inc"
4486	INTEGER nlev, msize
4487	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4488	TYPE(domain), POINTER :: xgrid
4489	TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
4490	REAL xv(500)
4491	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4492	cims, cime, cjms, cjme, ckms, ckme, &
4493	cips, cipe, cjps, cjpe, ckps, ckpe
4494	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4495	nims, nime, njms, njme, nkms, nkme, &
4496	nips, nipe, njps, njpe, nkps, nkpe
4497	INTERFACE
4498	SUBROUTINE feedback_nest_prep ( grid, config_flags &
4499	!
4500	#include "em_dummy_new_args.inc"
4501	!
4502	)
4503	USE module_domain
4504	USE module_configure
4505	USE module_dm
4506	USE module_state_description
4507	!
4508	TYPE (grid_config_rec_type) :: config_flags
4509	TYPE(domain), TARGET :: grid
4510	#include "em_dummy_new_decl.inc"
4511	END SUBROUTINE feedback_nest_prep
4512
4513	END INTERFACE
4514
4515	CALL get_ijk_from_grid ( grid , &
4516	cids, cide, cjds, cjde, ckds, ckde, &
4517	cims, cime, cjms, cjme, ckms, ckme, &
4518	cips, cipe, cjps, cjpe, ckps, ckpe )
4519	CALL get_ijk_from_grid ( ngrid , &
4520	nids, nide, njds, njde, nkds, nkde, &
4521	nims, nime, njms, njme, nkms, nkme, &
4522	nips, nipe, njps, njpe, nkps, nkpe )
4523
4524	nlev = ckde - ckds + 1
4525
4526	ips_save = ngrid%i_parent_start ! used in feedback_domain_em_part2 below
4527	jps_save = ngrid%j_parent_start
4528	ipe_save = ngrid%i_parent_start + (nide-nids+1) / ngrid%parent_grid_ratio - 1
4529	jpe_save = ngrid%j_parent_start + (njde-njds+1) / ngrid%parent_grid_ratio - 1
4530
4531	CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
4532	CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
4533
4534	xgrid => grid
4535	grid => ngrid
4536
4537	CALL feedback_nest_prep ( grid, nconfig_flags &
4538	!
4539	#include "em_actual_new_args.inc"
4540	!
4541	)
4542
4543	grid => xgrid
4544	CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
4545
4546	# include "em_nest_feedbackup_interp.inc"
4547
4548	RETURN
4549	END SUBROUTINE feedback_domain_em_part1
4550
4551	!------------------------------------------------------------------
4552
4553	SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags &
4554	!
4555	#include "em_dummy_new_args.inc"
4556	!
4557	)
4558	USE module_domain
4559	USE module_configure
4560	USE module_dm
4561	!
4562	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4563	TYPE(domain), POINTER :: intermediate_grid
4564	TYPE(domain), POINTER :: ngrid
4565	#include "em_dummy_new_decl.inc"
4566	#include "em_i1_decl.inc"
4567	INTEGER nlev, msize
4568	INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4569	TYPE (grid_config_rec_type) :: config_flags
4570	REAL xv(500)
4571	INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4572	cims, cime, cjms, cjme, ckms, ckme, &
4573	cips, cipe, cjps, cjpe, ckps, ckpe
4574	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4575	nims, nime, njms, njme, nkms, nkme, &
4576	nips, nipe, njps, njpe, nkps, nkpe
4577	REAL :: nest_influence
4578	LOGICAL, EXTERNAL :: em_cd_feedback_mask
4579
4580	#ifdef DM_PARALLEL
4581	# define REGISTER_I1
4582	# include "em_data_calls.inc"
4583	#endif
4584
4585	nest_influence = 1.
4586
4587	CALL get_ijk_from_grid ( grid , &
4588	cids, cide, cjds, cjde, ckds, ckde, &
4589	cims, cime, cjms, cjme, ckms, ckme, &
4590	cips, cipe, cjps, cjpe, ckps, ckpe )
4591	CALL get_ijk_from_grid ( intermediate_grid , &
4592	nids, nide, njds, njde, nkds, nkde, &
4593	nims, nime, njms, njme, nkms, nkme, &
4594	nips, nipe, njps, njpe, nkps, nkpe )
4595
4596	nlev = ckde - ckds + 1
4597
4598	# include "em_nest_feedbackup_pack.inc"
4599
4600	CALL rsl_merge_msgs
4601
4602	#define NEST_INFLUENCE(A,B) A = B
4603	# include "em_nest_feedbackup_unpack.inc"
4604
4605	! smooth coarse grid
4606
4607	CALL get_ijk_from_grid ( ngrid, &
4608	nids, nide, njds, njde, nkds, nkde, &
4609	nims, nime, njms, njme, nkms, nkme, &
4610	nips, nipe, njps, njpe, nkps, nkpe )
4611
4612	# include "HALO_EM_INTERP_UP.inc"
4613	# include "em_nest_feedbackup_smooth.inc"
4614
4615	RETURN
4616	END SUBROUTINE feedback_domain_em_part2
4617
4618	#endif
4619
4620	!------------------------------------------------------------------
4621
4622	#if ( NMM_CORE == 1 )
4623	!==============================================================================
4624	! NMM nesting infrastructure extended from EM core. This is gopal's doing.
4625	!==============================================================================
4626
4627	SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags &
4628	!
4629	#include "nmm_dummy_args.inc"
4630	!
4631	)
4632	USE module_domain
4633	USE module_configure
4634	USE module_dm
4635	USE module_timing
4636	IMPLICIT NONE
4637	!
4638	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4639	TYPE(domain), POINTER :: intermediate_grid
4640	TYPE(domain), POINTER :: ngrid
4641	#include "nmm_dummy_decl.inc"
4642	TYPE (grid_config_rec_type) :: config_flags
4643
4644	CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4645
4646	RETURN
4647	END SUBROUTINE interp_domain_nmm_part1
4648
4649	SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags &
4650	!
4651	#include "nmm_dummy_args.inc"
4652	!
4653	)
4654	USE module_domain
4655	USE module_configure
4656	USE module_dm
4657	IMPLICIT NONE
4658	!
4659	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4660	TYPE(domain), POINTER :: ngrid
4661	#include "nmm_dummy_decl.inc"
4662	TYPE (grid_config_rec_type) :: config_flags
4663
4664	CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4665
4666	RETURN
4667	END SUBROUTINE interp_domain_nmm_part2
4668
4669	SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags &
4670	!
4671	#include "nmm_dummy_args.inc"
4672	!
4673	)
4674	USE module_domain
4675	USE module_configure
4676	USE module_dm
4677	USE module_timing
4678	!
4679	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4680	TYPE(domain), POINTER :: intermediate_grid
4681	#include "nmm_dummy_decl.inc"
4682	TYPE (grid_config_rec_type) :: config_flags
4683
4684	CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4685
4686	RETURN
4687	END SUBROUTINE force_domain_nmm_part1
4688
4689	SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags &
4690	!
4691	#include "nmm_dummy_args.inc"
4692	!
4693	)
4694	USE module_domain
4695	USE module_configure
4696	USE module_dm
4697	IMPLICIT NONE
4698	!
4699	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4700	TYPE(domain), POINTER :: ngrid
4701	#include "nmm_dummy_decl.inc"
4702	TYPE (grid_config_rec_type) :: config_flags
4703
4704	CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4705
4706	RETURN
4707	END SUBROUTINE force_domain_nmm_part2
4708
4709	SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags &
4710	!
4711	#include "nmm_dummy_args.inc"
4712	!
4713	)
4714	USE module_domain
4715	USE module_configure
4716	USE module_dm
4717	IMPLICIT NONE
4718	!
4719	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4720	TYPE(domain), POINTER :: ngrid
4721	#include "nmm_dummy_decl.inc"
4722	TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
4723
4724	CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4725
4726	RETURN
4727	END SUBROUTINE feedback_domain_nmm_part1
4728
4729	SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags &
4730	!
4731	#include "nmm_dummy_args.inc"
4732	!
4733	)
4734	USE module_domain
4735	USE module_configure
4736	USE module_dm
4737	USE module_utility
4738	IMPLICIT NONE
4739
4740	!
4741	TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4742	TYPE(domain), POINTER :: intermediate_grid
4743	TYPE(domain), POINTER :: ngrid
4744
4745	#include "nmm_dummy_decl.inc"
4746	TYPE (grid_config_rec_type) :: config_flags
4747
4748	CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4749
4750	RETURN
4751	END SUBROUTINE feedback_domain_nmm_part2
4752
4753	!=================================================================================
4754	! End of gopal's doing
4755	!=================================================================================
4756	#endif
4757
4758
4759
4760	#ifndef STUBMPI
4761
4762	SUBROUTINE wrf_gatherv_real (Field, field_ofst, &
4763	my_count , & ! sendcount
4764	globbuf, glob_ofst , & ! recvbuf
4765	counts , & ! recvcounts
4766	displs , & ! displs
4767	root , & ! root
4768	communicator , & ! communicator
4769	ierr )
4770	USE module_dm
4771	IMPLICIT NONE
4772	INCLUDE 'mpif.h'
4773	INTEGER field_ofst, glob_ofst
4774	INTEGER my_count, communicator, root, ierr
4775	INTEGER , DIMENSION(*) :: counts, displs
4776	REAL, DIMENSION(*) :: Field, globbuf
4777
4778	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
4779	my_count , & ! sendcount
4780	getrealmpitype() , & ! sendtype
4781	globbuf( glob_ofst ) , & ! recvbuf
4782	counts , & ! recvcounts
4783	displs , & ! displs
4784	getrealmpitype() , & ! recvtype
4785	root , & ! root
4786	communicator , & ! communicator
4787	ierr )
4788
4789	END SUBROUTINE wrf_gatherv_real
4790
4791	SUBROUTINE wrf_gatherv_integer (Field, field_ofst, &
4792	my_count , & ! sendcount
4793	globbuf, glob_ofst , & ! recvbuf
4794	counts , & ! recvcounts
4795	displs , & ! displs
4796	root , & ! root
4797	communicator , & ! communicator
4798	ierr )
4799	USE module_dm
4800	IMPLICIT NONE
4801	INCLUDE 'mpif.h'
4802	INTEGER field_ofst, glob_ofst
4803	INTEGER my_count, communicator, root, ierr
4804	INTEGER , DIMENSION(*) :: counts, displs
4805	INTEGER, DIMENSION(*) :: Field, globbuf
4806
4807	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
4808	my_count , & ! sendcount
4809	MPI_INTEGER , & ! sendtype
4810	globbuf( glob_ofst ) , & ! recvbuf
4811	counts , & ! recvcounts
4812	displs , & ! displs
4813	MPI_INTEGER , & ! recvtype
4814	root , & ! root
4815	communicator , & ! communicator
4816	ierr )
4817
4818	END SUBROUTINE wrf_gatherv_integer
4819
4820	SUBROUTINE wrf_gatherv_double (Field, field_ofst, &
4821	my_count , & ! sendcount
4822	globbuf, glob_ofst , & ! recvbuf
4823	counts , & ! recvcounts
4824	displs , & ! displs
4825	root , & ! root
4826	communicator , & ! communicator
4827	ierr )
4828	USE module_dm
4829	IMPLICIT NONE
4830	INCLUDE 'mpif.h'
4831	INTEGER field_ofst, glob_ofst
4832	INTEGER my_count, communicator, root, ierr
4833	INTEGER , DIMENSION(*) :: counts, displs
4834	DOUBLE PRECISION, DIMENSION(*) :: Field, globbuf
4835
4836	CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
4837	my_count , & ! sendcount
4838	MPI_DOUBLE_PRECISION , & ! sendtype
4839	globbuf( glob_ofst ) , & ! recvbuf
4840	counts , & ! recvcounts
4841	displs , & ! displs
4842	MPI_DOUBLE_PRECISION , & ! recvtype
4843	root , & ! root
4844	communicator , & ! communicator
4845	ierr )
4846
4847	END SUBROUTINE wrf_gatherv_double
4848
4849	#endif

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

Download in other formats:

Original Format