module_dm.F
References to this file elsewhere.
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 #ifdef SGIALTIX
2673 ! allocate space for the intermediate domain
2674 CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2, .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 mpi_comm_split( MPI_COMM_WORLD, 2 , 1 , mpi_comm_local, ierr )
2960 CALL wrf_set_dm_communicator ( mpi_comm_local )
2961 ENDIF
2962 CALL wrf_get_dm_communicator( mpi_comm_local )
2963 CALL wrf_termio_dup
2964 #endif
2965 CALL rsl_initialize1( mpi_comm_local )
2966 CALL set_def_decomp_fcn ( rsl_patch_decomp )
2967 END SUBROUTINE init_module_dm
2968
2969 ! internal, used below for switching the argument to MPI calls
2970 ! if reals are being autopromoted to doubles in the build of WRF
2971 INTEGER function getrealmpitype()
2972 #ifndef STUBMPI
2973 IMPLICIT NONE
2974 INCLUDE 'mpif.h'
2975 INTEGER rtypesize, dtypesize, ierr
2976 CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
2977 CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
2978 IF ( RWORDSIZE .EQ. rtypesize ) THEN
2979 getrealmpitype = MPI_REAL
2980 ELSE IF ( RWORDSIZE .EQ. dtypesize ) THEN
2981 getrealmpitype = MPI_DOUBLE_PRECISION
2982 ELSE
2983 CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' )
2984 ENDIF
2985 #else
2986 ! required dummy initialization for function that is never called
2987 getrealmpitype = 1
2988 #endif
2989 RETURN
2990 END FUNCTION getrealmpitype
2991
2992 REAL FUNCTION wrf_dm_max_real ( inval )
2993 IMPLICIT NONE
2994 REAL inval, retval
2995 INTEGER ierr
2996 ! <DESCRIPTION>
2997 ! Collective operation. Each processor calls passing a local value; on return
2998 ! all processors are passed back the maximum of all values passed.
2999 !
3000 ! </DESCRIPTION>
3001 #ifndef STUBMPI
3002 INCLUDE 'mpif.h'
3003 CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_MAX, mpi_comm_local, ierr )
3004 wrf_dm_max_real = retval
3005 #else
3006 wrf_dm_max_real = inval
3007 #endif
3008 END FUNCTION wrf_dm_max_real
3009
3010 REAL FUNCTION wrf_dm_min_real ( inval )
3011 IMPLICIT NONE
3012 REAL inval, retval
3013 INTEGER typesize, op
3014 INTEGER ierr
3015 ! <DESCRIPTION>
3016 ! Collective operation. Each processor calls passing a local value; on return
3017 ! all processors are passed back the minumum of all values passed.
3018 !
3019 ! </DESCRIPTION>
3020 #ifndef STUBMPI
3021 INCLUDE 'mpif.h'
3022 CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_MIN, mpi_comm_local, ierr )
3023 wrf_dm_min_real = retval
3024 #else
3025 wrf_dm_min_real = inval
3026 #endif
3027 END FUNCTION wrf_dm_min_real
3028
3029 REAL FUNCTION wrf_dm_sum_real ( inval )
3030 IMPLICIT NONE
3031 INTEGER ierr
3032 INTEGER typesize, op
3033 REAL inval, retval
3034 ! <DESCRIPTION>
3035 ! Collective operation. Each processor calls passing a local value; on return
3036 ! all processors are passed back the sum of all values passed.
3037 !
3038 ! </DESCRIPTION>
3039 #ifndef STUBMPI
3040 INCLUDE 'mpif.h'
3041 CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_SUM, mpi_comm_local, ierr )
3042 wrf_dm_sum_real = retval
3043 #else
3044 wrf_dm_sum_real = inval
3045 #endif
3046 END FUNCTION wrf_dm_sum_real
3047
3048 SUBROUTINE wrf_dm_sum_reals ( inval, retval )
3049 IMPLICIT NONE
3050 INTEGER ierr
3051 REAL, INTENT(IN ) :: inval(:)
3052 REAL, INTENT( OUT) :: retval(:)
3053 ! <DESCRIPTION>
3054 ! Array version.
3055 ! Collective operation. Each processor calls passing a local value; on return
3056 ! all processors are passed back the sum of all values passed.
3057 !
3058 ! </DESCRIPTION>
3059 #ifndef STUBMPI
3060 INCLUDE 'mpif.h'
3061 CALL mpi_allreduce ( inval, retval , SIZE(inval), getrealmpitype() , MPI_SUM, mpi_comm_local, ierr )
3062 #else
3063 retval = inval
3064 #endif
3065 END SUBROUTINE wrf_dm_sum_reals
3066
3067 INTEGER FUNCTION wrf_dm_sum_integer ( inval )
3068 IMPLICIT NONE
3069 INTEGER inval, retval, ierr
3070 ! <DESCRIPTION>
3071 ! Collective operation. Each processor calls passing a local value; on return
3072 ! all processors are passed back the sum of all values passed.
3073 !
3074 ! </DESCRIPTION>
3075 #ifndef STUBMPI
3076 INCLUDE 'mpif.h'
3077 CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, mpi_comm_local, ierr )
3078 wrf_dm_sum_integer = retval
3079 #else
3080 wrf_dm_sum_integer = inval
3081 #endif
3082 END FUNCTION wrf_dm_sum_integer
3083
3084 SUBROUTINE wrf_dm_sum_integers ( inval, retval )
3085 IMPLICIT NONE
3086 INTEGER ierr
3087 INTEGER, INTENT(IN ) :: inval(:)
3088 INTEGER, INTENT( OUT) :: retval(:)
3089 ! <DESCRIPTION>
3090 ! Array version.
3091 ! Collective operation. Each processor calls passing a local value; on return
3092 ! all processors are passed back the sum of all values passed.
3093 !
3094 ! </DESCRIPTION>
3095 #ifndef STUBMPI
3096 INCLUDE 'mpif.h'
3097 CALL mpi_allreduce ( inval, retval , SIZE(inval), MPI_INTEGER, MPI_SUM, mpi_comm_local, ierr )
3098 #else
3099 retval = inval
3100 #endif
3101 END SUBROUTINE wrf_dm_sum_integers
3102
3103
3104 SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
3105 IMPLICIT NONE
3106 REAL val, val_all( rsl_nproc )
3107 INTEGER idex, jdex, ierr
3108 INTEGER dex(2)
3109 INTEGER dex_all (2,rsl_nproc)
3110 ! <DESCRIPTION>
3111 ! Collective operation. Each processor calls passing a local value and its index; on return
3112 ! all processors are passed back the maximum of all values passed and its index.
3113 !
3114 ! </DESCRIPTION>
3115 INTEGER i, comm
3116 #ifndef STUBMPI
3117 INCLUDE 'mpif.h'
3118
3119 CALL wrf_get_dm_communicator ( comm )
3120 dex(1) = idex ; dex(2) = jdex
3121 CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3122 CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
3123 val = val_all(1)
3124 idex = dex_all(1,1) ; jdex = dex_all(2,1)
3125 DO i = 2, rsl_nproc
3126 IF ( val_all(i) .GT. val ) THEN
3127 val = val_all(i)
3128 idex = dex_all(1,i)
3129 jdex = dex_all(2,i)
3130 ENDIF
3131 ENDDO
3132 #endif
3133 END SUBROUTINE wrf_dm_maxval_real
3134
3135 SUBROUTINE wrf_dm_minval_real ( val, idex, jdex )
3136 IMPLICIT NONE
3137 REAL val, val_all( rsl_nproc )
3138 INTEGER idex, jdex, ierr
3139 INTEGER dex(2)
3140 INTEGER dex_all (2,rsl_nproc)
3141 ! <DESCRIPTION>
3142 ! Collective operation. Each processor calls passing a local value and its index; on return
3143 ! all processors are passed back the minimum of all values passed and its index.
3144 !
3145 ! </DESCRIPTION>
3146 INTEGER i, comm
3147 #ifndef STUBMPI
3148 INCLUDE 'mpif.h'
3149
3150 CALL wrf_get_dm_communicator ( comm )
3151 dex(1) = idex ; dex(2) = jdex
3152 CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3153 CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
3154 val = val_all(1)
3155 idex = dex_all(1,1) ; jdex = dex_all(2,1)
3156 DO i = 2, rsl_nproc
3157 IF ( val_all(i) .LT. val ) THEN
3158 val = val_all(i)
3159 idex = dex_all(1,i)
3160 jdex = dex_all(2,i)
3161 ENDIF
3162 ENDDO
3163 #endif
3164 END SUBROUTINE wrf_dm_minval_real
3165
3166 SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
3167 IMPLICIT NONE
3168 DOUBLE PRECISION val, val_all( rsl_nproc )
3169 INTEGER idex, jdex, ierr
3170 INTEGER dex(2)
3171 INTEGER dex_all (2,rsl_nproc)
3172 ! <DESCRIPTION>
3173 ! Collective operation. Each processor calls passing a local value and its index; on return
3174 ! all processors are passed back the maximum of all values passed and its index.
3175 !
3176 ! </DESCRIPTION>
3177 INTEGER i, comm
3178 #ifndef STUBMPI
3179 INCLUDE 'mpif.h'
3180
3181 CALL wrf_get_dm_communicator ( comm )
3182 dex(1) = idex ; dex(2) = jdex
3183 CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3184 CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
3185 val = val_all(1)
3186 idex = dex_all(1,1) ; jdex = dex_all(2,1)
3187 DO i = 2, rsl_nproc
3188 IF ( val_all(i) .GT. val ) THEN
3189 val = val_all(i)
3190 idex = dex_all(1,i)
3191 jdex = dex_all(2,i)
3192 ENDIF
3193 ENDDO
3194 #endif
3195 END SUBROUTINE wrf_dm_maxval_doubleprecision
3196
3197 SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex )
3198 IMPLICIT NONE
3199 DOUBLE PRECISION val, val_all( rsl_nproc )
3200 INTEGER idex, jdex, ierr
3201 INTEGER dex(2)
3202 INTEGER dex_all (2,rsl_nproc)
3203 ! <DESCRIPTION>
3204 ! Collective operation. Each processor calls passing a local value and its index; on return
3205 ! all processors are passed back the minimum of all values passed and its index.
3206 !
3207 ! </DESCRIPTION>
3208 INTEGER i, comm
3209 #ifndef STUBMPI
3210 INCLUDE 'mpif.h'
3211
3212 CALL wrf_get_dm_communicator ( comm )
3213 dex(1) = idex ; dex(2) = jdex
3214 CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3215 CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
3216 val = val_all(1)
3217 idex = dex_all(1,1) ; jdex = dex_all(2,1)
3218 DO i = 2, rsl_nproc
3219 IF ( val_all(i) .LT. val ) THEN
3220 val = val_all(i)
3221 idex = dex_all(1,i)
3222 jdex = dex_all(2,i)
3223 ENDIF
3224 ENDDO
3225 #endif
3226 END SUBROUTINE wrf_dm_minval_doubleprecision
3227
3228
3229 SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
3230 IMPLICIT NONE
3231 INTEGER val, val_all( rsl_nproc )
3232 INTEGER idex, jdex, ierr
3233 INTEGER dex(2)
3234 INTEGER dex_all (2,rsl_nproc)
3235 ! <DESCRIPTION>
3236 ! Collective operation. Each processor calls passing a local value and its index; on return
3237 ! all processors are passed back the maximum of all values passed and its index.
3238 !
3239 ! </DESCRIPTION>
3240 INTEGER i, comm
3241 #ifndef STUBMPI
3242 INCLUDE 'mpif.h'
3243
3244 CALL wrf_get_dm_communicator ( comm )
3245 dex(1) = idex ; dex(2) = jdex
3246 CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3247 CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
3248 val = val_all(1)
3249 idex = dex_all(1,1) ; jdex = dex_all(2,1)
3250 DO i = 2, rsl_nproc
3251 IF ( val_all(i) .GT. val ) THEN
3252 val = val_all(i)
3253 idex = dex_all(1,i)
3254 jdex = dex_all(2,i)
3255 ENDIF
3256 ENDDO
3257 #endif
3258 END SUBROUTINE wrf_dm_maxval_integer
3259
3260 SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex )
3261 IMPLICIT NONE
3262 INTEGER val, val_all( rsl_nproc )
3263 INTEGER idex, jdex, ierr
3264 INTEGER dex(2)
3265 INTEGER dex_all (2,rsl_nproc)
3266 ! <DESCRIPTION>
3267 ! Collective operation. Each processor calls passing a local value and its index; on return
3268 ! all processors are passed back the minimum of all values passed and its index.
3269 !
3270 ! </DESCRIPTION>
3271 INTEGER i, comm
3272 #ifndef STUBMPI
3273 INCLUDE 'mpif.h'
3274
3275 CALL wrf_get_dm_communicator ( comm )
3276 dex(1) = idex ; dex(2) = jdex
3277 CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
3278 CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
3279 val = val_all(1)
3280 idex = dex_all(1,1) ; jdex = dex_all(2,1)
3281 DO i = 2, rsl_nproc
3282 IF ( val_all(i) .LT. val ) THEN
3283 val = val_all(i)
3284 idex = dex_all(1,i)
3285 jdex = dex_all(2,i)
3286 ENDIF
3287 ENDDO
3288 #endif
3289 END SUBROUTINE wrf_dm_minval_integer
3290
3291 SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
3292 USE module_domain
3293 TYPE (domain),INTENT(INOUT) :: parent, nest
3294 INTEGER, INTENT(IN) :: dx, dy
3295 CALL rsl_move_nest ( parent%domdesc, nest%domdesc, dx, dy )
3296 END SUBROUTINE wrf_dm_move_nest
3297
3298 !------------------------------------------------------------------------------
3299 SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, &
3300 mp_local_uobmask, &
3301 mp_local_vobmask, &
3302 mp_local_cobmask, errf )
3303
3304 !------------------------------------------------------------------------------
3305 ! PURPOSE: Do MPI allgatherv operation across processors to get the
3306 ! errors at each observation point on all processors.
3307 !
3308 !------------------------------------------------------------------------------
3309 #ifndef STUBMPI
3310 INCLUDE 'mpif.h'
3311
3312 INTEGER, INTENT(IN) :: nsta ! Observation index.
3313 INTEGER, INTENT(IN) :: nerrf ! Number of error fields.
3314 INTEGER, INTENT(IN) :: niobf ! Number of observations.
3315 LOGICAL, INTENT(IN) :: MP_LOCAL_UOBMASK(NIOBF)
3316 LOGICAL, INTENT(IN) :: MP_LOCAL_VOBMASK(NIOBF)
3317 LOGICAL, INTENT(IN) :: MP_LOCAL_COBMASK(NIOBF)
3318 REAL, INTENT(INOUT) :: errf(nerrf, niobf)
3319
3320 ! Local declarations
3321 integer i, n, nlocal_dot, nlocal_crs
3322 REAL UVT_BUFFER(NIOBF) ! Buffer for holding U, V, or T
3323 REAL QRK_BUFFER(NIOBF) ! Buffer for holding Q or RKO
3324 REAL SFP_BUFFER(NIOBF) ! Buffer for holding Surface pressure
3325 INTEGER N_BUFFER(NIOBF)
3326 REAL FULL_BUFFER(NIOBF)
3327 INTEGER IFULL_BUFFER(NIOBF)
3328 INTEGER IDISPLACEMENT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
3329 INTEGER ICOUNT(1024) ! HARD CODED MAX NUMBER OF PROCESSORS
3330
3331 INTEGER :: MPI_COMM_COMP ! MPI group communicator
3332 INTEGER :: NPROCS ! Number of processors
3333 INTEGER :: IERR ! Error code from MPI routines
3334
3335 ! Get communicator for MPI operations.
3336 CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
3337
3338 ! Get rank of monitor processor and broadcast to others.
3339 CALL MPI_COMM_SIZE( MPI_COMM_COMP, NPROCS, IERR )
3340
3341 ! DO THE U FIELD
3342 NLOCAL_DOT = 0
3343 DO N = 1, NSTA
3344 IF ( MP_LOCAL_UOBMASK(N) ) THEN ! USE U-POINT MASK
3345 NLOCAL_DOT = NLOCAL_DOT + 1
3346 UVT_BUFFER(NLOCAL_DOT) = ERRF(1,N) ! U WIND COMPONENT
3347 SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N) ! SURFACE PRESSURE
3348 QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N) ! RKO
3349 N_BUFFER(NLOCAL_DOT) = N
3350 ENDIF
3351 ENDDO
3352 CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
3353 ICOUNT,1,MPI_INTEGER, &
3354 MPI_COMM_COMP,IERR)
3355 I = 1
3356
3357 IDISPLACEMENT(1) = 0
3358 DO I = 2, NPROCS
3359 IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
3360 ENDDO
3361 CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
3362 IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3363 MPI_INTEGER, MPI_COMM_COMP, IERR)
3364 ! U
3365 CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
3366 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3367 MPI_REAL, MPI_COMM_COMP, IERR)
3368 DO N = 1, NSTA
3369 ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3370 ENDDO
3371 ! SURF PRESS AT U-POINTS
3372 CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
3373 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3374 MPI_REAL, MPI_COMM_COMP, IERR)
3375 DO N = 1, NSTA
3376 ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3377 ENDDO
3378 ! RKO
3379 CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL, &
3380 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3381 MPI_REAL, MPI_COMM_COMP, IERR)
3382 DO N = 1, NSTA
3383 ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3384 ENDDO
3385
3386 ! DO THE V FIELD
3387 NLOCAL_DOT = 0
3388 DO N = 1, NSTA
3389 IF ( MP_LOCAL_VOBMASK(N) ) THEN ! USE V-POINT MASK
3390 NLOCAL_DOT = NLOCAL_DOT + 1
3391 UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N) ! V WIND COMPONENT
3392 SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N) ! SURFACE PRESSURE
3393 N_BUFFER(NLOCAL_DOT) = N
3394 ENDIF
3395 ENDDO
3396 CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
3397 ICOUNT,1,MPI_INTEGER, &
3398 MPI_COMM_COMP,IERR)
3399 I = 1
3400
3401 IDISPLACEMENT(1) = 0
3402 DO I = 2, NPROCS
3403 IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
3404 ENDDO
3405 CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, &
3406 IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3407 MPI_INTEGER, MPI_COMM_COMP, IERR)
3408 ! V
3409 CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL, &
3410 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3411 MPI_REAL, MPI_COMM_COMP, IERR)
3412 DO N = 1, NSTA
3413 ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3414 ENDDO
3415 ! SURF PRESS AT V-POINTS
3416 CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, &
3417 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3418 MPI_REAL, MPI_COMM_COMP, IERR)
3419 DO N = 1, NSTA
3420 ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3421 ENDDO
3422
3423 ! DO THE CROSS FIELDS, T AND Q
3424 NLOCAL_CRS = 0
3425 DO N = 1, NSTA
3426 IF ( MP_LOCAL_COBMASK(N) ) THEN ! USE MASS-POINT MASK
3427 NLOCAL_CRS = NLOCAL_CRS + 1
3428 UVT_BUFFER(NLOCAL_CRS) = ERRF(3,N) ! TEMPERATURE
3429 QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N) ! MOISTURE
3430 SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N) ! SURFACE PRESSURE
3431 N_BUFFER(NLOCAL_CRS) = N
3432 ENDIF
3433 ENDDO
3434 CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, &
3435 ICOUNT,1,MPI_INTEGER, &
3436 MPI_COMM_COMP,IERR)
3437 IDISPLACEMENT(1) = 0
3438 DO I = 2, NPROCS
3439 IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
3440 ENDDO
3441 CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER, &
3442 IFULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3443 MPI_INTEGER, MPI_COMM_COMP, IERR)
3444 ! T
3445 CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_CRS, MPI_REAL, &
3446 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3447 MPI_REAL, MPI_COMM_COMP, IERR)
3448
3449 DO N = 1, NSTA
3450 ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3451 ENDDO
3452 ! Q
3453 CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL, &
3454 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3455 MPI_REAL, MPI_COMM_COMP, IERR)
3456 DO N = 1, NSTA
3457 ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3458 ENDDO
3459 ! SURF PRESS AT MASS POINTS
3460 CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL, &
3461 FULL_BUFFER, ICOUNT, IDISPLACEMENT, &
3462 MPI_REAL, MPI_COMM_COMP, IERR)
3463 DO N = 1, NSTA
3464 ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
3465 ENDDO
3466 #endif
3467 END SUBROUTINE get_full_obs_vector
3468
3469 END MODULE module_dm
3470
3471 !=========================================================================
3472 ! wrf_dm_patch_domain has to be outside the module because it is called
3473 ! by a routine in module_domain but depends on module domain
3474
3475
3476 SUBROUTINE wrf_dm_patch_domain ( id , domdesc , parent_id , parent_domdesc , &
3477 sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
3478 sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
3479 sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
3480 sp1x , ep1x , sm1x , em1x , &
3481 sp2x , ep2x , sm2x , em2x , &
3482 sp3x , ep3x , sm3x , em3x , &
3483 sp1y , ep1y , sm1y , em1y , &
3484 sp2y , ep2y , sm2y , em2y , &
3485 sp3y , ep3y , sm3y , em3y , &
3486 bdx , bdy )
3487 USE module_domain
3488 USE module_dm
3489 IMPLICIT NONE
3490
3491 INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
3492 INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
3493 sm1 , em1 , sm2 , em2 , sm3 , em3
3494 INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
3495 sm1x , em1x , sm2x , em2x , sm3x , em3x
3496 INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
3497 sm1y , em1y , sm2y , em2y , sm3y , em3y
3498 INTEGER, INTENT(INOUT):: id , domdesc , parent_id , parent_domdesc
3499
3500 TYPE(domain), POINTER :: parent, grid_ptr
3501
3502 ! <DESCRIPTION>
3503 ! The rsl-package supplied routine that computes the patch and memory dimensions
3504 ! for this task. See also <a href=patch_domain_rsl.html>patch_domain_rsl</a>
3505 !
3506 ! </DESCRIPTION>
3507
3508 ! this is necessary because we cannot pass parent directly into
3509 ! wrf_dm_patch_domain because creating the correct interface definitions
3510 ! would generate a circular USE reference between module_domain and module_dm
3511 ! see comment this date in module_domain for more information. JM 20020416
3512
3513 NULLIFY( parent )
3514 grid_ptr => head_grid
3515 CALL find_grid_by_id( parent_id , grid_ptr , parent )
3516
3517 CALL patch_domain_rsl ( id , domdesc , parent, parent_id , parent_domdesc , &
3518 sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
3519 sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
3520 sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
3521 sp1x , ep1x , sm1x , em1x , &
3522 sp2x , ep2x , sm2x , em2x , &
3523 sp3x , ep3x , sm3x , em3x , &
3524 sp1y , ep1y , sm1y , em1y , &
3525 sp2y , ep2y , sm2y , em2y , &
3526 sp3y , ep3y , sm3y , em3y , &
3527 bdx , bdy )
3528
3529
3530 RETURN
3531 END SUBROUTINE wrf_dm_patch_domain
3532
3533 SUBROUTINE wrf_termio_dup
3534 IMPLICIT NONE
3535 INTEGER mytask, ntasks, ierr
3536 ! <DESCRIPTION>
3537 ! Redirect standard output and standard error to separate files for each processor.
3538 !
3539 ! </DESCRIPTION>
3540 #ifndef STUBMPI
3541 INCLUDE 'mpif.h'
3542 CALL mpi_comm_size(MPI_COMM_WORLD, ntasks, ierr )
3543 CALL mpi_comm_rank(MPI_COMM_WORLD, mytask, ierr )
3544 #else
3545 ntasks = 1
3546 mytask = 0
3547 #endif
3548 write(0,*)'starting wrf task ',mytask,' of ',ntasks
3549 CALL rsl_error_dup1( mytask )
3550 END SUBROUTINE wrf_termio_dup
3551
3552 SUBROUTINE wrf_get_myproc( myproc )
3553 IMPLICIT NONE
3554 ! <DESCRIPTION>
3555 ! Pass back the task number (usually MPI rank) on this process.
3556 !
3557 ! </DESCRIPTION>
3558 # include "rsl.inc"
3559 INTEGER myproc
3560 myproc = rsl_myproc
3561 RETURN
3562 END SUBROUTINE wrf_get_myproc
3563
3564 SUBROUTINE wrf_get_nproc( nproc )
3565 IMPLICIT NONE
3566 # include "rsl.inc"
3567 INTEGER nproc
3568 ! <DESCRIPTION>
3569 ! Pass back the number of distributed-memory tasks.
3570 !
3571 ! </DESCRIPTION>
3572 nproc = rsl_nproc_all
3573 RETURN
3574 END SUBROUTINE wrf_get_nproc
3575
3576 SUBROUTINE wrf_get_nprocx( nprocx )
3577 IMPLICIT NONE
3578 # include "rsl.inc"
3579 INTEGER nprocx
3580 ! <DESCRIPTION>
3581 ! Pass back the number of distributed-memory tasks decomposing the X dimension of the domain.
3582 !
3583 ! </DESCRIPTION>
3584 nprocx = rsl_nproc_min
3585 RETURN
3586 END SUBROUTINE wrf_get_nprocx
3587
3588 SUBROUTINE wrf_get_nprocy( nprocy )
3589 IMPLICIT NONE
3590 # include "rsl.inc"
3591 INTEGER nprocy
3592 ! <DESCRIPTION>
3593 ! Pass back the number of distributed-memory tasks decomposing the Y dimension of the domain.
3594 !
3595 ! </DESCRIPTION>
3596 nprocy = rsl_nproc_maj
3597 RETURN
3598 END SUBROUTINE wrf_get_nprocy
3599
3600 SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
3601 USE module_dm
3602 IMPLICIT NONE
3603 INTEGER size
3604 #ifndef NEC
3605 INTEGER*1 BUF(size)
3606 #else
3607 CHARACTER*1 BUF(size)
3608 #endif
3609 ! <DESCRIPTION>
3610 ! Collective operation. Given a buffer and a size in bytes on task zero, broadcast and return that buffer on all tasks.
3611 !
3612 ! </DESCRIPTION>
3613 CALL rsl_mon_bcast( buf , size )
3614 RETURN
3615 END SUBROUTINE wrf_dm_bcast_bytes
3616
3617 SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
3618 IMPLICIT NONE
3619 INTEGER n1
3620 ! <DESCRIPTION>
3621 ! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
3622 !
3623 ! </DESCRIPTION>
3624 CHARACTER*(*) buf
3625 INTEGER ibuf(256),i,n
3626 CHARACTER*256 tstr
3627 n = n1
3628 ! Root task is required to have the correct value of N1, other tasks
3629 ! might not have the correct value.
3630 CALL wrf_dm_bcast_integer( n , 1 )
3631 IF (n .GT. 256) n = 256
3632 IF (n .GT. 0 ) then
3633 DO i = 1, n
3634 ibuf(I) = ichar(buf(I:I))
3635 ENDDO
3636 CALL wrf_dm_bcast_integer( ibuf, n )
3637 buf = ''
3638 DO i = 1, n
3639 buf(i:i) = char(ibuf(i))
3640 ENDDO
3641 ENDIF
3642 RETURN
3643 END SUBROUTINE wrf_dm_bcast_string
3644
3645 SUBROUTINE wrf_dm_bcast_integer( BUF, N1 )
3646 IMPLICIT NONE
3647 INTEGER n1
3648 INTEGER buf(*)
3649 ! <DESCRIPTION>
3650 ! Collective operation. Given an array of integers and length on task zero, broadcast and return that array of values on all tasks.
3651 !
3652 ! </DESCRIPTION>
3653 CALL rsl_mon_bcast( BUF , N1 * IWORDSIZE )
3654 RETURN
3655 END SUBROUTINE wrf_dm_bcast_integer
3656
3657 SUBROUTINE wrf_dm_bcast_double( BUF, N1 )
3658 IMPLICIT NONE
3659 INTEGER n1
3660 ! <DESCRIPTION>
3661 ! Collective operation. Given an array of doubles and length on task zero, broadcast and return that array of values on all tasks.
3662 !
3663 ! </DESCRIPTION>
3664 DOUBLEPRECISION buf(*)
3665 CALL rsl_mon_bcast( BUF , N1 * DWORDSIZE )
3666 RETURN
3667 END SUBROUTINE wrf_dm_bcast_double
3668
3669 SUBROUTINE wrf_dm_bcast_real( BUF, N1 )
3670 IMPLICIT NONE
3671 INTEGER n1
3672 ! <DESCRIPTION>
3673 ! Collective operation. Given an array of reals and length on task zero, broadcast and return that array of values on all tasks.
3674 !
3675 ! </DESCRIPTION>
3676 REAL buf(*)
3677 CALL rsl_mon_bcast( BUF , N1 * RWORDSIZE )
3678 RETURN
3679 END SUBROUTINE wrf_dm_bcast_real
3680
3681 SUBROUTINE wrf_dm_bcast_logical( BUF, N1 )
3682 IMPLICIT NONE
3683 INTEGER n1
3684 ! <DESCRIPTION>
3685 ! Collective operation. Given an array of logicals and length on task zero, broadcast and return that array of values on all tasks.
3686 !
3687 ! </DESCRIPTION>
3688 LOGICAL buf(*)
3689 CALL rsl_mon_bcast( BUF , N1 * LWORDSIZE )
3690 RETURN
3691 END SUBROUTINE wrf_dm_bcast_logical
3692
3693 SUBROUTINE wrf_dm_halo ( domdesc , comms , stencil_id )
3694 USE module_dm
3695 IMPLICIT NONE
3696 INTEGER domdesc , comms(*) , stencil_id
3697 CALL rsl_exch_stencil ( domdesc , comms( stencil_id ) )
3698 RETURN
3699 END SUBROUTINE wrf_dm_halo
3700
3701 SUBROUTINE wrf_dm_xpose_z2y ( domdesc , comms , xpose_id )
3702 USE module_dm
3703 IMPLICIT NONE
3704 INTEGER domdesc , comms(*) , xpose_id
3705 CALL rsl_xpose_mn_mz ( domdesc , comms( xpose_id ) ) ! switched nz->mz 20020910
3706 RETURN
3707 END SUBROUTINE wrf_dm_xpose_z2y
3708
3709 SUBROUTINE wrf_dm_xpose_y2z ( domdesc , comms , xpose_id )
3710 USE module_dm
3711 IMPLICIT NONE
3712 INTEGER domdesc , comms(*) , xpose_id
3713 CALL rsl_xpose_mz_mn ( domdesc , comms( xpose_id ) ) ! switched nz->mz 20020910
3714 RETURN
3715 END SUBROUTINE wrf_dm_xpose_y2z
3716
3717 SUBROUTINE wrf_dm_xpose_y2x ( domdesc , comms , xpose_id )
3718 USE module_dm
3719 IMPLICIT NONE
3720 INTEGER domdesc , comms(*) , xpose_id
3721 CALL rsl_xpose_mz_nz ( domdesc , comms( xpose_id ) ) ! switched nz<->mz 20020910
3722 RETURN
3723 END SUBROUTINE wrf_dm_xpose_y2x
3724
3725 SUBROUTINE wrf_dm_xpose_x2y ( domdesc , comms , xpose_id )
3726 USE module_dm
3727 IMPLICIT NONE
3728 INTEGER domdesc , comms(*) , xpose_id
3729 CALL rsl_xpose_nz_mz ( domdesc , comms( xpose_id ) ) ! switched nz<->mz 20020910
3730 RETURN
3731 END SUBROUTINE wrf_dm_xpose_x2y
3732
3733 SUBROUTINE wrf_dm_xpose_x2z ( domdesc , comms , xpose_id )
3734 USE module_dm
3735 IMPLICIT NONE
3736 INTEGER domdesc , comms(*) , xpose_id
3737 CALL rsl_xpose_nz_mn ( domdesc , comms( xpose_id ) ) ! switched mz->nz 20020910
3738 RETURN
3739 END SUBROUTINE wrf_dm_xpose_x2z
3740
3741 SUBROUTINE wrf_dm_xpose_z2x ( domdesc , comms , xpose_id )
3742 USE module_dm
3743 IMPLICIT NONE
3744 INTEGER domdesc , comms(*) , xpose_id
3745 CALL rsl_xpose_mn_nz ( domdesc , comms( xpose_id ) ) ! switched mz->nz 20020910
3746 RETURN
3747 END SUBROUTINE wrf_dm_xpose_z2x
3748
3749 #if 0
3750 SUBROUTINE wrf_dm_boundary ( domdesc , comms , period_id , &
3751 periodic_x , periodic_y )
3752 USE module_dm
3753 IMPLICIT NONE
3754 INTEGER domdesc , comms(*) , period_id
3755 LOGICAL , INTENT(IN) :: periodic_x, periodic_y
3756 # include "rsl.inc"
3757
3758 IF ( periodic_x ) THEN
3759 CALL rsl_exch_period ( domdesc , comms( period_id ) , RSL_M )
3760 END IF
3761 IF ( periodic_y ) THEN
3762 CALL rsl_exch_period ( domdesc , comms( period_id ) , RSL_N )
3763 END IF
3764 RETURN
3765 END SUBROUTINE wrf_dm_boundary
3766 #endif
3767
3768 SUBROUTINE wrf_dm_define_comms ( grid )
3769 USE module_domain
3770 USE module_dm
3771 IMPLICIT NONE
3772 TYPE(domain) , INTENT (INOUT) :: grid
3773 INTEGER dyn_opt
3774 INTEGER idum1, idum2, icomm
3775
3776 #ifdef DEREF_KLUDGE
3777 ! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3778 INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33
3779 INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3780 INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3781 #endif
3782
3783 #include "deref_kludge.h"
3784
3785 CALL nl_get_dyn_opt( 1, dyn_opt )
3786
3787 CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
3788
3789 ! rsl interface has been restructured so there is no longer a
3790 ! need to call a dyncore specific define_comms routine here.
3791 ! Removed 6/2001. JM
3792
3793 DO icomm = 1, max_comms
3794 grid%comms(icomm) = invalid_message_value
3795 ENDDO
3796 grid%shift_x = invalid_message_value
3797 grid%shift_y = invalid_message_value
3798
3799 RETURN
3800 END SUBROUTINE wrf_dm_define_comms
3801
3802 SUBROUTINE write_68( grid, v , s , &
3803 ids, ide, jds, jde, kds, kde, &
3804 ims, ime, jms, jme, kms, kme, &
3805 its, ite, jts, jte, kts, kte )
3806 USE module_domain
3807 IMPLICIT NONE
3808 TYPE(domain) , INTENT (INOUT) :: grid
3809 CHARACTER *(*) s
3810 INTEGER ids, ide, jds, jde, kds, kde, &
3811 ims, ime, jms, jme, kms, kme, &
3812 its, ite, jts, jte, kts, kte
3813 REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) :: v
3814 # include "rsl.inc"
3815
3816 INTEGER i,j,k
3817
3818 logical, external :: wrf_dm_on_monitor
3819 real globbuf( ids:ide, kds:kde, jds:jde )
3820 character*3 ord, stag
3821
3822 if ( kds == kde ) then
3823 ord = 'xy'
3824 stag = 'xy'
3825 CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
3826 ids, ide, jds, jde, kds, kde, &
3827 ims, ime, jms, jme, kms, kme, &
3828 its, ite, jts, jte, kts, kte )
3829 else
3830
3831 stag = 'xyz'
3832 ord = 'xzy'
3833 CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
3834 ids, ide, kds, kde, jds, jde, &
3835 ims, ime, kms, kme, jms, jme, &
3836 its, ite, kts, kte, jts, jte )
3837 endif
3838
3839
3840 if ( wrf_dm_on_monitor() ) THEN
3841 WRITE(68,*) ide-ids+1, jde-jds+1 , s
3842 DO j = jds, jde
3843 DO i = ids, ide
3844 WRITE(68,*) globbuf(i,1,j)
3845 ENDDO
3846 ENDDO
3847 endif
3848
3849 RETURN
3850 END
3851
3852 SUBROUTINE wrf_abort
3853 ! <DESCRIPTION>
3854 ! Kill the run. Calls MPI_ABORT.
3855 !
3856 ! </DESCRIPTION>
3857 #ifndef STUBMPI
3858 INCLUDE 'mpif.h'
3859 CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
3860 #else
3861 STOP
3862 #endif
3863 END SUBROUTINE wrf_abort
3864
3865 SUBROUTINE wrf_dm_shutdown
3866 # include "rsl.inc"
3867 ! <DESCRIPTION>
3868 ! Shutdown (gracefully) the underlying comm layer.
3869 !
3870 ! </DESCRIPTION>
3871 CALL RSL_SHUTDOWN
3872 RETURN
3873 END SUBROUTINE wrf_dm_shutdown
3874
3875 LOGICAL FUNCTION wrf_dm_on_monitor()
3876 LOGICAL rsl_iammonitor
3877 EXTERNAL rsl_iammonitor
3878 ! <DESCRIPTION>
3879 ! Return true on task zero, false otherwise.
3880 !
3881 ! </DESCRIPTION>
3882 wrf_dm_on_monitor = rsl_iammonitor()
3883 RETURN
3884 END FUNCTION wrf_dm_on_monitor
3885
3886 INTEGER FUNCTION wrf_dm_monitor_rank()
3887 USE module_dm
3888 IMPLICIT NONE
3889 INTEGER retval
3890 CALL rsl_monitor_proc( retval )
3891 wrf_dm_monitor_rank = retval
3892 RETURN
3893 END FUNCTION wrf_dm_monitor_rank
3894
3895 SUBROUTINE wrf_get_dm_communicator ( communicator )
3896 IMPLICIT NONE
3897 INTEGER , INTENT(OUT) :: communicator
3898 ! <DESCRIPTION>
3899 ! Return the communicator the underlying comm layer is using.
3900 !
3901 ! </DESCRIPTION>
3902 CALL rsl_get_communicator ( communicator )
3903 RETURN
3904 END SUBROUTINE wrf_get_dm_communicator
3905
3906 SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
3907 IMPLICIT NONE
3908 INTEGER , INTENT(OUT) :: iocommunicator
3909 ! <DESCRIPTION>
3910 ! Return the io communicator the underlying comm layer is using. Not used.
3911 !
3912 ! </DESCRIPTION>
3913 CALL rsl_get_communicator ( iocommunicator ) ! same as regular communicator
3914 RETURN
3915 END SUBROUTINE wrf_get_dm_iocommunicator
3916
3917 SUBROUTINE wrf_set_dm_communicator ( communicator )
3918 IMPLICIT NONE
3919 INTEGER , INTENT(IN) :: communicator
3920 ! <DESCRIPTION>
3921 ! Set the communicator the underlying comm layer is to use.
3922 !
3923 ! </DESCRIPTION>
3924 CALL rsl_set_communicator ( communicator )
3925 RETURN
3926 END SUBROUTINE wrf_set_dm_communicator
3927
3928 SUBROUTINE wrf_set_dm_iocommunicator ( iocommunicator )
3929 IMPLICIT NONE
3930 INTEGER , INTENT(IN) :: iocommunicator
3931 ! <DESCRIPTION>
3932 ! Set the io communicator the underlying comm layer is to use. Not used.
3933 !
3934 ! </DESCRIPTION>
3935 ! CALL rsl_set_communicator ( iocommunicator ) ! same as regular communicator
3936 RETURN
3937 END SUBROUTINE wrf_set_dm_iocommunicator
3938
3939
3940 !!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3941
3942 SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,stagger,ordering,&
3943 DS1,DE1,DS2,DE2,DS3,DE3,&
3944 MS1,ME1,MS2,ME2,MS3,ME3,&
3945 PS1,PE1,PS2,PE2,PS3,PE3 )
3946 IMPLICIT NONE
3947 #include "rsl.inc"
3948 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
3949 MS1,ME1,MS2,ME2,MS3,ME3,&
3950 PS1,PE1,PS2,PE2,PS3,PE3
3951 CHARACTER *(*) stagger,ordering
3952 INTEGER fid,domdesc
3953 REAL globbuf(*)
3954 REAL buf(*)
3955 ! <DESCRIPTION>
3956 ! Collective operation. Given a buffer of type real corresponding to a 2- or 3-dimensional patch on a local processor,
3957 ! return on task zero the global array assembled from the pieces stored on each processor.
3958 !
3959 ! </DESCRIPTION>
3960
3961 CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,TRUE_RSL_REAL,&
3962 DS1,DE1,DS2,DE2,DS3,DE3,&
3963 MS1,ME1,MS2,ME2,MS3,ME3,&
3964 PS1,PE1,PS2,PE2,PS3,PE3 )
3965
3966 RETURN
3967 END SUBROUTINE wrf_patch_to_global_real
3968
3969 SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,stagger,ordering,&
3970 DS1,DE1,DS2,DE2,DS3,DE3,&
3971 MS1,ME1,MS2,ME2,MS3,ME3,&
3972 PS1,PE1,PS2,PE2,PS3,PE3 )
3973 IMPLICIT NONE
3974 #include "rsl.inc"
3975 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
3976 MS1,ME1,MS2,ME2,MS3,ME3,&
3977 PS1,PE1,PS2,PE2,PS3,PE3
3978 CHARACTER *(*) stagger,ordering
3979 INTEGER fid,domdesc
3980 DOUBLEPRECISION globbuf(*)
3981 DOUBLEPRECISION buf(*)
3982 ! <DESCRIPTION>
3983 ! Collective operation. Given a buffer of type double corresponding to a 2- or 3-dimensional patch on a local processor,
3984 ! return on task zero the global array assembled from the pieces stored on each processor.
3985 !
3986 ! </DESCRIPTION>
3987
3988 CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,RSL_DOUBLE,&
3989 DS1,DE1,DS2,DE2,DS3,DE3,&
3990 MS1,ME1,MS2,ME2,MS3,ME3,&
3991 PS1,PE1,PS2,PE2,PS3,PE3 )
3992
3993 RETURN
3994 END SUBROUTINE wrf_patch_to_global_double
3995
3996
3997 SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,stagger,ordering,&
3998 DS1,DE1,DS2,DE2,DS3,DE3,&
3999 MS1,ME1,MS2,ME2,MS3,ME3,&
4000 PS1,PE1,PS2,PE2,PS3,PE3 )
4001 IMPLICIT NONE
4002 #include "rsl.inc"
4003 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4004 MS1,ME1,MS2,ME2,MS3,ME3,&
4005 PS1,PE1,PS2,PE2,PS3,PE3
4006 CHARACTER *(*) stagger,ordering
4007 INTEGER fid,domdesc
4008 INTEGER globbuf(*)
4009 INTEGER buf(*)
4010 ! <DESCRIPTION>
4011 ! Collective operation. Given a buffer of type integer corresponding to a 2- or 3-dimensional patch on a local processor,
4012 ! return on task zero the global array assembled from the pieces stored on each processor.
4013 !
4014 ! </DESCRIPTION>
4015
4016 CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,rsl_integer,&
4017 DS1,DE1,DS2,DE2,DS3,DE3,&
4018 MS1,ME1,MS2,ME2,MS3,ME3,&
4019 PS1,PE1,PS2,PE2,PS3,PE3 )
4020
4021 RETURN
4022 END SUBROUTINE wrf_patch_to_global_integer
4023
4024 SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,stagger,ordering,&
4025 DS1,DE1,DS2,DE2,DS3,DE3,&
4026 MS1,ME1,MS2,ME2,MS3,ME3,&
4027 PS1,PE1,PS2,PE2,PS3,PE3 )
4028 IMPLICIT NONE
4029 #include "rsl.inc"
4030 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4031 MS1,ME1,MS2,ME2,MS3,ME3,&
4032 PS1,PE1,PS2,PE2,PS3,PE3
4033 CHARACTER *(*) stagger,ordering
4034 INTEGER fid,domdesc
4035 INTEGER globbuf(*)
4036 INTEGER buf(*)
4037 ! <DESCRIPTION>
4038 ! Collective operation. Given a buffer of type integer corresponding to a 2- or 3-dimensional patch on a local processor,
4039 ! return on task zero the global array assembled from the pieces stored on each processor.
4040 !
4041 ! </DESCRIPTION>
4042
4043 IF ( LWORDSIZE .NE. IWORDSIZE ) THEN
4044 CALL wrf_error_fatal( "module_dm: LWORDSIZE != IWORDSIZE on this machine. RSL cannot cast" )
4045 ENDIF
4046
4047 CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,rsl_integer,&
4048 DS1,DE1,DS2,DE2,DS3,DE3,&
4049 MS1,ME1,MS2,ME2,MS3,ME3,&
4050 PS1,PE1,PS2,PE2,PS3,PE3 )
4051
4052 RETURN
4053 END SUBROUTINE wrf_patch_to_global_logical
4054
4055 SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,type,&
4056 DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4057 MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4058 PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
4059 USE module_driver_constants
4060 USE module_timing
4061 USE module_wrf_error
4062 IMPLICIT NONE
4063 #include "rsl.inc"
4064 INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4065 MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4066 PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
4067 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4068 MS1,ME1,MS2,ME2,MS3,ME3,&
4069 PS1,PE1,PS2,PE2,PS3,PE3
4070 CHARACTER *(*) stagger,ordering
4071 INTEGER fid,domdesc,type
4072 REAL globbuf(*)
4073 REAL buf(*)
4074
4075 LOGICAL, EXTERNAL :: has_char
4076 INTEGER glen(3),llen(3),glen2d(3),llen2d(3)
4077 INTEGER i, j, k, ord, ord2d, ndim
4078 INTEGER mlen, nlen, zlen
4079
4080 DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
4081 MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
4082 PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
4083
4084 ndim = len(TRIM(ordering))
4085
4086 CALL rsl_get_glen( domdesc, glen(1), glen(2), glen(3) )
4087
4088 SELECT CASE ( TRIM(ordering) )
4089 CASE ( 'xyz','xy' )
4090 ord = io3d_ijk_internal ; ord2d = io2d_ij_internal
4091 ! the non-staggered variables come in at one-less than
4092 ! domain dimensions, but RSL wants full domain spec, so
4093 ! adjust if not staggered
4094 IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4095 IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
4096 IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4097 CASE ( 'yxz','yx' )
4098 ord = io3d_jik_internal ; ord2d = io2d_ji_internal
4099 IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4100 IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
4101 IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4102 CASE ( 'zxy' )
4103 IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4104 IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4105 IF ( .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
4106 ord = io3d_kij_internal ; ord2d = io2d_ij_internal
4107 #if 0
4108 CASE ( 'zyx' )
4109 ord = io3d_kji_internal ; ord2d = io2d_ji_internal
4110 CASE ( 'yzx' )
4111 ord = io3d_jki_internal ; ord2d = io2d_ji_internal
4112 #endif
4113 CASE ( 'xzy' )
4114 IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4115 IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4116 IF ( .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
4117 ord = io3d_ikj_internal ; ord2d = io2d_ij_internal
4118 CASE DEFAULT
4119 ord = -1 ; ord2d = -1
4120 END SELECT
4121
4122
4123 glen(1) = DE1-DS1+1 ; glen(2) = DE2-DS2+1 ; glen(3) = DE3-DS3+1
4124 llen(1) = ME1-MS1+1 ; llen(2) = ME2-MS2+1 ; llen(3) = ME3-MS3+1
4125 glen2d(1) = DE1-DS1+1 ; glen2d(2) = DE2-DS2+1
4126 llen2d(1) = ME1-MS1+1 ; llen2d(2) = ME2-MS2+1
4127
4128 IF ( wrf_at_debug_level(500) ) THEN
4129 CALL start_timing
4130 ENDIF
4131
4132 IF ( ndim .EQ. 3 ) THEN
4133 CALL rsl_write(globbuf,ord,buf,domdesc,type,glen,llen)
4134 ELSE
4135 CALL rsl_write(globbuf,ord2d,buf,domdesc,type,glen2d,llen2d)
4136 ENDIF
4137 IF ( wrf_at_debug_level(500) ) THEN
4138 CALL end_timing('wrf_patch_to_global_generic')
4139 ENDIF
4140 RETURN
4141 END SUBROUTINE wrf_patch_to_global_generic
4142
4143 !!!!!!!!!!!!!!!!!!!!!!! GLOBAL TO PATCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4144
4145 SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
4146 DS1,DE1,DS2,DE2,DS3,DE3,&
4147 MS1,ME1,MS2,ME2,MS3,ME3,&
4148 PS1,PE1,PS2,PE2,PS3,PE3 )
4149 IMPLICIT NONE
4150 #include "rsl.inc"
4151 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4152 MS1,ME1,MS2,ME2,MS3,ME3,&
4153 PS1,PE1,PS2,PE2,PS3,PE3
4154 CHARACTER *(*) stagger,ordering
4155 INTEGER fid,domdesc
4156 REAL globbuf(*)
4157 REAL buf(*)
4158 ! <DESCRIPTION>
4159 ! Collective operation. Given a global 2- or 3-dimensional array of type real on task zero,
4160 ! return the appropriate decomposed section (patch) on each processor.
4161 !
4162 ! </DESCRIPTION>
4163
4164 CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,TRUE_RSL_REAL,&
4165 DS1,DE1,DS2,DE2,DS3,DE3,&
4166 MS1,ME1,MS2,ME2,MS3,ME3,&
4167 PS1,PE1,PS2,PE2,PS3,PE3 )
4168 RETURN
4169 END SUBROUTINE wrf_global_to_patch_real
4170
4171 SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,stagger,ordering,&
4172 DS1,DE1,DS2,DE2,DS3,DE3,&
4173 MS1,ME1,MS2,ME2,MS3,ME3,&
4174 PS1,PE1,PS2,PE2,PS3,PE3 )
4175 IMPLICIT NONE
4176 #include "rsl.inc"
4177 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4178 MS1,ME1,MS2,ME2,MS3,ME3,&
4179 PS1,PE1,PS2,PE2,PS3,PE3
4180 CHARACTER *(*) stagger,ordering
4181 INTEGER fid,domdesc
4182 DOUBLEPRECISION globbuf(*)
4183 DOUBLEPRECISION buf(*)
4184 ! <DESCRIPTION>
4185 ! Collective operation. Given a global 2- or 3-dimensional array of type double on task zero,
4186 ! return the appropriate decomposed section (patch) on each processor.
4187 !
4188 ! </DESCRIPTION>
4189
4190 CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,RSL_DOUBLE,&
4191 DS1,DE1,DS2,DE2,DS3,DE3,&
4192 MS1,ME1,MS2,ME2,MS3,ME3,&
4193 PS1,PE1,PS2,PE2,PS3,PE3 )
4194 RETURN
4195 END SUBROUTINE wrf_global_to_patch_double
4196
4197
4198 SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,stagger,ordering,&
4199 DS1,DE1,DS2,DE2,DS3,DE3,&
4200 MS1,ME1,MS2,ME2,MS3,ME3,&
4201 PS1,PE1,PS2,PE2,PS3,PE3 )
4202 IMPLICIT NONE
4203 #include "rsl.inc"
4204 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4205 MS1,ME1,MS2,ME2,MS3,ME3,&
4206 PS1,PE1,PS2,PE2,PS3,PE3
4207 CHARACTER *(*) stagger,ordering
4208 INTEGER fid,domdesc
4209 INTEGER globbuf(*)
4210 INTEGER buf(*)
4211 ! <DESCRIPTION>
4212 ! Collective operation. Given a global 2- or 3-dimensional array of type integer on task zero,
4213 ! return the appropriate decomposed section (patch) on each processor.
4214 !
4215 ! </DESCRIPTION>
4216
4217 CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,rsl_integer,&
4218 DS1,DE1,DS2,DE2,DS3,DE3,&
4219 MS1,ME1,MS2,ME2,MS3,ME3,&
4220 PS1,PE1,PS2,PE2,PS3,PE3 )
4221 RETURN
4222 END SUBROUTINE wrf_global_to_patch_integer
4223
4224 SUBROUTINE wrf_global_to_patch_logical (globbuf,buf,domdesc,stagger,ordering,&
4225 DS1,DE1,DS2,DE2,DS3,DE3,&
4226 MS1,ME1,MS2,ME2,MS3,ME3,&
4227 PS1,PE1,PS2,PE2,PS3,PE3 )
4228 IMPLICIT NONE
4229 #include "rsl.inc"
4230 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4231 MS1,ME1,MS2,ME2,MS3,ME3,&
4232 PS1,PE1,PS2,PE2,PS3,PE3
4233 CHARACTER *(*) stagger,ordering
4234 INTEGER fid,domdesc
4235 LOGICAL globbuf(*)
4236 LOGICAL buf(*)
4237 ! <DESCRIPTION>
4238 ! Collective operation. Given a global 2- or 3-dimensional array of type integer on task zero,
4239 ! return the appropriate decomposed section (patch) on each processor.
4240 !
4241 ! </DESCRIPTION>
4242
4243 IF ( LWORDSIZE .NE. IWORDSIZE ) THEN
4244 CALL wrf_error_fatal( "RSL module_dm: LWORDSIZE != IWORDSIZE on this machine. RSL cannot cast" )
4245 ENDIF
4246
4247 CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,rsl_integer,&
4248 DS1,DE1,DS2,DE2,DS3,DE3,&
4249 MS1,ME1,MS2,ME2,MS3,ME3,&
4250 PS1,PE1,PS2,PE2,PS3,PE3 )
4251 RETURN
4252 END SUBROUTINE wrf_global_to_patch_logical
4253
4254 SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,type,&
4255 DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4256 MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4257 PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
4258 USE module_driver_constants
4259 IMPLICIT NONE
4260 #include "rsl.inc"
4261 INTEGER DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
4262 MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
4263 PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
4264 INTEGER DS1,DE1,DS2,DE2,DS3,DE3,&
4265 MS1,ME1,MS2,ME2,MS3,ME3,&
4266 PS1,PE1,PS2,PE2,PS3,PE3
4267 CHARACTER *(*) stagger,ordering
4268 INTEGER fid,domdesc,type
4269 REAL globbuf(*)
4270 REAL buf(*)
4271 LOGICAL, EXTERNAL :: has_char
4272
4273 INTEGER i,j,k,ord,ord2d,ndim
4274 INTEGER glen(3),llen(3),glen2d(3),llen2d(3)
4275
4276 DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
4277 MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
4278 PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
4279
4280 ndim = len(TRIM(ordering))
4281
4282 SELECT CASE ( TRIM(ordering) )
4283 CASE ( 'xyz','xy' )
4284 ord = io3d_ijk_internal ; ord2d = io2d_ij_internal
4285 ! the non-staggered variables come in at one-less than
4286 ! domain dimensions, but RSL wants full domain spec, so
4287 ! adjust if not staggered
4288 IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4289 IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
4290 IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4291 CASE ( 'yxz','yx' )
4292 ord = io3d_jik_internal ; ord2d = io2d_ji_internal
4293 IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4294 IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
4295 IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
4296 CASE ( 'zxy' )
4297 ord = io3d_kij_internal ; ord2d = io2d_ij_internal
4298 IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
4299 IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4300 IF ( .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
4301 #if 0
4302 CASE ( 'zyx' )
4303 ord = io3d_kji_internal ; ord2d = io2d_ji_internal
4304 CASE ( 'yzx' )
4305 ord = io3d_jki_internal ; ord2d = io2d_ji_internal
4306 #endif
4307 CASE ( 'xzy' )
4308 ord = io3d_ikj_internal ; ord2d = io2d_ij_internal
4309 IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
4310 IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
4311 IF ( .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
4312 CASE DEFAULT
4313 ord = -1 ; ord2d = -1
4314 END SELECT
4315
4316 glen(1) = DE1-DS1+1 ; glen(2) = DE2-DS2+1 ; glen(3) = DE3-DS3+1
4317 llen(1) = ME1-MS1+1 ; llen(2) = ME2-MS2+1 ; llen(3) = ME3-MS3+1
4318 glen2d(1) = DE1-DS1+1 ; glen2d(2) = DE2-DS2+1
4319 llen2d(1) = ME1-MS1+1 ; llen2d(2) = ME2-MS2+1
4320
4321 IF ( ndim .EQ. 3 ) THEN
4322 CALL rsl_read(globbuf,ord,buf,domdesc,type,glen,llen)
4323 ELSE
4324 CALL rsl_read(globbuf,ord2d,buf,domdesc,type,glen2d,llen2d)
4325 ENDIF
4326 RETURN
4327 END SUBROUTINE wrf_global_to_patch_generic
4328
4329
4330 !------------------------------------------------------------------
4331
4332 #if ( EM_CORE == 1 )
4333
4334 !------------------------------------------------------------------
4335
4336 SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags &
4337 !
4338 #include "em_dummy_new_args.inc"
4339 !
4340 )
4341 USE module_domain
4342 USE module_configure
4343 USE module_dm
4344 !
4345 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4346 TYPE(domain), POINTER :: ngrid
4347 #include "em_dummy_new_decl.inc"
4348 #include "em_i1_decl.inc"
4349 INTEGER nlev, msize
4350 INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4351 TYPE (grid_config_rec_type) :: config_flags
4352 REAL xv(500)
4353 INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4354 cims, cime, cjms, cjme, ckms, ckme, &
4355 cips, cipe, cjps, cjpe, ckps, ckpe
4356 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4357 nims, nime, njms, njme, nkms, nkme, &
4358 nips, nipe, njps, njpe, nkps, nkpe
4359 ! <DESCRIPTION>
4360 ! Description is to do...
4361 ! </DESCRIPTION>
4362
4363 #ifdef DM_PARALLEL
4364 # define REGISTER_I1
4365 # include "em_data_calls.inc"
4366 #endif
4367
4368 CALL get_ijk_from_grid ( grid , &
4369 cids, cide, cjds, cjde, ckds, ckde, &
4370 cims, cime, cjms, cjme, ckms, ckme, &
4371 cips, cipe, cjps, cjpe, ckps, ckpe )
4372 CALL get_ijk_from_grid ( ngrid , &
4373 nids, nide, njds, njde, nkds, nkde, &
4374 nims, nime, njms, njme, nkms, nkme, &
4375 nips, nipe, njps, njpe, nkps, nkpe )
4376
4377 nlev = ckde - ckds + 1
4378
4379 # include "em_nest_interpdown_unpack.inc"
4380
4381 #include "HALO_EM_FORCE_DOWN.inc"
4382
4383 ! code here to interpolate the data into the nested domain
4384 # include "em_nest_forcedown_interp.inc"
4385
4386 RETURN
4387 END SUBROUTINE force_domain_em_part2
4388
4389
4390
4391 !------------------------------------------------------------------
4392
4393 SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags &
4394 !
4395 #include "em_dummy_new_args.inc"
4396 !
4397 )
4398 USE module_domain
4399 USE module_configure
4400 USE module_dm
4401 USE module_timing
4402 !
4403 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4404 TYPE(domain), POINTER :: intermediate_grid
4405 TYPE(domain), POINTER :: ngrid
4406 #include "em_dummy_new_decl.inc"
4407 INTEGER nlev, msize
4408 INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4409 TYPE (grid_config_rec_type) :: config_flags
4410 REAL xv(500)
4411 INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4412 cims, cime, cjms, cjme, ckms, ckme, &
4413 cips, cipe, cjps, cjpe, ckps, ckpe
4414 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4415 nims, nime, njms, njme, nkms, nkme, &
4416 nips, nipe, njps, njpe, nkps, nkpe
4417
4418 !
4419
4420 CALL get_ijk_from_grid ( grid , &
4421 cids, cide, cjds, cjde, ckds, ckde, &
4422 cims, cime, cjms, cjme, ckms, ckme, &
4423 cips, cipe, cjps, cjpe, ckps, ckpe )
4424 CALL get_ijk_from_grid ( intermediate_grid , &
4425 nids, nide, njds, njde, nkds, nkde, &
4426 nims, nime, njms, njme, nkms, nkme, &
4427 nips, nipe, njps, njpe, nkps, nkpe )
4428
4429 nlev = ckde - ckds + 1
4430
4431 # include "em_nest_interpdown_pack.inc"
4432
4433 CALL rsl_bcast_msgs
4434
4435 RETURN
4436 END SUBROUTINE interp_domain_em_part1
4437
4438 SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags &
4439 !
4440 #include "em_dummy_new_args.inc"
4441 !
4442 )
4443 USE module_domain
4444 USE module_configure
4445 USE module_dm
4446 !
4447 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4448 TYPE(domain), POINTER :: ngrid
4449 #include "em_dummy_new_decl.inc"
4450 #include "em_i1_decl.inc"
4451 INTEGER nlev, msize
4452 INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4453 TYPE (grid_config_rec_type) :: config_flags
4454 REAL xv(500)
4455 INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4456 cims, cime, cjms, cjme, ckms, ckme, &
4457 cips, cipe, cjps, cjpe, ckps, ckpe
4458 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4459 nims, nime, njms, njme, nkms, nkme, &
4460 nips, nipe, njps, njpe, nkps, nkpe
4461
4462 #ifdef DM_PARALLEL
4463 # define REGISTER_I1
4464 # include "em_data_calls.inc"
4465 #endif
4466 CALL get_ijk_from_grid ( grid , &
4467 cids, cide, cjds, cjde, ckds, ckde, &
4468 cims, cime, cjms, cjme, ckms, ckme, &
4469 cips, cipe, cjps, cjpe, ckps, ckpe )
4470 CALL get_ijk_from_grid ( ngrid , &
4471 nids, nide, njds, njde, nkds, nkde, &
4472 nims, nime, njms, njme, nkms, nkme, &
4473 nips, nipe, njps, njpe, nkps, nkpe )
4474
4475 nlev = ckde - ckds + 1
4476
4477 # include "em_nest_interpdown_unpack.inc"
4478
4479 #include "HALO_EM_INTERP_DOWN.inc"
4480 ! code here to interpolate the data into the nested domain
4481
4482 # include "em_nest_interpdown_interp.inc"
4483
4484 RETURN
4485 END SUBROUTINE interp_domain_em_part2
4486
4487 !------------------------------------------------------------------
4488 ! This routine exists only to call a halo on a domain (the nest)
4489 ! gets called from feedback_domain_em_part1, below. This is needed
4490 ! because the halo code expects the fields being exchanged to have
4491 ! been dereferenced from the grid data structure, but in feedback_domain_em_part1
4492 ! the grid data structure points to the coarse domain, not the nest.
4493 ! And we want the halo exchange on the nest, so that the code in
4494 ! em_nest_feedbackup_interp.inc will work correctly on multi-p. JM 20040308
4495 !
4496 SUBROUTINE feedback_nest_prep ( grid, config_flags &
4497 !
4498 #include "em_dummy_new_args.inc"
4499 !
4500 )
4501 USE module_domain
4502 USE module_configure
4503 USE module_dm
4504 ! JRB dupllicate
4505 ! USE module_state_description
4506 !
4507 TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid")
4508 TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
4509 ! soil temp, moisture, etc., has vertical dim
4510 ! of soil categories
4511 #include "em_dummy_new_decl.inc"
4512
4513 #ifdef DM_PARALLEL
4514 # include "em_data_calls.inc"
4515 #endif
4516
4517 #ifdef DM_PARALLEL
4518 # include "HALO_EM_INTERP_UP.inc"
4519 #endif
4520
4521 END SUBROUTINE feedback_nest_prep
4522
4523 SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags &
4524 !
4525 #include "em_dummy_new_args.inc"
4526 !
4527 )
4528 USE module_domain
4529 USE module_configure
4530 USE module_dm
4531 !
4532 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4533 TYPE(domain), POINTER :: ngrid
4534 #include "em_dummy_new_decl.inc"
4535 INTEGER nlev, msize
4536 INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4537 TYPE(domain), POINTER :: xgrid
4538 TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
4539 REAL xv(500)
4540 INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4541 cims, cime, cjms, cjme, ckms, ckme, &
4542 cips, cipe, cjps, cjpe, ckps, ckpe
4543 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4544 nims, nime, njms, njme, nkms, nkme, &
4545 nips, nipe, njps, njpe, nkps, nkpe
4546 INTERFACE
4547 SUBROUTINE feedback_nest_prep ( grid, config_flags &
4548 !
4549 #include "em_dummy_new_args.inc"
4550 !
4551 )
4552 USE module_domain
4553 USE module_configure
4554 USE module_dm
4555 ! JRB duplicate
4556 ! USE module_state_description
4557 !
4558 TYPE (grid_config_rec_type) :: config_flags
4559 TYPE(domain), TARGET :: grid
4560 #include "em_dummy_new_decl.inc"
4561 END SUBROUTINE feedback_nest_prep
4562
4563 END INTERFACE
4564
4565 CALL get_ijk_from_grid ( grid , &
4566 cids, cide, cjds, cjde, ckds, ckde, &
4567 cims, cime, cjms, cjme, ckms, ckme, &
4568 cips, cipe, cjps, cjpe, ckps, ckpe )
4569 CALL get_ijk_from_grid ( ngrid , &
4570 nids, nide, njds, njde, nkds, nkde, &
4571 nims, nime, njms, njme, nkms, nkme, &
4572 nips, nipe, njps, njpe, nkps, nkpe )
4573
4574 nlev = ckde - ckds + 1
4575
4576 ips_save = ngrid%i_parent_start ! used in feedback_domain_em_part2 below
4577 jps_save = ngrid%j_parent_start
4578 ipe_save = ngrid%i_parent_start + (nide-nids+1) / ngrid%parent_grid_ratio - 1
4579 jpe_save = ngrid%j_parent_start + (njde-njds+1) / ngrid%parent_grid_ratio - 1
4580
4581 CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
4582 CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
4583
4584 xgrid => grid
4585 grid => ngrid
4586
4587 CALL feedback_nest_prep ( grid, nconfig_flags &
4588 !
4589 #include "em_actual_new_args.inc"
4590 !
4591 )
4592
4593 grid => xgrid
4594 CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
4595
4596 # include "em_nest_feedbackup_interp.inc"
4597
4598 RETURN
4599 END SUBROUTINE feedback_domain_em_part1
4600
4601 !------------------------------------------------------------------
4602
4603 SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags &
4604 !
4605 #include "em_dummy_new_args.inc"
4606 !
4607 )
4608 USE module_domain
4609 USE module_configure
4610 USE module_dm
4611 !
4612 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4613 TYPE(domain), POINTER :: intermediate_grid
4614 TYPE(domain), POINTER :: ngrid
4615 #include "em_dummy_new_decl.inc"
4616 #include "em_i1_decl.inc"
4617 INTEGER nlev, msize
4618 INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4619 TYPE (grid_config_rec_type) :: config_flags
4620 REAL xv(500)
4621 INTEGER :: cids, cide, cjds, cjde, ckds, ckde, &
4622 cims, cime, cjms, cjme, ckms, ckme, &
4623 cips, cipe, cjps, cjpe, ckps, ckpe
4624 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
4625 nims, nime, njms, njme, nkms, nkme, &
4626 nips, nipe, njps, njpe, nkps, nkpe
4627 REAL :: nest_influence
4628 LOGICAL, EXTERNAL :: em_cd_feedback_mask
4629
4630 #ifdef DM_PARALLEL
4631 # define REGISTER_I1
4632 # include "em_data_calls.inc"
4633 #endif
4634
4635 nest_influence = 1.
4636
4637 CALL get_ijk_from_grid ( grid , &
4638 cids, cide, cjds, cjde, ckds, ckde, &
4639 cims, cime, cjms, cjme, ckms, ckme, &
4640 cips, cipe, cjps, cjpe, ckps, ckpe )
4641 CALL get_ijk_from_grid ( intermediate_grid , &
4642 nids, nide, njds, njde, nkds, nkde, &
4643 nims, nime, njms, njme, nkms, nkme, &
4644 nips, nipe, njps, njpe, nkps, nkpe )
4645
4646 nlev = ckde - ckds + 1
4647
4648 # include "em_nest_feedbackup_pack.inc"
4649
4650 CALL rsl_merge_msgs
4651
4652 #define NEST_INFLUENCE(A,B) A = B
4653 # include "em_nest_feedbackup_unpack.inc"
4654
4655 ! smooth coarse grid
4656
4657 CALL get_ijk_from_grid ( ngrid, &
4658 nids, nide, njds, njde, nkds, nkde, &
4659 nims, nime, njms, njme, nkms, nkme, &
4660 nips, nipe, njps, njpe, nkps, nkpe )
4661
4662 # include "HALO_EM_INTERP_UP.inc"
4663 # include "em_nest_feedbackup_smooth.inc"
4664
4665 RETURN
4666 END SUBROUTINE feedback_domain_em_part2
4667
4668 #endif
4669
4670 !------------------------------------------------------------------
4671
4672 #if ( NMM_CORE == 1 )
4673 !==============================================================================
4674 ! NMM nesting infrastructure extended from EM core. This is gopal's doing.
4675 !==============================================================================
4676
4677 SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags &
4678 !
4679 #include "nmm_dummy_args.inc"
4680 !
4681 )
4682 USE module_domain
4683 USE module_configure
4684 USE module_dm
4685 USE module_timing
4686 IMPLICIT NONE
4687 !
4688 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4689 TYPE(domain), POINTER :: intermediate_grid
4690 TYPE(domain), POINTER :: ngrid
4691 #include "nmm_dummy_decl.inc"
4692 TYPE (grid_config_rec_type) :: config_flags
4693
4694 CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4695
4696 RETURN
4697 END SUBROUTINE interp_domain_nmm_part1
4698
4699 SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags &
4700 !
4701 #include "nmm_dummy_args.inc"
4702 !
4703 )
4704 USE module_domain
4705 USE module_configure
4706 USE module_dm
4707 IMPLICIT NONE
4708 !
4709 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4710 TYPE(domain), POINTER :: ngrid
4711 #include "nmm_dummy_decl.inc"
4712 TYPE (grid_config_rec_type) :: config_flags
4713
4714 CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4715
4716 RETURN
4717 END SUBROUTINE interp_domain_nmm_part2
4718
4719 SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags &
4720 !
4721 #include "nmm_dummy_args.inc"
4722 !
4723 )
4724 USE module_domain
4725 USE module_configure
4726 USE module_dm
4727 USE module_timing
4728 !
4729 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4730 TYPE(domain), POINTER :: intermediate_grid
4731 #include "nmm_dummy_decl.inc"
4732 TYPE (grid_config_rec_type) :: config_flags
4733
4734 CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4735
4736 RETURN
4737 END SUBROUTINE force_domain_nmm_part1
4738
4739 SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags &
4740 !
4741 #include "nmm_dummy_args.inc"
4742 !
4743 )
4744 USE module_domain
4745 USE module_configure
4746 USE module_dm
4747 IMPLICIT NONE
4748 !
4749 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4750 TYPE(domain), POINTER :: ngrid
4751 #include "nmm_dummy_decl.inc"
4752 TYPE (grid_config_rec_type) :: config_flags
4753
4754 CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4755
4756 RETURN
4757 END SUBROUTINE force_domain_nmm_part2
4758
4759 SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags &
4760 !
4761 #include "nmm_dummy_args.inc"
4762 !
4763 )
4764 USE module_domain
4765 USE module_configure
4766 USE module_dm
4767 IMPLICIT NONE
4768 !
4769 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4770 TYPE(domain), POINTER :: ngrid
4771 #include "nmm_dummy_decl.inc"
4772 TYPE (grid_config_rec_type) :: config_flags, nconfig_flags
4773
4774 CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4775
4776 RETURN
4777 END SUBROUTINE feedback_domain_nmm_part1
4778
4779 SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags &
4780 !
4781 #include "nmm_dummy_args.inc"
4782 !
4783 )
4784 USE module_domain
4785 USE module_configure
4786 USE module_dm
4787 USE module_utility
4788 IMPLICIT NONE
4789
4790 !
4791 TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid")
4792 TYPE(domain), POINTER :: intermediate_grid
4793 TYPE(domain), POINTER :: ngrid
4794
4795 #include "nmm_dummy_decl.inc"
4796 TYPE (grid_config_rec_type) :: config_flags
4797
4798 CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
4799
4800 RETURN
4801 END SUBROUTINE feedback_domain_nmm_part2
4802
4803 !=================================================================================
4804 ! End of gopal's doing
4805 !=================================================================================
4806 #endif
4807
4808
4809
4810 #ifndef STUBMPI
4811
4812 SUBROUTINE wrf_gatherv_real (Field, field_ofst, &
4813 my_count , & ! sendcount
4814 globbuf, glob_ofst , & ! recvbuf
4815 counts , & ! recvcounts
4816 displs , & ! displs
4817 root , & ! root
4818 communicator , & ! communicator
4819 ierr )
4820 USE module_dm
4821 IMPLICIT NONE
4822 INCLUDE 'mpif.h'
4823 INTEGER field_ofst, glob_ofst
4824 INTEGER my_count, communicator, root, ierr
4825 INTEGER , DIMENSION(*) :: counts, displs
4826 REAL, DIMENSION(*) :: Field, globbuf
4827
4828 CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
4829 my_count , & ! sendcount
4830 getrealmpitype() , & ! sendtype
4831 globbuf( glob_ofst ) , & ! recvbuf
4832 counts , & ! recvcounts
4833 displs , & ! displs
4834 getrealmpitype() , & ! recvtype
4835 root , & ! root
4836 communicator , & ! communicator
4837 ierr )
4838
4839 END SUBROUTINE wrf_gatherv_real
4840
4841 SUBROUTINE wrf_gatherv_integer (Field, field_ofst, &
4842 my_count , & ! sendcount
4843 globbuf, glob_ofst , & ! recvbuf
4844 counts , & ! recvcounts
4845 displs , & ! displs
4846 root , & ! root
4847 communicator , & ! communicator
4848 ierr )
4849 USE module_dm
4850 IMPLICIT NONE
4851 INCLUDE 'mpif.h'
4852 INTEGER field_ofst, glob_ofst
4853 INTEGER my_count, communicator, root, ierr
4854 INTEGER , DIMENSION(*) :: counts, displs
4855 INTEGER, DIMENSION(*) :: Field, globbuf
4856
4857 CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
4858 my_count , & ! sendcount
4859 MPI_INTEGER , & ! sendtype
4860 globbuf( glob_ofst ) , & ! recvbuf
4861 counts , & ! recvcounts
4862 displs , & ! displs
4863 MPI_INTEGER , & ! recvtype
4864 root , & ! root
4865 communicator , & ! communicator
4866 ierr )
4867
4868 END SUBROUTINE wrf_gatherv_integer
4869
4870 SUBROUTINE wrf_gatherv_double (Field, field_ofst, &
4871 my_count , & ! sendcount
4872 globbuf, glob_ofst , & ! recvbuf
4873 counts , & ! recvcounts
4874 displs , & ! displs
4875 root , & ! root
4876 communicator , & ! communicator
4877 ierr )
4878 USE module_dm
4879 IMPLICIT NONE
4880 INCLUDE 'mpif.h'
4881 INTEGER field_ofst, glob_ofst
4882 INTEGER my_count, communicator, root, ierr
4883 INTEGER , DIMENSION(*) :: counts, displs
4884 ! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
4885 ! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
4886 ! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
4887 ! if we were not indexing the globbuf and Field arrays it would not even matter
4888 REAL, DIMENSION(*) :: Field, globbuf
4889
4890 CALL mpi_gatherv( Field( field_ofst ), & ! sendbuf
4891 my_count , & ! sendcount
4892 MPI_DOUBLE_PRECISION , & ! sendtype
4893 globbuf( glob_ofst ) , & ! recvbuf
4894 counts , & ! recvcounts
4895 displs , & ! displs
4896 MPI_DOUBLE_PRECISION , & ! recvtype
4897 root , & ! root
4898 communicator , & ! communicator
4899 ierr )
4900
4901 END SUBROUTINE wrf_gatherv_double
4902
4903 !new stuff 20070124
4904 SUBROUTINE wrf_scatterv_real ( &
4905 globbuf, glob_ofst , & ! recvbuf
4906 counts , & ! recvcounts
4907 Field, field_ofst, &
4908 my_count , & ! sendcount
4909 displs , & ! displs
4910 root , & ! root
4911 communicator , & ! communicator
4912 ierr )
4913 USE module_dm
4914 IMPLICIT NONE
4915 INCLUDE 'mpif.h'
4916 INTEGER field_ofst, glob_ofst
4917 INTEGER my_count, communicator, root, ierr
4918 INTEGER , DIMENSION(*) :: counts, displs
4919 REAL, DIMENSION(*) :: Field, globbuf
4920
4921 CALL mpi_scatterv( &
4922 globbuf( glob_ofst ) , & ! recvbuf
4923 counts , & ! recvcounts
4924 displs , & ! displs
4925 getrealmpitype() , & ! recvtype
4926 Field( field_ofst ), & ! sendbuf
4927 my_count , & ! sendcount
4928 getrealmpitype() , & ! sendtype
4929 root , & ! root
4930 communicator , & ! communicator
4931 ierr )
4932
4933 END SUBROUTINE wrf_scatterv_real
4934
4935 SUBROUTINE wrf_scatterv_double ( &
4936 globbuf, glob_ofst , & ! recvbuf
4937 counts , & ! recvcounts
4938 Field, field_ofst, &
4939 my_count , & ! sendcount
4940 displs , & ! displs
4941 root , & ! root
4942 communicator , & ! communicator
4943 ierr )
4944 USE module_dm
4945 IMPLICIT NONE
4946 INCLUDE 'mpif.h'
4947 INTEGER field_ofst, glob_ofst
4948 INTEGER my_count, communicator, root, ierr
4949 INTEGER , DIMENSION(*) :: counts, displs
4950 ! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
4951 ! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
4952 ! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
4953 ! if we were not indexing the globbuf and Field arrays it would not even matter
4954 REAL, DIMENSION(*) :: Field, globbuf
4955
4956 CALL mpi_scatterv( &
4957 globbuf( glob_ofst ) , & ! recvbuf
4958 counts , & ! recvcounts
4959 displs , & ! displs
4960 MPI_DOUBLE_PRECISION , & ! recvtype
4961 Field( field_ofst ), & ! sendbuf
4962 my_count , & ! sendcount
4963 MPI_DOUBLE_PRECISION , & ! sendtype
4964 root , & ! root
4965 communicator , & ! communicator
4966 ierr )
4967
4968 END SUBROUTINE wrf_scatterv_double
4969
4970 SUBROUTINE wrf_scatterv_integer ( &
4971 globbuf, glob_ofst , & ! recvbuf
4972 counts , & ! recvcounts
4973 Field, field_ofst, &
4974 my_count , & ! sendcount
4975 displs , & ! displs
4976 root , & ! root
4977 communicator , & ! communicator
4978 ierr )
4979 IMPLICIT NONE
4980 INCLUDE 'mpif.h'
4981 INTEGER field_ofst, glob_ofst
4982 INTEGER my_count, communicator, root, ierr
4983 INTEGER , DIMENSION(*) :: counts, displs
4984 INTEGER, DIMENSION(*) :: Field, globbuf
4985
4986 CALL mpi_scatterv( &
4987 globbuf( glob_ofst ) , & ! recvbuf
4988 counts , & ! recvcounts
4989 displs , & ! displs
4990 MPI_INTEGER , & ! recvtype
4991 Field( field_ofst ), & ! sendbuf
4992 my_count , & ! sendcount
4993 MPI_INTEGER , & ! sendtype
4994 root , & ! root
4995 communicator , & ! communicator
4996 ierr )
4997
4998 END SUBROUTINE wrf_scatterv_integer
4999 ! end new stuff 20070124
5000
5001 #endif