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