module_io_quilt.F
References to this file elsewhere.
1 !WRF:DRIVER_LAYER:IO
2 !
3 #define DEBUG_LVL 50
4 !#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) ; write(0,*) __LINE__
5 #define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k )
6
7 MODULE module_wrf_quilt
8 !<DESCRIPTION>
9 !<PRE>
10 ! This module contains WRF-specific I/O quilt routines called by both
11 ! client (compute) and server (I/O quilt) tasks. I/O quilt servers are
12 ! a run-time optimization that allow I/O operations, executed on the I/O
13 ! quilt server tasks, to be overlapped with useful computation, executed on
14 ! the compute tasks. Since I/O operations are often quite slow compared to
15 ! computation, this performance optimization can increase parallel
16 ! efficiency.
17 !
18 ! Currently, one group of I/O servers can be specified at run-time. Namelist
19 ! variable "nio_tasks_per_group" is used to specify the number of I/O server
20 ! tasks in this group. In most cases, parallel efficiency is optimized when
21 ! the minimum number of I/O server tasks are used. If memory needed to cache
22 ! I/O operations fits on a single processor, then set nio_tasks_per_group=1.
23 ! If not, increase the number of I/O server tasks until I/O operations fit in
24 ! memory. In the future, multiple groups of I/O server tasks will be
25 ! supported. The number of groups will be specified by namelist variable
26 ! "nio_groups". For now, nio_groups must be set to 1. Currently, I/O servers
27 ! only support overlap of output operations with computation. Also, only I/O
28 ! packages that do no support native parallel I/O may be used with I/O server
29 ! tasks. This excludes PHDF5 and MCEL.
30 !
31 ! In this module, the I/O quilt server tasks call package-dependent
32 ! WRF-specific I/O interfaces to perform I/O operations requested by the
33 ! client (compute) tasks. All of these calls occur inside subroutine
34 ! quilt().
35 !
36 ! The client (compute) tasks call package-independent WRF-specific "quilt I/O"
37 ! interfaces that send requests to the I/O quilt servers. All of these calls
38 ! are made from module_io.F.
39 !
40 ! These routines have the same names and (roughly) the same arguments as those
41 ! specified in the WRF I/O API except that:
42 ! - "Quilt I/O" routines defined in this file and called by routines in
43 ! module_io.F have the "wrf_quilt_" prefix.
44 ! - Package-dependent routines called from routines in this file are defined
45 ! in the external I/O packages and have the "ext_" prefix.
46 !
47 ! Both client (compute) and server tasks call routine init_module_wrf_quilt()
48 ! which then calls setup_quilt_servers() determine which tasks are compute
49 ! tasks and which are server tasks. Before the end of init_module_wrf_quilt()
50 ! server tasks call routine quilt() and remain there for the rest of the model
51 ! run. Compute tasks return from init_module_wrf_quilt() to perform model
52 ! computations.
53 !
54 ! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
55 ! version of the WRF I/O API. This document includes detailed descriptions
56 ! of subroutines and their arguments that are not duplicated here.
57 !</PRE>
58 !</DESCRIPTION>
59 USE module_internal_header_util
60 USE module_timing
61
62 INTEGER, PARAMETER :: int_num_handles = 99
63 LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, int_handle_in_use, okay_to_commit
64 INTEGER, DIMENSION(int_num_handles) :: int_num_bytes_to_write, io_form
65 REAL, POINTER :: int_local_output_buffer(:)
66 INTEGER :: int_local_output_cursor
67 LOGICAL :: quilting_enabled
68 LOGICAL :: disable_quilt = .FALSE.
69 INTEGER :: prev_server_for_handle = -1
70 INTEGER :: server_for_handle(int_num_handles)
71 INTEGER :: reduced(2), reduced_dummy(2)
72 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
73
74 INTEGER nio_groups
75 #ifdef DM_PARALLEL
76 INTEGER mpi_comm_local
77 INTEGER mpi_comm_io_groups(100)
78 INTEGER nio_tasks_in_group
79 INTEGER nio_tasks_per_group
80 INTEGER ncompute_tasks
81 INTEGER ntasks
82 INTEGER mytask
83
84 INTEGER, PARAMETER :: onebyte = 1
85 INTEGER comm_io_servers, iserver, hdrbufsize, obufsize
86 INTEGER, DIMENSION(4096) :: hdrbuf
87 INTEGER, DIMENSION(int_num_handles) :: handle
88 #endif
89
90 CONTAINS
91
92 #if defined(DM_PARALLEL) && !defined( STUBMPI )
93 INTEGER FUNCTION get_server_id ( dhandle )
94 !<DESCRIPTION>
95 ! Logic in the client side to know which io server
96 ! group to send to. If the unit corresponds to a file that's
97 ! already been opened, then we have no choice but to send the
98 ! data to that group again, regardless of whether there are
99 ! other server-groups. If it's a new file, we can chose a new
100 ! server group. I.e. opening a file locks it onto a server
101 ! group. Closing the file unlocks it.
102 !</DESCRIPTION>
103 IMPLICIT NONE
104 INTEGER, INTENT(IN) :: dhandle
105 IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN
106 IF ( server_for_handle ( dhandle ) .GE. 1 ) THEN
107 get_server_id = server_for_handle ( dhandle )
108 ELSE
109 prev_server_for_handle = mod ( prev_server_for_handle + 1 , nio_groups )
110 server_for_handle( dhandle ) = prev_server_for_handle+1
111 get_server_id = prev_server_for_handle+1
112 ENDIF
113 ELSE
114 CALL wrf_message('module_io_quilt: get_server_id bad dhandle' )
115 ENDIF
116 END FUNCTION get_server_id
117 #endif
118
119 SUBROUTINE set_server_id ( dhandle, value )
120 IMPLICIT NONE
121 INTEGER, INTENT(IN) :: dhandle, value
122 IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN
123 server_for_handle(dhandle) = value
124 ELSE
125 CALL wrf_message('module_io_quilt: set_server_id bad dhandle' )
126 ENDIF
127 END SUBROUTINE set_server_id
128
129 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
130 SUBROUTINE int_get_fresh_handle( retval )
131 !<DESCRIPTION>
132 ! Find an unused "client file handle" and return it in retval.
133 ! The "client file handle" is used to remember how a file was opened
134 ! so clients do not need to ask the I/O quilt servers for this information.
135 ! It is also used as a file identifier in communications with the I/O
136 ! server task.
137 !
138 ! Note that client tasks know nothing about package-specific handles.
139 ! Only the I/O quilt servers know about them.
140 !</DESCRIPTION>
141 INTEGER i, retval
142 retval = -1
143 DO i = 1, int_num_handles
144 IF ( .NOT. int_handle_in_use(i) ) THEN
145 retval = i
146 GOTO 33
147 ENDIF
148 ENDDO
149 33 CONTINUE
150 IF ( retval < 0 ) THEN
151 CALL wrf_error_fatal("frame/module_io_quilt.F: int_get_fresh_handle() can not")
152 ENDIF
153 int_handle_in_use(i) = .TRUE.
154 NULLIFY ( int_local_output_buffer )
155 END SUBROUTINE int_get_fresh_handle
156
157 SUBROUTINE setup_quilt_servers ( nio_tasks_per_group, &
158 mytask, &
159 ntasks, &
160 n_groups_arg, &
161 nio, &
162 mpi_comm_wrld, &
163 mpi_comm_local, &
164 mpi_comm_io_groups)
165 !<DESCRIPTION>
166 ! Both client (compute) and server tasks call this routine to
167 ! determine which tasks are compute tasks and which are I/O server tasks.
168 !
169 ! Module variables MPI_COMM_LOCAL and MPI_COMM_IO_GROUPS(:) are set up to
170 ! contain MPI communicators as follows:
171 !
172 ! MPI_COMM_LOCAL is the Communicator for the local groups of tasks. For the
173 ! compute tasks it is the group of compute tasks; for a server group it the
174 ! communicator of tasks in the server group.
175 !
176 ! Elements of MPI_COMM_IO_GROUPS are communicators that each contain one or
177 ! more compute tasks and a single I/O server assigned to those compute tasks.
178 ! The I/O server tasks is always the last task in these communicators.
179 ! On a compute task, which has a single associate in each of the server
180 ! groups, MPI_COMM_IO_GROUPS is treated as an array; each element corresponds
181 ! to a different server group.
182 ! On a server task only the first element of MPI_COMM_IO_GROUPS is used
183 ! because each server task is part of only one io_group.
184 !
185 ! I/O server tasks in each I/O server group are divided among compute tasks as
186 ! evenly as possible.
187 !
188 ! When multiple I/O server groups are used, each must have the same number of
189 ! tasks. When the total number of extra I/O tasks does not divide evenly by
190 ! the number of io server groups requested, the remainder tasks are not used
191 ! (wasted).
192 !
193 ! For example, communicator membership for 18 tasks with nio_groups=2 and
194 ! nio_tasks_per_group=3 is shown below:
195 !
196 !<PRE>
197 ! Membership for MPI_COMM_LOCAL communicators:
198 ! COMPUTE TASKS: 0 1 2 3 4 5 6 7 8 9 10 11
199 ! 1ST I/O SERVER GROUP: 12 13 14
200 ! 2ND I/O SERVER GROUP: 15 16 17
201 !
202 ! Membership for MPI_COMM_IO_GROUPS(1):
203 ! COMPUTE TASKS 0, 3, 6, 9: 0 3 6 9 12
204 ! COMPUTE TASKS 1, 4, 7,10: 1 4 7 10 13
205 ! COMPUTE TASKS 2, 5, 8,11: 2 5 8 11 14
206 ! I/O SERVER TASK 12: 0 3 6 9 12
207 ! I/O SERVER TASK 13: 1 4 7 10 13
208 ! I/O SERVER TASK 14: 2 5 8 11 14
209 ! I/O SERVER TASK 15: 0 3 6 9 15
210 ! I/O SERVER TASK 16: 1 4 7 10 16
211 ! I/O SERVER TASK 17: 2 5 8 11 17
212 !
213 ! Membership for MPI_COMM_IO_GROUPS(2):
214 ! COMPUTE TASKS 0, 3, 6, 9: 0 3 6 9 15
215 ! COMPUTE TASKS 1, 4, 7,10: 1 4 7 10 16
216 ! COMPUTE TASKS 2, 5, 8,11: 2 5 8 11 17
217 ! I/O SERVER TASK 12: ** not used **
218 ! I/O SERVER TASK 13: ** not used **
219 ! I/O SERVER TASK 14: ** not used **
220 ! I/O SERVER TASK 15: ** not used **
221 ! I/O SERVER TASK 16: ** not used **
222 ! I/O SERVER TASK 17: ** not used **
223 !</PRE>
224 !</DESCRIPTION>
225 IMPLICIT NONE
226 INCLUDE 'mpif.h'
227 INTEGER, INTENT(IN) :: nio_tasks_per_group, mytask, ntasks, &
228 n_groups_arg, mpi_comm_wrld
229 INTEGER, INTENT(OUT) :: mpi_comm_local, nio
230 INTEGER, DIMENSION(100), INTENT(OUT) :: mpi_comm_io_groups
231 ! Local
232 INTEGER :: i, j, ii, comdup, ierr, niotasks, n_groups, iisize
233 INTEGER, DIMENSION(ntasks) :: icolor
234 CHARACTER*128 mess
235
236 n_groups = n_groups_arg
237 IF ( n_groups .LT. 1 ) n_groups = 1
238
239 !<DESCRIPTION>
240 ! nio is number of io tasks per group. If there arent enough tasks to satisfy
241 ! the requirement that there be at least as many compute tasks as io tasks in
242 ! each group, then just print a warning and dump out of quilting
243 !</DESCRIPTION>
244
245 nio = nio_tasks_per_group
246 ncompute_tasks = ntasks - (nio * n_groups)
247 IF ( ncompute_tasks .LT. nio ) THEN
248 WRITE(mess,'("Not enough tasks to have ",I3," groups of ",I3," I/O tasks. No quilting.")')n_groups,nio
249 nio = 0
250 ncompute_tasks = ntasks
251 ELSE
252 WRITE(mess,'("Quilting with ",I3," groups of ",I3," I/O tasks.")')n_groups,nio
253 ENDIF
254 CALL wrf_message(mess)
255
256 IF ( nio .LT. 0 ) THEN
257 nio = 0
258 ENDIF
259 IF ( nio .EQ. 0 ) THEN
260 quilting_enabled = .FALSE.
261 mpi_comm_local = MPI_COMM_WORLD
262 mpi_comm_io_groups = MPI_COMM_WORLD
263 RETURN
264 ENDIF
265 quilting_enabled = .TRUE.
266
267 ! First construct the local communicators
268 ! prepare to split the communicator by designating compute-only tasks
269 DO i = 1, ncompute_tasks
270 icolor(i) = 0
271 ENDDO
272 ii = 1
273 ! and designating the groups of i/o tasks
274 DO i = ncompute_tasks+1, ntasks, nio
275 DO j = i, i+nio-1
276 icolor(j) = ii
277 ENDDO
278 ii = ii+1
279 ENDDO
280 CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr)
281 CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr)
282
283 ! Now construct the communicators for the io_groups; round-robining the compute tasks
284 DO i = 1, ncompute_tasks
285 icolor(i) = mod(i-1,nio)
286 ENDDO
287 ! ... and add the io servers as the last task in each group
288 DO j = 1, n_groups
289 ! TBH: each I/O group will contain only one I/O server
290 DO i = ncompute_tasks+1,ntasks
291 icolor(i) = MPI_UNDEFINED
292 ENDDO
293 ii = 0
294 DO i = ncompute_tasks+(j-1)*nio+1,ncompute_tasks+j*nio
295 icolor(i) = ii
296 ii = ii+1
297 ENDDO
298 CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr)
299 CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_io_groups(j),ierr)
300 !CALL MPI_Comm_Size( mpi_comm_io_groups(j) , iisize, ierr )
301 ENDDO
302 ! If I am an I/O server, figure out which group I'm in and make that group's
303 ! communicator the first element in the mpi_comm_io_groups array (I will ignore
304 ! all of the other elements).
305 IF ( mytask+1 .GT. ncompute_tasks ) THEN
306 niotasks = ntasks - ncompute_tasks
307 i = mytask - ncompute_tasks
308 j = i / nio + 1
309 mpi_comm_io_groups(1) = mpi_comm_io_groups(j)
310 ENDIF
311
312 END SUBROUTINE setup_quilt_servers
313
314 SUBROUTINE quilt
315 !<DESCRIPTION>
316 ! I/O server tasks call this routine and remain in it for the rest of the
317 ! model run. I/O servers receive I/O requests from compute tasks and
318 ! perform requested I/O operations by calling package-dependent WRF-specific
319 ! I/O interfaces. Requests are sent in the form of "data headers". Each
320 ! request has a unique "header" message associated with it. For requests that
321 ! contain large amounts of data, the data is appended to the header. See
322 ! file module_internal_header_util.F for detailed descriptions of all
323 ! headers.
324 !
325 ! We wish to be able to link to different packages depending on whether
326 ! the I/O is restart, initial, history, or boundary.
327 !</DESCRIPTION>
328 USE module_state_description
329 USE module_quilt_outbuf_ops
330 IMPLICIT NONE
331 INCLUDE 'mpif.h'
332 #include "intio_tags.h"
333 #include "wrf_io_flags.h"
334 INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr
335 INTEGER istat
336 INTEGER mytask_io_group
337 INTEGER :: nout_set = 0
338 INTEGER :: obufsize, bigbufsize, inttypesize, chunksize, sz
339 REAL, DIMENSION(1) :: dummy
340 INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf
341 REAL, ALLOCATABLE, DIMENSION(:) :: RDATA
342 INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA
343 CHARACTER (LEN=512) :: CDATA
344 CHARACTER (LEN=80) :: fname
345 INTEGER icurs, hdrbufsize, itypesize, ftypesize, Status, fstat, io_form_arg
346 INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count
347 INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
348 INTEGER :: dummybuf(1)
349 CHARACTER (len=80) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess
350 INTEGER, EXTERNAL :: use_package
351 LOGICAL :: stored_write_record, retval
352 INTEGER iii, jjj, vid
353
354 !
355
356 ! Call ext_pkg_ioinit() routines to initialize I/O packages.
357 SysDepInfo = " "
358 #ifdef NETCDF
359 CALL ext_ncd_ioinit( SysDepInfo, ierr)
360 #endif
361 #ifdef INTIO
362 CALL ext_int_ioinit( SysDepInfo, ierr )
363 #endif
364 #ifdef XXX
365 CALL ext_xxx_ioinit( SysDepInfo, ierr)
366 #endif
367 #ifdef YYY
368 CALL ext_yyy_ioinit( SysDepInfo, ierr)
369 #endif
370 #ifdef ZZZ
371 CALL ext_zzz_ioinit( SysDepInfo, ierr)
372 #endif
373 #ifdef GRIB1
374 CALL ext_gr1_ioinit( SysDepInfo, ierr)
375 #endif
376 #ifdef GRIB2
377 CALL ext_gr2_ioinit( SysDepInfo, ierr)
378 #endif
379
380 okay_to_commit = .false.
381 stored_write_record = .false.
382 ninbuf = 0
383 ! get info. about the I/O server group that this I/O server task
384 ! belongs to
385 ! Last task in this I/O server group is the I/O server "root"
386 ! The I/O server "root" actually writes data to disk
387 ! TBH: WARNING: This is also implicit in the call to collect_on_comm().
388 CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr )
389 CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr )
390 CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr )
391 CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr )
392
393 CALL MPI_TYPE_SIZE( MPI_INTEGER, inttypesize, ierr )
394 IF ( inttypesize <= 0 ) THEN
395 CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid")
396 ENDIF
397 ! infinite loop until shutdown message received
398 ! This is the main request-handling loop. I/O quilt servers stay in this loop
399 ! until the model run ends.
400 DO WHILE (.TRUE.)
401
402 !<DESCRIPTION>
403 ! Each I/O server receives requests from its compute tasks. Each request
404 ! is contained in a data header (see module_internal_header_util.F for
405 ! detailed descriptions of data headers).
406 ! Each request is sent in two phases. First, sizes of all messages that
407 ! will be sent from the compute tasks to this I/O server are summed on the
408 ! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf"
409 ! and receives concatenated messages from the compute tasks in it via the
410 ! call to collect_on_comm(). Note that "sizes" are generally expressed in
411 ! *bytes* in this code so conversion to "count" (number of Fortran words) is
412 ! required for Fortran indexing and MPI calls.
413 !</DESCRIPTION>
414 ! wait for info from compute tasks in the I/O group that we're ready to rock
415 ! obufsize will contain number of *bytes*
416 !JMTIMINGCALL start_timing
417 ! first element of reduced is obufsize, second is DataHandle
418 ! if needed (currently needed only for ioclose).
419 reduced_dummy = 0
420 CALL MPI_Reduce( reduced_dummy, reduced, 2, MPI_INTEGER, &
421 MPI_SUM, mytask_io_group, &
422 mpi_comm_io_groups(1), ierr )
423 obufsize = reduced(1)
424 !JMTIMING CALL end_timing("MPI_Reduce at top of forever loop")
425 !JMDEBUGwrite(0,*)'obufsize = ',obufsize
426 !write(0,*)'ninbuf ',ninbuf,' obufsize ', obufsize
427 ! Negative obufsize will trigger I/O server exit.
428 IF ( obufsize .LT. 0 ) THEN
429 IF ( obufsize .EQ. -100 ) THEN ! magic number
430 #ifdef NETCDF
431 CALL ext_ncd_ioexit( Status )
432 #endif
433 #ifdef INTIO
434 CALL ext_int_ioexit( Status )
435 #endif
436 #ifdef XXX
437 CALL ext_xxx_ioexit( Status )
438 #endif
439 #ifdef YYY
440 CALL ext_yyy_ioexit( Status )
441 #endif
442 #ifdef ZZZ
443 CALL ext_zzz_ioexit( Status )
444 #endif
445 #ifdef GRIB1
446 CALL ext_gr1_ioexit( Status )
447 #endif
448 #ifdef GRIB2
449 CALL ext_gr2_ioexit( Status )
450 #endif
451 CALL wrf_message ( 'I/O QUILT SERVERS DONE' )
452 CALL mpi_finalize(ierr)
453 STOP
454 ELSE
455 CALL wrf_error_fatal('Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.')
456 ENDIF
457 ENDIF
458
459 !JMTIMING CALL start_timing
460 ! Obufsize of zero signals a close
461
462 ! Allocate buffer obuf to be big enough for the data the compute tasks
463 ! will send. Note: obuf is size in *bytes* so we need to pare this
464 ! down, since the buffer is INTEGER.
465 IF ( obufsize .GT. 0 ) THEN
466 ALLOCATE( obuf( (obufsize+1)/inttypesize ) )
467
468 ! let's roll; get the data from the compute procs and put in obuf
469 CALL collect_on_comm( mpi_comm_io_groups(1), &
470 onebyte, &
471 dummy, 0, &
472 obuf, obufsize )
473 !JMTIMING CALL end_timing( "quilt on server: collecting data from compute procs" )
474 ELSE
475 ! Necessarily, the compute processes send the ioclose signal,
476 ! if there is one, after the iosync, which means they
477 ! will stall on the ioclose message waiting for the quilt
478 ! processes if we handle the way other messages are collected,
479 ! using collect_on_comm. This avoids this, but we need
480 ! a special signal (obufsize zero) and the DataHandle
481 ! to be closed. That handle is send as the second
482 ! word of the io_close message received by the MPI_Reduce above.
483 ! Then a header representing the ioclose message is constructed
484 ! here and handled below as if it were received from the
485 ! compute processes. The clients (compute processes) must be
486 ! careful to send this correctly (one compule process sends the actual
487 ! handle and everone else sends a zero, so the result sums to
488 ! the value of the handle).
489 !
490 ALLOCATE( obuf( 4096 ) )
491 ! DataHandle is provided as second element of reduced
492 CALL int_gen_handle_header( obuf, obufsize, itypesize, &
493 reduced(2) , int_ioclose )
494
495 ENDIF
496
497 !write(0,*)'calling init_store_piece_of_field'
498 ! Now all messages received from the compute clients are stored in
499 ! obuf. Scan through obuf and extract headers and field data and store in
500 ! internal buffers. The scan is done twice, first to determine sizes of
501 ! internal buffers required for storage of headers and fields and second to
502 ! actually store the headers and fields. This bit of code does not do the
503 ! "quilting" (assembly of patches into full domains). For each field, it
504 ! simply concatenates all received patches for the field into a separate
505 ! internal buffer (i.e. one buffer per field). Quilting is done later by
506 ! routine store_patch_in_outbuf().
507 CALL init_store_piece_of_field
508 CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr )
509 !write(0,*)'mpi_type_size returns ', itypesize
510 ! Scan obuf the first time to calculate the size of the buffer required for
511 ! each field. Calls to add_to_bufsize_for_field() accumulate sizes.
512 vid = 0
513 icurs = inttypesize
514 DO WHILE ( icurs .lt. obufsize )
515 SELECT CASE ( get_hdr_tag( obuf ( icurs / inttypesize ) ) )
516 CASE ( int_field )
517 CALL int_get_write_field_header ( obuf(icurs/inttypesize), hdrbufsize, itypesize, ftypesize, &
518 DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
519 DomainDesc , MemoryOrder , Stagger , DimNames , &
520 DomainStart , DomainEnd , &
521 MemoryStart , MemoryEnd , &
522 PatchStart , PatchEnd )
523 chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
524 (PatchEnd(3)-PatchStart(3)+1)*ftypesize
525
526 !write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName)
527 call add_to_bufsize_for_field( VarName, hdrbufsize )
528 icurs = icurs + hdrbufsize
529 ! If this is a real write (i.e. not a training write), accumulate
530 ! buffersize for this field.
531 IF ( DomainDesc .NE. 333933 ) THEN ! magic number
532 !write(0,*) 'X-1a', chunksize, TRIM(VarName)
533 call add_to_bufsize_for_field( VarName, chunksize )
534 icurs = icurs + chunksize
535 ENDIF
536 CASE DEFAULT
537 hdrbufsize = obuf(icurs/inttypesize)
538 write(VarName,'(I5.5)')vid
539 !write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName)
540 call add_to_bufsize_for_field( VarName, hdrbufsize )
541 icurs = icurs + hdrbufsize
542 vid = vid+1
543 END SELECT
544 ENDDO
545 ! Store the headers and field data in internal buffers. The first call to
546 ! store_piece_of_field() allocates internal buffers using sizes computed by
547 ! calls to add_to_bufsize_for_field().
548 vid = 0
549 icurs = inttypesize
550 DO WHILE ( icurs .lt. obufsize )
551 !write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize
552 SELECT CASE ( get_hdr_tag( obuf ( icurs / inttypesize ) ) )
553 CASE ( int_field )
554 CALL int_get_write_field_header ( obuf(icurs/inttypesize), hdrbufsize, itypesize, ftypesize, &
555 DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
556 DomainDesc , MemoryOrder , Stagger , DimNames , &
557 DomainStart , DomainEnd , &
558 MemoryStart , MemoryEnd , &
559 PatchStart , PatchEnd )
560 chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
561 (PatchEnd(3)-PatchStart(3)+1)*ftypesize
562
563
564 call store_piece_of_field( obuf(icurs/inttypesize), VarName, hdrbufsize )
565 !write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName)
566 icurs = icurs + hdrbufsize
567 ! If this is a real write (i.e. not a training write), store
568 ! this piece of this field.
569 IF ( DomainDesc .NE. 333933 ) THEN ! magic number
570 !write(0,*) 'A-1a', chunksize, TRIM(VarName)
571 call store_piece_of_field( obuf(icurs/inttypesize), VarName, chunksize )
572 icurs = icurs + chunksize
573 ENDIF
574 CASE DEFAULT
575 hdrbufsize = obuf(icurs/inttypesize)
576 write(VarName,'(I5.5)')vid
577 call store_piece_of_field( obuf(icurs/inttypesize), VarName, hdrbufsize )
578 !write(0,*) 'A-2', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName)
579 icurs = icurs + hdrbufsize
580 vid = vid+1
581 END SELECT
582 ENDDO
583
584 !call mpi_comm_size( mpi_comm_local, iii, ierr )
585 !write(0,*)'mpi_comm_size mpi_comm_local ',iii
586 !call mpi_comm_rank( mpi_comm_local, iii, ierr )
587 !write(0,*)'mpi_comm_rank mpi_comm_local ',iii
588
589 !write(0,*)'calling init_retrieve_pieces_of_field '
590 ! Now, for each field, retrieve headers and patches (data) from the internal
591 ! buffers and collect them all on the I/O quilt server "root" task.
592 CALL init_retrieve_pieces_of_field
593 ! Retrieve header and all patches for the first field from the internal
594 ! buffers.
595 CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
596 !write(0,*)'calling first retrieve_pieces_of_field ',TRIM(VarName),obufsize,sz,retval
597 ! Sum sizes of all headers and patches (data) for this field from all I/O
598 ! servers in this I/O server group onto the I/O server "root".
599 CALL MPI_Reduce( sz, bigbufsize, 1, MPI_INTEGER, &
600 MPI_SUM, ntasks_local_group-1, &
601 mpi_comm_local, ierr )
602 !write(0,*)'after MPI_Reduce ',sz, bigbufsize
603
604 ! Loop until there are no more fields to retrieve from the internal buffers.
605 DO WHILE ( retval )
606
607 !write(0,*)' VarName ',TRIM(VarName),' sz ',sz,' bigbufsize ',bigbufsize
608
609 ! I/O server "root" allocates space to collect headers and fields from all
610 ! other servers in this I/O server group.
611 IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN
612 !write(0,*)'allocating bufbuf ', (bigbufsize+1)/inttypesize
613 ALLOCATE( bigbuf( (bigbufsize+1)/inttypesize ) )
614 ENDIF
615
616 !write(0,*)'before collect_on_comm tag,size ',Trim(VarName),get_hdr_tag(obuf),get_hdr_rec_size(obuf)
617 ! Collect buffers and fields from all I/O servers in this I/O server group
618 ! onto the I/O server "root"
619 CALL collect_on_comm( mpi_comm_local, &
620 onebyte, &
621 obuf, sz, &
622 bigbuf, bigbufsize )
623 !write(0,*)'after collect_on_comm ', sz, bigbufsize
624 ! The I/O server "root" now handles collected requests from all compute
625 ! tasks served by this I/O server group (i.e. all compute tasks).
626 IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN
627 !jjj = 4
628 !do iii = 1, ntasks_local_group
629 ! write(0,*)'i,j,tag,size ', iii, jjj, get_hdr_tag(bigbuf(jjj/4)),get_hdr_rec_size(bigbuf(jjj/4))
630 ! jjj = jjj + get_hdr_rec_size(bigbuf(jjj/4))
631 !enddo
632
633 icurs = inttypesize ! icurs is a byte counter, but buffer is integer
634
635 stored_write_record = .false.
636
637 ! The I/O server "root" loops over the collected requests.
638 DO WHILE ( icurs .lt. bigbufsize )
639 CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr )
640
641 !write(0,*)'B tag,size ',icurs,get_hdr_tag( bigbuf(icurs/inttypesize) ),get_hdr_rec_size( bigbuf(icurs/inttypesize) )
642 !write(0,*)' inttypesize ',inttypesize,' itypesize ',itypesize,' icurs/inttypesize ',icurs/inttypesize
643 ! The I/O server "root" gets the request out of the next header and
644 ! handles it by, in most cases, calling the appropriate external I/O package
645 ! interface.
646 SELECT CASE ( get_hdr_tag( bigbuf(icurs/inttypesize) ) )
647 ! The I/O server "root" handles the "noop" (do nothing) request. This is
648 ! actually quite easy. "Noop" requests exist to help avoid race conditions.
649 ! In some cases, only one compute task will everything about a request so
650 ! other compute tasks send "noop" requests.
651 CASE ( int_noop )
652 !write(0,*)' int_noop '
653 CALL int_get_noop_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize )
654 icurs = icurs + hdrbufsize
655
656 ! The I/O server "root" handles the "put_dom_td_real" request.
657 CASE ( int_dom_td_real )
658 !write(0,*)' int_dom_td_real '
659 CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
660 ALLOCATE( RData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
661 CALL int_get_td_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, &
662 DataHandle, DateStr, Element, RData, Count, code )
663 icurs = icurs + hdrbufsize
664
665 SELECT CASE (use_package(io_form(DataHandle)))
666 #ifdef NETCDF
667 CASE ( IO_NETCDF )
668 CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
669 #endif
670 #ifdef INTIO
671 CASE ( IO_INTIO )
672 CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
673 #endif
674 #ifdef YYY
675 CASE ( IO_YYY )
676 CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
677 #endif
678 #ifdef GRIB1
679 CASE ( IO_GRIB1 )
680 CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
681 #endif
682 #ifdef GRIB2
683 CASE ( IO_GRIB2 )
684 CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
685 #endif
686 CASE DEFAULT
687 Status = 0
688 END SELECT
689
690 DEALLOCATE( RData )
691 ! The I/O server "root" handles the "put_dom_ti_real" request.
692 CASE ( int_dom_ti_real )
693 !write(0,*)' int_dom_ti_real '
694 CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
695 ALLOCATE( RData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
696 CALL int_get_ti_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, &
697 DataHandle, Element, RData, Count, code )
698 icurs = icurs + hdrbufsize
699
700 SELECT CASE (use_package(io_form(DataHandle)))
701 #ifdef NETCDF
702 CASE ( IO_NETCDF )
703 CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
704 !write(0,*)'ext_ncd_put_dom_ti_real ',handle(DataHandle),TRIM(Element),RData,Status
705 #endif
706 #ifdef INTIO
707 CASE ( IO_INTIO )
708 CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
709 #endif
710 #ifdef YYY
711 CASE ( IO_YYY )
712 CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
713 #endif
714 #ifdef GRIB1
715 CASE ( IO_GRIB1 )
716 CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
717 #endif
718 #ifdef GRIB2
719 CASE ( IO_GRIB2 )
720 CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
721 #endif
722 CASE DEFAULT
723 Status = 0
724 END SELECT
725
726 DEALLOCATE( RData )
727
728 ! The I/O server "root" handles the "put_dom_td_integer" request.
729 CASE ( int_dom_td_integer )
730 !write(0,*)' int_dom_td_integer '
731 CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
732 ALLOCATE( IData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
733 CALL int_get_td_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, &
734 DataHandle, DateStr, Element, IData, Count, code )
735 icurs = icurs + hdrbufsize
736
737 SELECT CASE (use_package(io_form(DataHandle)))
738 #ifdef NETCDF
739 CASE ( IO_NETCDF )
740 CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
741 #endif
742 #ifdef INTIO
743 CASE ( IO_INTIO )
744 CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
745 #endif
746 #ifdef YYY
747 CASE ( IO_YYY )
748 CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
749 #endif
750 #ifdef GRIB1
751 CASE ( IO_GRIB1 )
752 CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
753 #endif
754 #ifdef GRIB2
755 CASE ( IO_GRIB2 )
756 CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
757 #endif
758 CASE DEFAULT
759 Status = 0
760 END SELECT
761
762 DEALLOCATE( IData )
763
764 ! The I/O server "root" handles the "put_dom_ti_integer" request.
765 CASE ( int_dom_ti_integer )
766 !write(0,*)' int_dom_ti_integer '
767
768 CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
769 ALLOCATE( IData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
770 CALL int_get_ti_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, &
771 DataHandle, Element, IData, Count, code )
772 icurs = icurs + hdrbufsize
773 SELECT CASE (use_package(io_form(DataHandle)))
774 #ifdef NETCDF
775 CASE ( IO_NETCDF )
776 CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
777 !write(0,*)'ext_ncd_put_dom_ti_integer ',handle(DataHandle),TRIM(Element),IData,Status
778 #endif
779 #ifdef INTIO
780 CASE ( IO_INTIO )
781 CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
782 #endif
783 #ifdef YYY
784 CASE ( IO_YYY )
785 CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
786 #endif
787 #ifdef GRIB1
788 CASE ( IO_GRIB1 )
789 CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
790 #endif
791 #ifdef GRIB2
792 CASE ( IO_GRIB2 )
793 CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
794 #endif
795
796 CASE DEFAULT
797 Status = 0
798 END SELECT
799
800 DEALLOCATE( IData)
801
802 ! The I/O server "root" handles the "set_time" request.
803 CASE ( int_set_time )
804 !write(0,*)' int_set_time '
805 CALL int_get_ti_header_char( bigbuf(icurs/inttypesize), hdrbufsize, inttypesize, &
806 DataHandle, Element, VarName, CData, code )
807 SELECT CASE (use_package(io_form(DataHandle)))
808 #ifdef INTIO
809 CASE ( IO_INTIO )
810 CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status)
811 #endif
812 CASE DEFAULT
813 Status = 0
814 END SELECT
815
816 icurs = icurs + hdrbufsize
817
818 ! The I/O server "root" handles the "put_dom_ti_char" request.
819 CASE ( int_dom_ti_char )
820 !write(0,*)' before int_get_ti_header_char '
821 CALL int_get_ti_header_char( bigbuf(icurs/inttypesize), hdrbufsize, inttypesize, &
822 DataHandle, Element, VarName, CData, code )
823 !write(0,*)' after int_get_ti_header_char ',VarName
824
825 SELECT CASE (use_package(io_form(DataHandle)))
826 #ifdef NETCDF
827 CASE ( IO_NETCDF )
828 CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
829 #endif
830 #ifdef INTIO
831 CASE ( IO_INTIO )
832 CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
833 #endif
834 #ifdef YYY
835 CASE ( IO_YYY )
836 CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
837 #endif
838 #ifdef GRIB1
839 CASE ( IO_GRIB1 )
840 CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
841 #endif
842 #ifdef GRIB2
843 CASE ( IO_GRIB2 )
844 CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
845 #endif
846 CASE DEFAULT
847 Status = 0
848 END SELECT
849
850 icurs = icurs + hdrbufsize
851
852 ! The I/O server "root" handles the "put_var_ti_char" request.
853 CASE ( int_var_ti_char )
854 !write(0,*)' int_var_ti_char '
855 CALL int_get_ti_header_char( bigbuf(icurs/inttypesize), hdrbufsize, inttypesize, &
856 DataHandle, Element, VarName, CData, code )
857
858 SELECT CASE (use_package(io_form(DataHandle)))
859 #ifdef NETCDF
860 CASE ( IO_NETCDF )
861 CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
862 #endif
863 #ifdef INTIO
864 CASE ( IO_INTIO )
865 CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
866 #endif
867 #ifdef YYY
868 CASE ( IO_YYY )
869 CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
870 #endif
871 #ifdef GRIB1
872 CASE ( IO_GRIB1 )
873 CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
874 #endif
875 #ifdef GRIB2
876 CASE ( IO_GRIB2 )
877 CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
878 #endif
879 CASE DEFAULT
880 Status = 0
881 END SELECT
882
883 icurs = icurs + hdrbufsize
884
885 CASE ( int_ioexit )
886 ! ioexit is now handled by sending negative message length to server
887 CALL wrf_error_fatal( &
888 "quilt: should have handled int_ioexit already")
889 ! The I/O server "root" handles the "ioclose" request.
890 CASE ( int_ioclose )
891 CALL int_get_handle_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, &
892 DataHandle , code )
893 icurs = icurs + hdrbufsize
894
895 IF ( DataHandle .GE. 1 ) THEN
896 !JMDEBUGwrite(0,*)'closing DataHandle ',DataHandle
897
898 SELECT CASE (use_package(io_form(DataHandle)))
899 #ifdef NETCDF
900 CASE ( IO_NETCDF )
901 CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
902 IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
903 CALL ext_ncd_ioclose(handle(DataHandle),Status)
904 ENDIF
905 #endif
906 #ifdef INTIO
907 CASE ( IO_INTIO )
908 CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
909 IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
910 CALL ext_int_ioclose(handle(DataHandle),Status)
911 ENDIF
912 #endif
913 #ifdef YYY
914 CASE ( IO_YYY )
915 CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
916 IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
917 CALL ext_yyy_ioclose(handle(DataHandle),Status)
918 ENDIF
919 #endif
920 #ifdef GRIB1
921 CASE ( IO_GRIB1 )
922 CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
923 IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
924 CALL ext_gr1_ioclose(handle(DataHandle),Status)
925 ENDIF
926 #endif
927 #ifdef GRIB2
928 CASE ( IO_GRIB2 )
929 CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
930 IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
931 CALL ext_gr2_ioclose(handle(DataHandle),Status)
932 ENDIF
933 #endif
934 CASE DEFAULT
935 Status = 0
936 END SELECT
937 ENDIF
938
939 ! The I/O server "root" handles the "open_for_write_begin" request.
940 CASE ( int_open_for_write_begin )
941
942 CALL int_get_ofwb_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, &
943 FileName,SysDepInfo,io_form_arg,DataHandle )
944
945 !write(0,*)' int_open_for_write_begin inttypesize ',inttypesize,' itypesize ',itypesize
946 !write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize
947 !JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle
948 !write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo)
949 icurs = icurs + hdrbufsize
950 !write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/inttypesize) ),get_hdr_rec_size( bigbuf(icurs/inttypesize) )
951
952 io_form(DataHandle) = io_form_arg
953
954 SELECT CASE (use_package(io_form(DataHandle)))
955 #ifdef NETCDF
956 CASE ( IO_NETCDF )
957 CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
958 !write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status
959 #endif
960 #ifdef INTIO
961 CASE ( IO_INTIO )
962 CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
963 #endif
964 #ifdef YYY
965 CASE ( IO_YYY )
966 CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
967 #endif
968 #ifdef GRIB1
969 CASE ( IO_GRIB1 )
970 CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
971 #endif
972 #ifdef GRIB2
973 CASE ( IO_GRIB2 )
974 CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
975 #endif
976 CASE DEFAULT
977 Status = 0
978 END SELECT
979
980 okay_to_write(DataHandle) = .false.
981
982 ! The I/O server "root" handles the "open_for_write_commit" request.
983 ! In this case, the "okay_to_commit" is simply set to .true. so "write_field"
984 ! requests will initiate writes to disk. Actual commit will be done after
985 ! all requests in this batch have been handled.
986 CASE ( int_open_for_write_commit )
987
988 CALL int_get_handle_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, &
989 DataHandle , code )
990 !write(0,*)' int_open_for_write_commit icurs ', icurs, hdrbufsize
991 icurs = icurs + hdrbufsize
992 okay_to_commit(DataHandle) = .true.
993
994 ! The I/O server "root" handles the "write_field" (int_field) request.
995 ! If okay_to_write(DataHandle) is .true. then the patch in the
996 ! header (bigbuf) is written to a globally-sized internal output buffer via
997 ! the call to store_patch_in_outbuf(). Note that this is where the actual
998 ! "quilting" (reassembly of patches onto a full-size domain) is done. If
999 ! okay_to_write(DataHandle) is .false. then external I/O package interfaces
1000 ! are called to write metadata for I/O formats that support native metadata.
1001 !
1002 ! NOTE that the I/O server "root" will only see write_field (int_field)
1003 ! requests AFTER an "iosync" request.
1004 CASE ( int_field )
1005 !write(0,*)' int_field '
1006 CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
1007 CALL int_get_write_field_header ( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, ftypesize, &
1008 DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
1009 DomainDesc , MemoryOrder , Stagger , DimNames , &
1010 DomainStart , DomainEnd , &
1011 MemoryStart , MemoryEnd , &
1012 PatchStart , PatchEnd )
1013 icurs = icurs + hdrbufsize
1014
1015 IF ( okay_to_write(DataHandle) ) THEN
1016
1017 ! WRITE(*,*)'>>> ',TRIM(DateStr), ' ', TRIM(VarName), ' ', TRIM(MemoryOrder), ' ', &
1018 ! (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1)
1019
1020 IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN
1021 ! Note that the WRF_DOUBLE branch of this IF statement must come first since
1022 ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds.
1023 IF ( FieldType .EQ. WRF_DOUBLE) THEN
1024 ! this branch has not been tested TBH: 20050406
1025 CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr )
1026 ELSE
1027 CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
1028 ENDIF
1029 stored_write_record = .true.
1030 CALL store_patch_in_outbuf ( bigbuf(icurs/inttypesize), dummybuf, TRIM(DateStr), TRIM(VarName) , &
1031 FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, &
1032 DomainStart , DomainEnd , &
1033 MemoryStart , MemoryEnd , &
1034 PatchStart , PatchEnd )
1035
1036 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1037 CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
1038 stored_write_record = .true.
1039 CALL store_patch_in_outbuf ( dummybuf, bigbuf(icurs/inttypesize), TRIM(DateStr), TRIM(VarName) , &
1040 FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, &
1041 DomainStart , DomainEnd , &
1042 MemoryStart , MemoryEnd , &
1043 PatchStart , PatchEnd )
1044 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
1045 ftypesize = LWORDSIZE
1046 ENDIF
1047 icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
1048 (PatchEnd(3)-PatchStart(3)+1)*ftypesize
1049 ELSE
1050 SELECT CASE (use_package(io_form(DataHandle)))
1051 #ifdef NETCDF
1052 CASE ( IO_NETCDF )
1053 CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , &
1054 TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
1055 DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
1056 DomainStart , DomainEnd , &
1057 DomainStart , DomainEnd , &
1058 DomainStart , DomainEnd , &
1059 Status )
1060 #endif
1061 #if 0
1062 ! since this is training and the grib output doesn't need training, disable this branch.
1063 #ifdef YYY
1064 CASE ( IO_YYY )
1065 CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , &
1066 TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
1067 DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
1068 DomainStart , DomainEnd , &
1069 DomainStart , DomainEnd , &
1070 DomainStart , DomainEnd , &
1071 Status )
1072 #endif
1073 #endif
1074 CASE DEFAULT
1075 Status = 0
1076 END SELECT
1077 ENDIF
1078 CASE ( int_iosync )
1079 !write(0,*)' int_iosync '
1080 CALL int_get_handle_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, &
1081 DataHandle , code )
1082 icurs = icurs + hdrbufsize
1083 CASE DEFAULT
1084 WRITE(mess,*)'quilt: bad tag: ',get_hdr_tag( bigbuf(icurs/inttypesize) ),' icurs ',icurs/inttypesize
1085 CALL wrf_error_fatal( mess )
1086 END SELECT
1087
1088 ENDDO
1089 ! Now, the I/O server "root" has finshed handling all commands from the latest
1090 ! call to retrieve_pieces_of_field().
1091
1092 IF (stored_write_record) THEN
1093 !write(0,*)'calling write_outbuf ',DataHandle
1094 ! If any fields have been stored in a globally-sized internal output buffer
1095 ! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write
1096 ! them to disk now.
1097 ! NOTE that the I/O server "root" will only have called
1098 ! store_patch_in_outbuf() when handling write_field (int_field)
1099 ! commands which only arrive AFTER an "iosync" command.
1100 !JMTIMING CALL start_timing
1101 CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle)))
1102 !JMTIMING CALL end_timing( "quilt: call to write_outbuf" )
1103 !write(0,*)'back from write_outbuf ',DataHandle
1104 ENDIF
1105
1106 ! If one or more "open_for_write_commit" commands were encountered from the
1107 ! latest call to retrieve_pieces_of_field() then call the package-specific
1108 ! routine to do the commit.
1109 IF (okay_to_commit(DataHandle)) THEN
1110
1111 SELECT CASE (use_package(io_form(DataHandle)))
1112 #ifdef NETCDF
1113 CASE ( IO_NETCDF )
1114 CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
1115 !write(0,*)'preparing to commit ', DataHandle, fstat, fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED
1116 IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
1117 !write(0,*)'calling ext_ncd_open_for_write_commit ', handle(DataHandle), DataHandle
1118 CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status)
1119 !write(0,*)'back from ext_ncd_open_for_write_commit ', Status
1120 okay_to_write(DataHandle) = .true.
1121 ENDIF
1122 #endif
1123 #ifdef INTIO
1124 CASE ( IO_INTIO )
1125 CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
1126 IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
1127 CALL ext_int_open_for_write_commit(handle(DataHandle),Status)
1128 okay_to_write(DataHandle) = .true.
1129 ENDIF
1130 #endif
1131 #ifdef YYY
1132 CASE ( IO_YYY )
1133 CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
1134 IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
1135 CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status)
1136 okay_to_write(DataHandle) = .true.
1137 ENDIF
1138 #endif
1139 #ifdef GRIB1
1140 CASE ( IO_GRIB1 )
1141 CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
1142 IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
1143 CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status)
1144 okay_to_write(DataHandle) = .true.
1145 ENDIF
1146 #endif
1147 #ifdef GRIB2
1148 CASE ( IO_GRIB2 )
1149 CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
1150 IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
1151 CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status)
1152 okay_to_write(DataHandle) = .true.
1153 ENDIF
1154 #endif
1155
1156 CASE DEFAULT
1157 Status = 0
1158 END SELECT
1159
1160 okay_to_commit(DataHandle) = .false.
1161 ENDIF
1162 DEALLOCATE( bigbuf )
1163 ENDIF
1164
1165 ! Retrieve header and all patches for the next field from the internal
1166 ! buffers.
1167 CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
1168 !write(0,*)'calling next retrieve_pieces_of_field ',trim(VarName),obufsize,sz,retval
1169 ! Sum sizes of all headers and patches (data) for this field from all I/O
1170 ! servers in this I/O server group onto the I/O server "root".
1171 CALL MPI_Reduce( sz, bigbufsize, 1, MPI_INTEGER, &
1172 MPI_SUM, ntasks_local_group-1, &
1173 mpi_comm_local, ierr )
1174 ! Then, return to the top of the loop to collect headers and data from all
1175 ! I/O servers in this I/O server group onto the I/O server "root" and handle
1176 ! the next batch of commands.
1177 !write(0,*)'after MPI_Reduce ',sz, bigbufsize
1178 END DO
1179
1180 DEALLOCATE( obuf )
1181
1182 ! flush output files if needed
1183 IF (stored_write_record) THEN
1184 !JMTIMING CALL start_timing
1185 SELECT CASE ( use_package(io_form) )
1186 #ifdef NETCDF
1187 CASE ( IO_NETCDF )
1188 CALL ext_ncd_iosync( handle(DataHandle), Status )
1189 #endif
1190 #ifdef XXX
1191 CASE ( IO_XXX )
1192 CALL ext_xxx_iosync( handle(DataHandle), Status )
1193 #endif
1194 #ifdef YYY
1195 CASE ( IO_YYY )
1196 CALL ext_yyy_iosync( handle(DataHandle), Status )
1197 #endif
1198 #ifdef ZZZ
1199 CASE ( IO_ZZZ )
1200 CALL ext_zzz_iosync( handle(DataHandle), Status )
1201 #endif
1202 #ifdef GRIB1
1203 CASE ( IO_GRIB1 )
1204 CALL ext_gr1_iosync( handle(DataHandle), Status )
1205 #endif
1206 #ifdef GRIB2
1207 CASE ( IO_GRIB2 )
1208 CALL ext_gr2_iosync( handle(DataHandle), Status )
1209 #endif
1210 #ifdef INTIO
1211 CASE ( IO_INTIO )
1212 CALL ext_int_iosync( handle(DataHandle), Status )
1213 #endif
1214 CASE DEFAULT
1215 Status = 0
1216 END SELECT
1217 !JMTIMING CALL end_timing( "quilt: flush" )
1218 ENDIF
1219
1220 END DO
1221
1222 END SUBROUTINE quilt
1223
1224 ! end of #endif of DM_PARALLEL
1225 #endif
1226
1227 SUBROUTINE init_module_wrf_quilt
1228 !<DESCRIPTION>
1229 ! Both client (compute) and server tasks call this routine to initialize the
1230 ! module. Routine setup_quilt_servers() is called from this routine to
1231 ! determine which tasks are compute tasks and which are server tasks. Server
1232 ! tasks then call routine quilt() and remain there for the rest of the model
1233 ! run. Compute tasks return from init_module_wrf_quilt() to perform model
1234 ! computations.
1235 !</DESCRIPTION>
1236 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1237 IMPLICIT NONE
1238 INCLUDE 'mpif.h'
1239 INTEGER i
1240 NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups
1241 INTEGER ntasks, mytask, ierr, io_status
1242 LOGICAL mpi_inited
1243
1244 quilting_enabled = .FALSE.
1245 IF ( disable_quilt ) RETURN
1246
1247 DO i = 1,int_num_handles
1248 okay_to_write(i) = .FALSE.
1249 int_handle_in_use(i) = .FALSE.
1250 server_for_handle(i) = 0
1251 int_num_bytes_to_write(i) = 0
1252 ENDDO
1253
1254 CALL MPI_INITIALIZED( mpi_inited, ierr )
1255 IF ( mpi_inited ) THEN
1256 CALL wrf_error_fatal("frame/module_io_quilt.F: quilt initialization "// &
1257 "must be called before MPI_Init") ;
1258 ENDIF
1259
1260 CALL mpi_init ( ierr )
1261 CALL wrf_set_dm_communicator( MPI_COMM_WORLD )
1262 CALL wrf_termio_dup
1263 CALL MPI_Comm_rank ( MPI_COMM_WORLD, mytask, ierr ) ;
1264 CALL mpi_x_comm_size ( MPI_COMM_WORLD, ntasks, ierr ) ;
1265
1266 IF ( mytask .EQ. 0 ) THEN
1267 OPEN ( unit=27, file="namelist.input", form="formatted", status="old" )
1268 nio_groups = 1
1269 nio_tasks_per_group = 0
1270 ! Not finding the namelist should not be an error. Hopes of folding this
1271 ! namelist into the Registry are complicated because this information is needed
1272 ! before MPI is fully set up.
1273 READ ( 27 , NML = namelist_quilt, IOSTAT=io_status )
1274 CLOSE ( 27 )
1275 ENDIF
1276 CALL mpi_bcast( nio_tasks_per_group , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD, ierr )
1277 CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD, ierr )
1278
1279 CALL setup_quilt_servers( nio_tasks_per_group, &
1280 mytask, &
1281 ntasks, &
1282 nio_groups, &
1283 nio_tasks_in_group, &
1284 MPI_COMM_WORLD, &
1285 mpi_comm_local, &
1286 mpi_comm_io_groups)
1287
1288 ! provide the communicator for the integration tasks to RSL
1289 IF ( mytask .lt. ncompute_tasks ) THEN
1290 CALL wrf_set_dm_communicator( mpi_comm_local )
1291 ELSE
1292 CALL quilt ! will not return on io server tasks
1293 ENDIF
1294 #endif
1295 RETURN
1296 END SUBROUTINE init_module_wrf_quilt
1297 END MODULE module_wrf_quilt
1298
1299 !<DESCRIPTION>
1300 ! Remaining routines in this file are defined outside of the module
1301 ! either to defeat arg/param type checking or to avoid an explicit use
1302 ! dependence.
1303 !</DESCRIPTION>
1304
1305 SUBROUTINE disable_quilting
1306 !<DESCRIPTION>
1307 ! Call this in programs that you never want to be quilting (e.g. real)
1308 ! Must call before call to init_module_wrf_quilt().
1309 !</DESCRIPTION>
1310 USE module_wrf_quilt
1311 disable_quilt = .TRUE.
1312 RETURN
1313 END SUBROUTINE disable_quilting
1314
1315 LOGICAL FUNCTION use_output_servers()
1316 !<DESCRIPTION>
1317 ! Returns .TRUE. if I/O quilt servers are in-use for write operations.
1318 ! This routine is called only by client (compute) tasks.
1319 !</DESCRIPTION>
1320 USE module_wrf_quilt
1321 use_output_servers = quilting_enabled
1322 RETURN
1323 END FUNCTION use_output_servers
1324
1325 LOGICAL FUNCTION use_input_servers()
1326 !<DESCRIPTION>
1327 ! Returns .TRUE. if I/O quilt servers are in-use for read operations.
1328 ! This routine is called only by client (compute) tasks.
1329 !</DESCRIPTION>
1330 USE module_wrf_quilt
1331 use_input_servers = .FALSE.
1332 RETURN
1333 END FUNCTION use_input_servers
1334
1335 SUBROUTINE wrf_quilt_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
1336 DataHandle , io_form_arg, Status )
1337 !<DESCRIPTION>
1338 ! Instruct the I/O quilt servers to begin data definition ("training") phase
1339 ! for writing to WRF dataset FileName. io_form_arg indicates file format.
1340 ! This routine is called only by client (compute) tasks.
1341 !</DESCRIPTION>
1342 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1343 USE module_wrf_quilt
1344 IMPLICIT NONE
1345 INCLUDE 'mpif.h'
1346 #include "intio_tags.h"
1347 CHARACTER *(*), INTENT(IN) :: FileName
1348 INTEGER , INTENT(IN) :: Comm_compute , Comm_io
1349 CHARACTER *(*), INTENT(IN) :: SysDepInfo
1350 INTEGER , INTENT(OUT) :: DataHandle
1351 INTEGER , INTENT(IN) :: io_form_arg
1352 INTEGER , INTENT(OUT) :: Status
1353 ! Local
1354 CHARACTER*132 :: locFileName, locSysDepInfo
1355 INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
1356 REAL dummy
1357
1358 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_begin' )
1359 CALL int_get_fresh_handle(i)
1360 okay_to_write(i) = .false.
1361 DataHandle = i
1362
1363 locFileName = FileName
1364 locSysDepInfo = SysDepInfo
1365
1366 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
1367 IF ( wrf_dm_on_monitor() ) THEN
1368 CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
1369 locFileName,locSysDepInfo,io_form_arg,DataHandle )
1370 ELSE
1371 CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
1372 ENDIF
1373
1374 iserver = get_server_id ( DataHandle )
1375 !JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin iserver = ', iserver
1376 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
1377 !JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin comm_io_group = ', comm_io_group
1378
1379 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
1380 !JMDEBUGwrite(0,*)'mpi_x_comm_size tasks_in_group ',tasks_in_group, ierr
1381
1382 !JMTIMING CALL start_timing
1383 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
1384 reduced = 0
1385 reduced(1) = hdrbufsize
1386 IF ( wrf_dm_on_monitor() ) reduced(2) = i
1387 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
1388 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
1389 comm_io_group, ierr )
1390 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_begin")
1391
1392 ! send data to the i/o processor
1393 CALL collect_on_comm( comm_io_group, &
1394 onebyte, &
1395 hdrbuf, hdrbufsize , &
1396 dummy, 0 )
1397
1398 Status = 0
1399
1400
1401 #endif
1402 RETURN
1403 END SUBROUTINE wrf_quilt_open_for_write_begin
1404
1405 SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status )
1406 !<DESCRIPTION>
1407 ! Instruct the I/O quilt servers to switch an internal flag to enable output
1408 ! for the dataset referenced by DataHandle. The call to
1409 ! wrf_quilt_open_for_write_commit() must be paired with a call to
1410 ! wrf_quilt_open_for_write_begin().
1411 ! This routine is called only by client (compute) tasks.
1412 !</DESCRIPTION>
1413 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1414 USE module_wrf_quilt
1415 IMPLICIT NONE
1416 INCLUDE 'mpif.h'
1417 #include "intio_tags.h"
1418 INTEGER , INTENT(IN ) :: DataHandle
1419 INTEGER , INTENT(OUT) :: Status
1420 INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
1421 REAL dummy
1422
1423 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_commit' )
1424 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
1425 IF ( int_handle_in_use( DataHandle ) ) THEN
1426 okay_to_write( DataHandle ) = .true.
1427 ENDIF
1428 ENDIF
1429
1430 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
1431 CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
1432 DataHandle, int_open_for_write_commit )
1433
1434 iserver = get_server_id ( DataHandle )
1435 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
1436
1437 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
1438
1439 !JMTIMING CALL start_timing
1440 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
1441 reduced = 0
1442 reduced(1) = hdrbufsize
1443 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
1444 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
1445 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
1446 comm_io_group, ierr )
1447 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_commit")
1448
1449 ! send data to the i/o processor
1450 CALL collect_on_comm( comm_io_group, &
1451 onebyte, &
1452 hdrbuf, hdrbufsize , &
1453 dummy, 0 )
1454
1455 Status = 0
1456
1457 #endif
1458 RETURN
1459 END SUBROUTINE wrf_quilt_open_for_write_commit
1460
1461 SUBROUTINE wrf_quilt_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
1462 DataHandle , Status )
1463 !<DESCRIPTION>
1464 ! Instruct the I/O quilt servers to open WRF dataset FileName for reading.
1465 ! This routine is called only by client (compute) tasks.
1466 ! This is not yet supported.
1467 !</DESCRIPTION>
1468 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1469 IMPLICIT NONE
1470 CHARACTER *(*), INTENT(IN) :: FileName
1471 INTEGER , INTENT(IN) :: Comm_compute , Comm_io
1472 CHARACTER *(*), INTENT(IN) :: SysDepInfo
1473 INTEGER , INTENT(OUT) :: DataHandle
1474 INTEGER , INTENT(OUT) :: Status
1475
1476 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_read' )
1477 DataHandle = -1
1478 Status = -1
1479 CALL wrf_error_fatal ( "frame/module_io_quilt.F: wrf_quilt_open_for_read not yet supported" )
1480 #endif
1481 RETURN
1482 END SUBROUTINE wrf_quilt_open_for_read
1483
1484 SUBROUTINE wrf_quilt_inquire_opened ( DataHandle, FileName , FileStatus, Status )
1485 !<DESCRIPTION>
1486 ! Inquire if the dataset referenced by DataHandle is open.
1487 ! Does not require communication with I/O servers.
1488 ! This routine is called only by client (compute) tasks.
1489 !</DESCRIPTION>
1490 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1491 USE module_wrf_quilt
1492 IMPLICIT NONE
1493 #include "wrf_io_flags.h"
1494 INTEGER , INTENT(IN) :: DataHandle
1495 CHARACTER *(*), INTENT(IN) :: FileName
1496 INTEGER , INTENT(OUT) :: FileStatus
1497 INTEGER , INTENT(OUT) :: Status
1498
1499 Status = 0
1500
1501 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_opened' )
1502 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
1503 IF ( int_handle_in_use( DataHandle ) ) THEN
1504 IF ( okay_to_write( DataHandle ) ) THEN
1505 FileStatus = WRF_FILE_OPENED_FOR_WRITE
1506 ENDIF
1507 ENDIF
1508 ENDIF
1509 Status = 0
1510
1511 #endif
1512 RETURN
1513 END SUBROUTINE wrf_quilt_inquire_opened
1514
1515 SUBROUTINE wrf_quilt_inquire_filename ( DataHandle, FileName , FileStatus, Status )
1516 !<DESCRIPTION>
1517 ! Return the Filename and FileStatus associated with DataHandle.
1518 ! Does not require communication with I/O servers.
1519 !
1520 ! Note that the current implementation does not actually return FileName.
1521 ! Currenlty, WRF does not use this returned value. Fixing this would simply
1522 ! require saving the file names on the client tasks in an array similar to
1523 ! okay_to_write().
1524 ! This routine is called only by client (compute) tasks.
1525 !</DESCRIPTION>
1526 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1527 USE module_wrf_quilt
1528 IMPLICIT NONE
1529 #include "wrf_io_flags.h"
1530 INTEGER , INTENT(IN) :: DataHandle
1531 CHARACTER *(*), INTENT(OUT) :: FileName
1532 INTEGER , INTENT(OUT) :: FileStatus
1533 INTEGER , INTENT(OUT) :: Status
1534 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_filename' )
1535 Status = 0
1536 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
1537 IF ( int_handle_in_use( DataHandle ) ) THEN
1538 IF ( okay_to_write( DataHandle ) ) THEN
1539 FileStatus = WRF_FILE_OPENED_FOR_WRITE
1540 ELSE
1541 FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
1542 ENDIF
1543 ELSE
1544 FileStatus = WRF_FILE_NOT_OPENED
1545 ENDIF
1546 Status = 0
1547 FileName = "bogusfornow"
1548 ELSE
1549 Status = -1
1550 ENDIF
1551 #endif
1552 RETURN
1553 END SUBROUTINE wrf_quilt_inquire_filename
1554
1555 SUBROUTINE wrf_quilt_iosync ( DataHandle, Status )
1556 !<DESCRIPTION>
1557 ! Instruct the I/O quilt servers to synchronize the disk copy of a dataset
1558 ! with memory buffers.
1559 !
1560 ! After the "iosync" header (request) is sent to the I/O quilt server,
1561 ! the compute tasks will then send the entire contents (headers and data) of
1562 ! int_local_output_buffer to their I/O quilt server. This communication is
1563 ! done in subroutine send_to_io_quilt_servers(). After the I/O quilt servers
1564 ! receive this data, they will write all accumulated fields to disk.
1565 !
1566 ! Significant time may be required for the I/O quilt servers to organize
1567 ! fields and write them to disk. Therefore, the "iosync" request should be
1568 ! sent only when the compute tasks are ready to run for a while without
1569 ! needing to communicate with the servers. Otherwise, the compute tasks
1570 ! will end up waiting for the servers to finish writing to disk, thus wasting
1571 ! any performance benefits of having servers at all.
1572 !
1573 ! This routine is called only by client (compute) tasks.
1574 !</DESCRIPTION>
1575 #if defined( DM_PARALLEL ) && ! defined (STUBMPI)
1576 USE module_wrf_quilt
1577 IMPLICIT NONE
1578 include "mpif.h"
1579 INTEGER , INTENT(IN) :: DataHandle
1580 INTEGER , INTENT(OUT) :: Status
1581
1582 INTEGER locsize , inttypesize
1583 INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
1584
1585 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' )
1586
1587 !JMTIMING CALL start_timing
1588 IF ( associated ( int_local_output_buffer ) ) THEN
1589
1590 iserver = get_server_id ( DataHandle )
1591 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
1592
1593 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
1594
1595 locsize = int_num_bytes_to_write(DataHandle)
1596
1597 !JMTIMING CALL start_timing
1598 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
1599 reduced = 0
1600 reduced(1) = locsize
1601 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
1602 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
1603 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
1604 comm_io_group, ierr )
1605 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_iosync")
1606
1607 ! send data to the i/o processor
1608 #ifdef DEREF_KLUDGE
1609 CALL collect_on_comm( comm_io_group, &
1610 onebyte, &
1611 int_local_output_buffer(1), locsize , &
1612 dummy, 0 )
1613 #else
1614 CALL collect_on_comm( comm_io_group, &
1615 onebyte, &
1616 int_local_output_buffer, locsize , &
1617 dummy, 0 )
1618 #endif
1619
1620
1621 int_local_output_cursor = 1
1622 ! int_num_bytes_to_write(DataHandle) = 0
1623 DEALLOCATE ( int_local_output_buffer )
1624 NULLIFY ( int_local_output_buffer )
1625 ELSE
1626 CALL wrf_message ("frame/module_io_quilt.F: wrf_quilt_iosync: no buffer allocated")
1627 ENDIF
1628 !JMTIMING CALL end_timing("wrf_quilt_iosync")
1629 Status = 0
1630 #endif
1631 RETURN
1632 END SUBROUTINE wrf_quilt_iosync
1633
1634 SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status )
1635 !<DESCRIPTION>
1636 ! Instruct the I/O quilt servers to close the dataset referenced by
1637 ! DataHandle.
1638 ! This routine also clears the client file handle and, if needed, deallocates
1639 ! int_local_output_buffer.
1640 ! This routine is called only by client (compute) tasks.
1641 !</DESCRIPTION>
1642 #if defined( DM_PARALLEL ) && ! defined( STUBMPI)
1643 USE module_wrf_quilt
1644 USE module_timing
1645 IMPLICIT NONE
1646 INCLUDE 'mpif.h'
1647 #include "intio_tags.h"
1648 INTEGER , INTENT(IN) :: DataHandle
1649 INTEGER , INTENT(OUT) :: Status
1650 INTEGER i, itypesize, tasks_in_group, comm_io_group, ierr
1651 REAL dummy
1652
1653 !JMTIMING CALL start_timing
1654 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioclose' )
1655 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
1656
1657 IF ( wrf_dm_on_monitor() ) THEN
1658 CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
1659 DataHandle , int_ioclose )
1660 ELSE
1661 CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
1662 ENDIF
1663
1664 iserver = get_server_id ( DataHandle )
1665 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
1666
1667 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
1668
1669 !JMTIMING CALL start_timing
1670 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
1671 reduced = 0
1672 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
1673 !JMDEBUGwrite(0,*)'before MPI_Reduce in ioclose: reduced ', reduced
1674 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
1675 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
1676 comm_io_group, ierr )
1677 !JMTIMING CALL end_timing("MPI_Reduce in ioclose")
1678
1679 #if 0
1680 ! send data to the i/o processor
1681 !JMTIMING CALL start_timing
1682 CALL collect_on_comm( comm_io_group, &
1683 onebyte, &
1684 hdrbuf, hdrbufsize , &
1685 dummy, 0 )
1686 !JMTIMING CALL end_timing("collect_on_comm in io_close")
1687 #endif
1688
1689 int_handle_in_use(DataHandle) = .false.
1690 CALL set_server_id( DataHandle, 0 )
1691 okay_to_write(DataHandle) = .false.
1692 okay_to_commit(DataHandle) = .false.
1693 int_local_output_cursor = 1
1694 int_num_bytes_to_write(DataHandle) = 0
1695 IF ( associated ( int_local_output_buffer ) ) THEN
1696 DEALLOCATE ( int_local_output_buffer )
1697 NULLIFY ( int_local_output_buffer )
1698 ENDIF
1699
1700 Status = 0
1701 !JMTIMING CALL end_timing( "wrf_quilt_ioclose" )
1702
1703 #endif
1704 RETURN
1705 END SUBROUTINE wrf_quilt_ioclose
1706
1707 SUBROUTINE wrf_quilt_ioexit( Status )
1708 !<DESCRIPTION>
1709 ! Instruct the I/O quilt servers to shut down the WRF I/O system.
1710 ! Do not call any wrf_quilt_*() routines after this routine has been called.
1711 ! This routine is called only by client (compute) tasks.
1712 !</DESCRIPTION>
1713 #if defined( DM_PARALLEL ) && ! defined (STUBMPI )
1714 USE module_wrf_quilt
1715 IMPLICIT NONE
1716 INCLUDE 'mpif.h'
1717 #include "intio_tags.h"
1718 INTEGER , INTENT(OUT) :: Status
1719 INTEGER :: DataHandle
1720 INTEGER i, itypesize, tasks_in_group, comm_io_group, me, ierr
1721 REAL dummy
1722
1723 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioexit' )
1724 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
1725
1726 IF ( wrf_dm_on_monitor() ) THEN
1727 CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
1728 DataHandle , int_ioexit ) ! Handle is dummy
1729 ELSE
1730 CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
1731 ENDIF
1732
1733 DO iserver = 1, nio_groups
1734 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
1735
1736 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
1737 CALL mpi_comm_rank( comm_io_group , me , ierr )
1738
1739 ! BY SENDING A NEGATIVE SIZE WE GET THE SERVERS TO SHUT DOWN
1740 hdrbufsize = -100
1741 reduced = 0
1742 IF ( me .eq. 0 ) reduced(1) = hdrbufsize
1743 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
1744 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
1745 comm_io_group, ierr )
1746
1747 ENDDO
1748 Status = 0
1749
1750 #endif
1751 RETURN
1752 END SUBROUTINE wrf_quilt_ioexit
1753
1754 SUBROUTINE wrf_quilt_get_next_time ( DataHandle, DateStr, Status )
1755 !<DESCRIPTION>
1756 ! Instruct the I/O quilt servers to return the next time stamp.
1757 ! This is not yet supported.
1758 ! This routine is called only by client (compute) tasks.
1759 !</DESCRIPTION>
1760 #if defined( DM_PARALLEL ) && ! defined (STUBMPI)
1761 IMPLICIT NONE
1762 INTEGER , INTENT(IN) :: DataHandle
1763 CHARACTER*(*) :: DateStr
1764 INTEGER :: Status
1765 #endif
1766 RETURN
1767 END SUBROUTINE wrf_quilt_get_next_time
1768
1769 SUBROUTINE wrf_quilt_get_previous_time ( DataHandle, DateStr, Status )
1770 !<DESCRIPTION>
1771 ! Instruct the I/O quilt servers to return the previous time stamp.
1772 ! This is not yet supported.
1773 ! This routine is called only by client (compute) tasks.
1774 !</DESCRIPTION>
1775 #if defined( DM_PARALLEL ) && ! defined (STUBMPI)
1776 IMPLICIT NONE
1777 INTEGER , INTENT(IN) :: DataHandle
1778 CHARACTER*(*) :: DateStr
1779 INTEGER :: Status
1780 #endif
1781 RETURN
1782 END SUBROUTINE wrf_quilt_get_previous_time
1783
1784 SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status )
1785 !<DESCRIPTION>
1786 ! Instruct the I/O quilt servers to set the time stamp in the dataset
1787 ! referenced by DataHandle.
1788 ! This routine is called only by client (compute) tasks.
1789 !</DESCRIPTION>
1790 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1791 USE module_wrf_quilt
1792 IMPLICIT NONE
1793 INCLUDE 'mpif.h'
1794 #include "intio_tags.h"
1795 INTEGER , INTENT(IN) :: DataHandle
1796 CHARACTER*(*) , INTENT(IN) :: Data
1797 INTEGER :: Status
1798 INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
1799 REAL dummy
1800 INTEGER :: Count
1801 !
1802 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_set_time' )
1803
1804 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
1805 IF ( int_handle_in_use( DataHandle ) ) THEN
1806 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
1807 Count = 0 ! there is no count for character strings
1808 CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
1809 DataHandle, "TIMESTAMP", "", Data, int_set_time )
1810 iserver = get_server_id ( DataHandle )
1811 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
1812 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
1813
1814 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
1815 reduced = 0
1816 reduced(1) = hdrbufsize
1817 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
1818 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
1819 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
1820 comm_io_group, ierr )
1821 ! send data to the i/o processor
1822 CALL collect_on_comm( comm_io_group, &
1823 onebyte, &
1824 hdrbuf, hdrbufsize , &
1825 dummy, 0 )
1826 ENDIF
1827 ENDIF
1828
1829 #endif
1830 RETURN
1831 END SUBROUTINE wrf_quilt_set_time
1832
1833 SUBROUTINE wrf_quilt_get_next_var ( DataHandle, VarName, Status )
1834 !<DESCRIPTION>
1835 ! When reading, instruct the I/O quilt servers to return the name of the next
1836 ! variable in the current time frame.
1837 ! This is not yet supported.
1838 ! This routine is called only by client (compute) tasks.
1839 !</DESCRIPTION>
1840 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1841 IMPLICIT NONE
1842 INTEGER , INTENT(IN) :: DataHandle
1843 CHARACTER*(*) :: VarName
1844 INTEGER :: Status
1845 #endif
1846 RETURN
1847 END SUBROUTINE wrf_quilt_get_next_var
1848
1849 SUBROUTINE wrf_quilt_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status )
1850 !<DESCRIPTION>
1851 ! Instruct the I/O quilt servers to attempt to read Count words of time
1852 ! independent domain metadata named "Element"
1853 ! from the open dataset described by DataHandle.
1854 ! Metadata of type real are
1855 ! stored in array Data.
1856 ! Actual number of words read is returned in OutCount.
1857 ! This routine is called only by client (compute) tasks.
1858
1859 ! This is not yet supported.
1860 !</DESCRIPTION>
1861 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1862 IMPLICIT NONE
1863 INTEGER , INTENT(IN) :: DataHandle
1864 CHARACTER*(*) , INTENT(IN) :: Element
1865 REAL, INTENT(IN) :: Data(*)
1866 INTEGER , INTENT(IN) :: Count
1867 INTEGER :: Outcount
1868 INTEGER :: Status
1869 CALL wrf_message('wrf_quilt_get_dom_ti_real not supported yet')
1870 #endif
1871 RETURN
1872 END SUBROUTINE wrf_quilt_get_dom_ti_real
1873
1874 SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Status )
1875 !<DESCRIPTION>
1876 ! Instruct the I/O quilt servers to write Count words of time independent
1877 ! domain metadata named "Element"
1878 ! to the open dataset described by DataHandle.
1879 ! Metadata of type real are
1880 ! copied from array Data.
1881 ! This routine is called only by client (compute) tasks.
1882 !</DESCRIPTION>
1883 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1884 USE module_wrf_quilt
1885 IMPLICIT NONE
1886 INCLUDE 'mpif.h'
1887 #include "intio_tags.h"
1888 INTEGER , INTENT(IN) :: DataHandle
1889 CHARACTER*(*) , INTENT(IN) :: Element
1890 real , INTENT(IN) :: Data(*)
1891 INTEGER , INTENT(IN) :: Count
1892 INTEGER :: Status
1893 !Local
1894 CHARACTER*132 :: locElement
1895 INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group
1896 REAL dummy
1897 !
1898 !JMTIMING CALL start_timing
1899 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_real' )
1900 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
1901 locElement = Element
1902
1903 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
1904 IF ( int_handle_in_use( DataHandle ) ) THEN
1905 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
1906 CALL MPI_TYPE_SIZE( MPI_REAL, typesize, ierr )
1907 IF ( wrf_dm_on_monitor() ) THEN
1908 CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
1909 DataHandle, locElement, Data, Count, int_dom_ti_real )
1910 ELSE
1911 CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
1912 ENDIF
1913 iserver = get_server_id ( DataHandle )
1914 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
1915 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
1916
1917 !JMTIMING CALL start_timing
1918 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
1919 reduced = 0
1920 reduced(1) = hdrbufsize
1921 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
1922 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
1923 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
1924 comm_io_group, ierr )
1925 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_real")
1926 ! send data to the i/o processor
1927 CALL collect_on_comm( comm_io_group, &
1928 onebyte, &
1929 hdrbuf, hdrbufsize , &
1930 dummy, 0 )
1931 ENDIF
1932 ENDIF
1933
1934 Status = 0
1935 !JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_real")
1936 #endif
1937 RETURN
1938 END SUBROUTINE wrf_quilt_put_dom_ti_real
1939
1940 SUBROUTINE wrf_quilt_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status )
1941 !<DESCRIPTION>
1942 ! Instruct the I/O quilt servers to attempt to read Count words of time
1943 ! independent domain metadata named "Element"
1944 ! from the open dataset described by DataHandle.
1945 ! Metadata of type double are
1946 ! stored in array Data.
1947 ! Actual number of words read is returned in OutCount.
1948 ! This routine is called only by client (compute) tasks.
1949 !
1950 ! This is not yet supported.
1951 !</DESCRIPTION>
1952 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1953 IMPLICIT NONE
1954 INTEGER , INTENT(IN) :: DataHandle
1955 CHARACTER*(*) , INTENT(IN) :: Element
1956 real*8 :: Data(*)
1957 INTEGER , INTENT(IN) :: Count
1958 INTEGER :: OutCount
1959 INTEGER :: Status
1960 CALL wrf_error_fatal('wrf_quilt_get_dom_ti_double not supported yet')
1961 #endif
1962 RETURN
1963 END SUBROUTINE wrf_quilt_get_dom_ti_double
1964
1965 SUBROUTINE wrf_quilt_put_dom_ti_double ( DataHandle,Element, Data, Count, Status )
1966 !<DESCRIPTION>
1967 ! Instruct the I/O quilt servers to write Count words of time independent
1968 ! domain metadata named "Element"
1969 ! to the open dataset described by DataHandle.
1970 ! Metadata of type double are
1971 ! copied from array Data.
1972 ! This routine is called only by client (compute) tasks.
1973 !
1974 ! This is not yet supported.
1975 !</DESCRIPTION>
1976 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
1977 IMPLICIT NONE
1978 INTEGER , INTENT(IN) :: DataHandle
1979 CHARACTER*(*) , INTENT(IN) :: Element
1980 real*8 , INTENT(IN) :: Data(*)
1981 INTEGER , INTENT(IN) :: Count
1982 INTEGER :: Status
1983 CALL wrf_error_fatal('wrf_quilt_put_dom_ti_double not supported yet')
1984 #endif
1985 RETURN
1986 END SUBROUTINE wrf_quilt_put_dom_ti_double
1987
1988 SUBROUTINE wrf_quilt_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status )
1989 !<DESCRIPTION>
1990 ! Instruct the I/O quilt servers to attempt to read Count words of time
1991 ! independent domain metadata named "Element"
1992 ! from the open dataset described by DataHandle.
1993 ! Metadata of type integer are
1994 ! stored in array Data.
1995 ! Actual number of words read is returned in OutCount.
1996 ! This routine is called only by client (compute) tasks.
1997 !
1998 ! This is not yet supported.
1999 !</DESCRIPTION>
2000 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2001 IMPLICIT NONE
2002 INTEGER , INTENT(IN) :: DataHandle
2003 CHARACTER*(*) , INTENT(IN) :: Element
2004 integer :: Data(*)
2005 INTEGER , INTENT(IN) :: Count
2006 INTEGER :: OutCount
2007 INTEGER :: Status
2008 CALL wrf_message('wrf_quilt_get_dom_ti_integer not supported yet')
2009 #endif
2010 RETURN
2011 END SUBROUTINE wrf_quilt_get_dom_ti_integer
2012
2013 SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status )
2014 !<DESCRIPTION>
2015 ! Instruct the I/O quilt servers to write Count words of time independent
2016 ! domain metadata named "Element"
2017 ! to the open dataset described by DataHandle.
2018 ! Metadata of type integer are
2019 ! copied from array Data.
2020 ! This routine is called only by client (compute) tasks.
2021 !</DESCRIPTION>
2022 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2023 USE module_wrf_quilt
2024 IMPLICIT NONE
2025 INCLUDE 'mpif.h'
2026 #include "intio_tags.h"
2027 INTEGER , INTENT(IN) :: DataHandle
2028 CHARACTER*(*) , INTENT(IN) :: Element
2029 INTEGER , INTENT(IN) :: Data(*)
2030 INTEGER , INTENT(IN) :: Count
2031 INTEGER :: Status
2032 ! Local
2033 CHARACTER*132 :: locElement
2034 INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group
2035 REAL dummy
2036 !
2037
2038 !JMTIMING CALL start_timing
2039 locElement = Element
2040
2041 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_integer' )
2042
2043 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
2044 IF ( int_handle_in_use( DataHandle ) ) THEN
2045 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
2046 CALL MPI_TYPE_SIZE( MPI_INTEGER, typesize, ierr )
2047 IF ( wrf_dm_on_monitor() ) THEN
2048 CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
2049 DataHandle, locElement, Data, Count, int_dom_ti_integer )
2050 ELSE
2051 CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
2052 ENDIF
2053 iserver = get_server_id ( DataHandle )
2054 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
2055 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
2056
2057 !JMTIMING CALL start_timing
2058 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
2059 reduced = 0
2060 reduced(1) = hdrbufsize
2061 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
2062 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
2063 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
2064 comm_io_group, ierr )
2065
2066 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_integer")
2067 ! send data to the i/o processor
2068 CALL collect_on_comm( comm_io_group, &
2069 onebyte, &
2070 hdrbuf, hdrbufsize , &
2071 dummy, 0 )
2072 ENDIF
2073 ENDIF
2074 CALL wrf_debug ( DEBUG_LVL, 'returning from wrf_quilt_put_dom_ti_integer' )
2075 !JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_integer" )
2076
2077 #endif
2078 RETURN
2079 END SUBROUTINE wrf_quilt_put_dom_ti_integer
2080
2081 SUBROUTINE wrf_quilt_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status )
2082 !<DESCRIPTION>
2083 ! Instruct the I/O quilt servers to attempt to read Count words of time
2084 ! independent domain metadata named "Element"
2085 ! from the open dataset described by DataHandle.
2086 ! Metadata of type logical are
2087 ! stored in array Data.
2088 ! Actual number of words read is returned in OutCount.
2089 ! This routine is called only by client (compute) tasks.
2090 !
2091 ! This is not yet supported.
2092 !</DESCRIPTION>
2093 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2094 IMPLICIT NONE
2095 INTEGER , INTENT(IN) :: DataHandle
2096 CHARACTER*(*) , INTENT(IN) :: Element
2097 logical :: Data(*)
2098 INTEGER , INTENT(IN) :: Count
2099 INTEGER :: OutCount
2100 INTEGER :: Status
2101 ! CALL wrf_message('wrf_quilt_get_dom_ti_logical not supported yet')
2102 #endif
2103 RETURN
2104 END SUBROUTINE wrf_quilt_get_dom_ti_logical
2105
2106 SUBROUTINE wrf_quilt_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status )
2107 !<DESCRIPTION>
2108 ! Instruct the I/O quilt servers to write Count words of time independent
2109 ! domain metadata named "Element"
2110 ! to the open dataset described by DataHandle.
2111 ! Metadata of type logical are
2112 ! copied from array Data.
2113 ! This routine is called only by client (compute) tasks.
2114 !
2115 ! This is not yet supported.
2116 !</DESCRIPTION>
2117 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2118 IMPLICIT NONE
2119 INTEGER , INTENT(IN) :: DataHandle
2120 CHARACTER*(*) , INTENT(IN) :: Element
2121 logical , INTENT(IN) :: Data(*)
2122 INTEGER , INTENT(IN) :: Count
2123 INTEGER :: Status
2124 ! Local
2125 INTEGER i
2126 INTEGER one_or_zero(Count)
2127
2128 DO i = 1, Count
2129 IF ( Data(i) ) THEN
2130 one_or_zero(i) = 1
2131 ELSE
2132 one_or_zero(i) = 0
2133 ENDIF
2134 ENDDO
2135
2136 CALL wrf_quilt_put_dom_ti_integer ( DataHandle,Element, one_or_zero, Count, Status )
2137 #endif
2138 RETURN
2139 END SUBROUTINE wrf_quilt_put_dom_ti_logical
2140
2141 SUBROUTINE wrf_quilt_get_dom_ti_char ( DataHandle,Element, Data, Status )
2142 !<DESCRIPTION>
2143 ! Instruct the I/O quilt servers to attempt to read time independent
2144 ! domain metadata named "Element"
2145 ! from the open dataset described by DataHandle.
2146 ! Metadata of type char are
2147 ! stored in string Data.
2148 ! This routine is called only by client (compute) tasks.
2149 !
2150 ! This is not yet supported.
2151 !</DESCRIPTION>
2152 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2153 IMPLICIT NONE
2154 INTEGER , INTENT(IN) :: DataHandle
2155 CHARACTER*(*) , INTENT(IN) :: Element
2156 CHARACTER*(*) :: Data
2157 INTEGER :: Status
2158 CALL wrf_message('wrf_quilt_get_dom_ti_char not supported yet')
2159 #endif
2160 RETURN
2161 END SUBROUTINE wrf_quilt_get_dom_ti_char
2162
2163 SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status )
2164 !<DESCRIPTION>
2165 ! Instruct the I/O quilt servers to write time independent
2166 ! domain metadata named "Element"
2167 ! to the open dataset described by DataHandle.
2168 ! Metadata of type char are
2169 ! copied from string Data.
2170 ! This routine is called only by client (compute) tasks.
2171 !</DESCRIPTION>
2172 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2173 USE module_wrf_quilt
2174 IMPLICIT NONE
2175 INCLUDE 'mpif.h'
2176 #include "intio_tags.h"
2177 INTEGER , INTENT(IN) :: DataHandle
2178 CHARACTER*(*) , INTENT(IN) :: Element
2179 CHARACTER*(*) , INTENT(IN) :: Data
2180 INTEGER :: Status
2181 INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group, me
2182 REAL dummy
2183 !
2184 !JMTIMING CALL start_timing
2185 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_char' )
2186
2187 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
2188 IF ( int_handle_in_use( DataHandle ) ) THEN
2189 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
2190 IF ( wrf_dm_on_monitor() ) THEN
2191 CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
2192 DataHandle, Element, "", Data, int_dom_ti_char )
2193 ELSE
2194 CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
2195 ENDIF
2196 iserver = get_server_id ( DataHandle )
2197 ! write(0,*)'wrf_quilt_put_dom_ti_char ',iserver
2198 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
2199 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
2200 ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here)
2201 !JMTIMING! CALL start_timing
2202 !write(0,*)'calling MPI_Barrier'
2203 ! CALL MPI_Barrier( mpi_comm_local, ierr )
2204 !write(0,*)'back from MPI_Barrier'
2205 !JMTIMING! CALL end_timing("MPI_Barrier in wrf_quilt_put_dom_ti_char")
2206
2207 !JMTIMING CALL start_timing
2208 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
2209 reduced_dummy = 0
2210 reduced = 0
2211 reduced(1) = hdrbufsize
2212 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
2213
2214 !call mpi_comm_rank( comm_io_group , me, ierr )
2215 !write(0,*)'calling MPI_Reduce me and tasks_in_group and comm_io_group',me,tasks_in_group ,comm_io_group
2216
2217 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
2218 MPI_SUM, tasks_in_group-1, & ! nio_tasks_in_group-1 is me
2219 comm_io_group, ierr )
2220
2221 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_char")
2222 ! send data to the i/o processor
2223 !JMTIMING CALL start_timing
2224
2225 CALL collect_on_comm( comm_io_group, &
2226 onebyte, &
2227 hdrbuf, hdrbufsize , &
2228 dummy, 0 )
2229 !JMTIMING CALL end_timing("collect_on_comm in wrf_quilt_put_dom_ti_char")
2230 ENDIF
2231 ENDIF
2232 !JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char")
2233
2234 #endif
2235 RETURN
2236 END SUBROUTINE wrf_quilt_put_dom_ti_char
2237
2238 SUBROUTINE wrf_quilt_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
2239 !<DESCRIPTION>
2240 ! Instruct the I/O quilt servers to attempt to read Count words of time
2241 ! dependent domain metadata named "Element" valid at time DateStr
2242 ! from the open dataset described by DataHandle.
2243 ! Metadata of type real are
2244 ! stored in array Data.
2245 ! Actual number of words read is returned in OutCount.
2246 ! This routine is called only by client (compute) tasks.
2247 !
2248 ! This is not yet supported.
2249 !</DESCRIPTION>
2250 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2251 IMPLICIT NONE
2252 INTEGER , INTENT(IN) :: DataHandle
2253 CHARACTER*(*) , INTENT(IN) :: Element
2254 CHARACTER*(*) , INTENT(IN) :: DateStr
2255 real :: Data(*)
2256 INTEGER , INTENT(IN) :: Count
2257 INTEGER :: OutCount
2258 INTEGER :: Status
2259 #endif
2260 RETURN
2261 END SUBROUTINE wrf_quilt_get_dom_td_real
2262
2263 SUBROUTINE wrf_quilt_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status )
2264 !<DESCRIPTION>
2265 ! Instruct the I/O quilt servers to write Count words of time dependent
2266 ! domain metadata named "Element" valid at time DateStr
2267 ! to the open dataset described by DataHandle.
2268 ! Metadata of type real are
2269 ! copied from array Data.
2270 ! This routine is called only by client (compute) tasks.
2271 !
2272 ! This is not yet supported.
2273 !</DESCRIPTION>
2274 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2275 IMPLICIT NONE
2276 INTEGER , INTENT(IN) :: DataHandle
2277 CHARACTER*(*) , INTENT(IN) :: Element
2278 CHARACTER*(*) , INTENT(IN) :: DateStr
2279 real , INTENT(IN) :: Data(*)
2280 INTEGER , INTENT(IN) :: Count
2281 INTEGER :: Status
2282 #endif
2283 RETURN
2284 END SUBROUTINE wrf_quilt_put_dom_td_real
2285
2286 SUBROUTINE wrf_quilt_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
2287 !<DESCRIPTION>
2288 ! Instruct the I/O quilt servers to attempt to read Count words of time
2289 ! dependent domain metadata named "Element" valid at time DateStr
2290 ! from the open dataset described by DataHandle.
2291 ! Metadata of type double are
2292 ! stored in array Data.
2293 ! Actual number of words read is returned in OutCount.
2294 ! This routine is called only by client (compute) tasks.
2295 !
2296 ! This is not yet supported.
2297 !</DESCRIPTION>
2298 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2299 IMPLICIT NONE
2300 INTEGER , INTENT(IN) :: DataHandle
2301 CHARACTER*(*) , INTENT(IN) :: Element
2302 CHARACTER*(*) , INTENT(IN) :: DateStr
2303 real*8 :: Data(*)
2304 INTEGER , INTENT(IN) :: Count
2305 INTEGER :: OutCount
2306 INTEGER :: Status
2307 #endif
2308 CALL wrf_error_fatal('wrf_quilt_get_dom_td_double not supported yet')
2309 RETURN
2310 END SUBROUTINE wrf_quilt_get_dom_td_double
2311
2312 SUBROUTINE wrf_quilt_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status )
2313 !<DESCRIPTION>
2314 ! Instruct the I/O quilt servers to write Count words of time dependent
2315 ! domain metadata named "Element" valid at time DateStr
2316 ! to the open dataset described by DataHandle.
2317 ! Metadata of type double are
2318 ! copied from array Data.
2319 ! This routine is called only by client (compute) tasks.
2320 !
2321 ! This is not yet supported.
2322 !</DESCRIPTION>
2323 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2324 IMPLICIT NONE
2325 INTEGER , INTENT(IN) :: DataHandle
2326 CHARACTER*(*) , INTENT(IN) :: Element
2327 CHARACTER*(*) , INTENT(IN) :: DateStr
2328 real*8 , INTENT(IN) :: Data(*)
2329 INTEGER , INTENT(IN) :: Count
2330 INTEGER :: Status
2331 #endif
2332 CALL wrf_error_fatal('wrf_quilt_put_dom_td_double not supported yet')
2333 RETURN
2334 END SUBROUTINE wrf_quilt_put_dom_td_double
2335
2336 SUBROUTINE wrf_quilt_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
2337 !<DESCRIPTION>
2338 ! Instruct the I/O quilt servers to attempt to read Count words of time
2339 ! dependent domain metadata named "Element" valid at time DateStr
2340 ! from the open dataset described by DataHandle.
2341 ! Metadata of type integer are
2342 ! stored in array Data.
2343 ! Actual number of words read is returned in OutCount.
2344 ! This routine is called only by client (compute) tasks.
2345 !
2346 ! This is not yet supported.
2347 !</DESCRIPTION>
2348 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2349 IMPLICIT NONE
2350 INTEGER , INTENT(IN) :: DataHandle
2351 CHARACTER*(*) , INTENT(IN) :: Element
2352 CHARACTER*(*) , INTENT(IN) :: DateStr
2353 integer :: Data(*)
2354 INTEGER , INTENT(IN) :: Count
2355 INTEGER :: OutCount
2356 INTEGER :: Status
2357 #endif
2358 RETURN
2359 END SUBROUTINE wrf_quilt_get_dom_td_integer
2360
2361 SUBROUTINE wrf_quilt_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status )
2362 !<DESCRIPTION>
2363 ! Instruct the I/O quilt servers to write Count words of time dependent
2364 ! domain metadata named "Element" valid at time DateStr
2365 ! to the open dataset described by DataHandle.
2366 ! Metadata of type integer are
2367 ! copied from array Data.
2368 ! This routine is called only by client (compute) tasks.
2369 !
2370 ! This is not yet supported.
2371 !</DESCRIPTION>
2372 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2373 IMPLICIT NONE
2374 INTEGER , INTENT(IN) :: DataHandle
2375 CHARACTER*(*) , INTENT(IN) :: Element
2376 CHARACTER*(*) , INTENT(IN) :: DateStr
2377 integer , INTENT(IN) :: Data(*)
2378 INTEGER , INTENT(IN) :: Count
2379 INTEGER :: Status
2380 #endif
2381 RETURN
2382 END SUBROUTINE wrf_quilt_put_dom_td_integer
2383
2384 SUBROUTINE wrf_quilt_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
2385 !<DESCRIPTION>
2386 ! Instruct the I/O quilt servers to attempt to read Count words of time
2387 ! dependent domain metadata named "Element" valid at time DateStr
2388 ! from the open dataset described by DataHandle.
2389 ! Metadata of type logical are
2390 ! stored in array Data.
2391 ! Actual number of words read is returned in OutCount.
2392 ! This routine is called only by client (compute) tasks.
2393 !
2394 ! This is not yet supported.
2395 !</DESCRIPTION>
2396 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2397 IMPLICIT NONE
2398 INTEGER , INTENT(IN) :: DataHandle
2399 CHARACTER*(*) , INTENT(IN) :: Element
2400 CHARACTER*(*) , INTENT(IN) :: DateStr
2401 logical :: Data(*)
2402 INTEGER , INTENT(IN) :: Count
2403 INTEGER :: OutCount
2404 INTEGER :: Status
2405 #endif
2406 RETURN
2407 END SUBROUTINE wrf_quilt_get_dom_td_logical
2408
2409 SUBROUTINE wrf_quilt_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status )
2410 !<DESCRIPTION>
2411 ! Instruct the I/O quilt servers to write Count words of time dependent
2412 ! domain metadata named "Element" valid at time DateStr
2413 ! to the open dataset described by DataHandle.
2414 ! Metadata of type logical are
2415 ! copied from array Data.
2416 ! This routine is called only by client (compute) tasks.
2417 !
2418 ! This is not yet supported.
2419 !</DESCRIPTION>
2420 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2421 IMPLICIT NONE
2422 INTEGER , INTENT(IN) :: DataHandle
2423 CHARACTER*(*) , INTENT(IN) :: Element
2424 CHARACTER*(*) , INTENT(IN) :: DateStr
2425 logical , INTENT(IN) :: Data(*)
2426 INTEGER , INTENT(IN) :: Count
2427 INTEGER :: Status
2428 #endif
2429 RETURN
2430 END SUBROUTINE wrf_quilt_put_dom_td_logical
2431
2432 SUBROUTINE wrf_quilt_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status )
2433 !<DESCRIPTION>
2434 ! Instruct the I/O quilt servers to attempt to read time dependent
2435 ! domain metadata named "Element" valid at time DateStr
2436 ! from the open dataset described by DataHandle.
2437 ! Metadata of type char are
2438 ! stored in string Data.
2439 ! This routine is called only by client (compute) tasks.
2440 !
2441 ! This is not yet supported.
2442 !</DESCRIPTION>
2443 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2444 IMPLICIT NONE
2445 INTEGER , INTENT(IN) :: DataHandle
2446 CHARACTER*(*) , INTENT(IN) :: Element
2447 CHARACTER*(*) , INTENT(IN) :: DateStr
2448 CHARACTER*(*) :: Data
2449 INTEGER :: Status
2450 #endif
2451 RETURN
2452 END SUBROUTINE wrf_quilt_get_dom_td_char
2453
2454 SUBROUTINE wrf_quilt_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status )
2455 !<DESCRIPTION>
2456 ! Instruct $he I/O quilt servers to write time dependent
2457 ! domain metadata named "Element" valid at time DateStr
2458 ! to the open dataset described by DataHandle.
2459 ! Metadata of type char are
2460 ! copied from string Data.
2461 ! This routine is called only by client (compute) tasks.
2462 !
2463 ! This is not yet supported.
2464 !</DESCRIPTION>
2465 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2466 IMPLICIT NONE
2467 INTEGER , INTENT(IN) :: DataHandle
2468 CHARACTER*(*) , INTENT(IN) :: Element
2469 CHARACTER*(*) , INTENT(IN) :: DateStr
2470 CHARACTER*(*) , INTENT(IN) :: Data
2471 INTEGER :: Status
2472 #endif
2473 RETURN
2474 END SUBROUTINE wrf_quilt_put_dom_td_char
2475
2476 SUBROUTINE wrf_quilt_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
2477 !<DESCRIPTION>
2478 ! Instruct the I/O quilt servers to attempt to read Count words of time
2479 ! independent attribute "Element" of variable "Varname"
2480 ! from the open dataset described by DataHandle.
2481 ! Attribute of type real is
2482 ! stored in array Data.
2483 ! Actual number of words read is returned in OutCount.
2484 ! This routine is called only by client (compute) tasks.
2485 !
2486 ! This is not yet supported.
2487 !</DESCRIPTION>
2488 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2489 IMPLICIT NONE
2490 INTEGER , INTENT(IN) :: DataHandle
2491 CHARACTER*(*) , INTENT(IN) :: Element
2492 CHARACTER*(*) , INTENT(IN) :: VarName
2493 real :: Data(*)
2494 INTEGER , INTENT(IN) :: Count
2495 INTEGER :: OutCount
2496 INTEGER :: Status
2497 #endif
2498 RETURN
2499 END SUBROUTINE wrf_quilt_get_var_ti_real
2500
2501 SUBROUTINE wrf_quilt_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status )
2502 !<DESCRIPTION>
2503 ! Instruct the I/O quilt servers to write Count words of time independent
2504 ! attribute "Element" of variable "Varname"
2505 ! to the open dataset described by DataHandle.
2506 ! Attribute of type real is
2507 ! copied from array Data.
2508 ! This routine is called only by client (compute) tasks.
2509 !
2510 ! This is not yet supported.
2511 !</DESCRIPTION>
2512 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2513 IMPLICIT NONE
2514 INTEGER , INTENT(IN) :: DataHandle
2515 CHARACTER*(*) , INTENT(IN) :: Element
2516 CHARACTER*(*) , INTENT(IN) :: VarName
2517 real , INTENT(IN) :: Data(*)
2518 INTEGER , INTENT(IN) :: Count
2519 INTEGER :: Status
2520 #endif
2521 RETURN
2522 END SUBROUTINE wrf_quilt_put_var_ti_real
2523
2524 SUBROUTINE wrf_quilt_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
2525 !<DESCRIPTION>
2526 ! Instruct the I/O quilt servers to attempt to read Count words of time
2527 ! independent attribute "Element" of variable "Varname"
2528 ! from the open dataset described by DataHandle.
2529 ! Attribute of type double is
2530 ! stored in array Data.
2531 ! Actual number of words read is returned in OutCount.
2532 ! This routine is called only by client (compute) tasks.
2533 !
2534 ! This is not yet supported.
2535 !</DESCRIPTION>
2536 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2537 IMPLICIT NONE
2538 INTEGER , INTENT(IN) :: DataHandle
2539 CHARACTER*(*) , INTENT(IN) :: Element
2540 CHARACTER*(*) , INTENT(IN) :: VarName
2541 real*8 :: Data(*)
2542 INTEGER , INTENT(IN) :: Count
2543 INTEGER :: OutCount
2544 INTEGER :: Status
2545 #endif
2546 CALL wrf_error_fatal('wrf_quilt_get_var_ti_double not supported yet')
2547 RETURN
2548 END SUBROUTINE wrf_quilt_get_var_ti_double
2549
2550 SUBROUTINE wrf_quilt_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status )
2551 !<DESCRIPTION>
2552 ! Instruct the I/O quilt servers to write Count words of time independent
2553 ! attribute "Element" of variable "Varname"
2554 ! to the open dataset described by DataHandle.
2555 ! Attribute of type double is
2556 ! copied from array Data.
2557 ! This routine is called only by client (compute) tasks.
2558 !
2559 ! This is not yet supported.
2560 !</DESCRIPTION>
2561 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2562 IMPLICIT NONE
2563 INTEGER , INTENT(IN) :: DataHandle
2564 CHARACTER*(*) , INTENT(IN) :: Element
2565 CHARACTER*(*) , INTENT(IN) :: VarName
2566 real*8 , INTENT(IN) :: Data(*)
2567 INTEGER , INTENT(IN) :: Count
2568 INTEGER :: Status
2569 #endif
2570 CALL wrf_error_fatal('wrf_quilt_put_var_ti_double not supported yet')
2571 RETURN
2572 END SUBROUTINE wrf_quilt_put_var_ti_double
2573
2574 SUBROUTINE wrf_quilt_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
2575 !<DESCRIPTION>
2576 ! Instruct the I/O quilt servers to attempt to read Count words of time
2577 ! independent attribute "Element" of variable "Varname"
2578 ! from the open dataset described by DataHandle.
2579 ! Attribute of type integer is
2580 ! stored in array Data.
2581 ! Actual number of words read is returned in OutCount.
2582 ! This routine is called only by client (compute) tasks.
2583 !
2584 ! This is not yet supported.
2585 !</DESCRIPTION>
2586 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2587 IMPLICIT NONE
2588 INTEGER , INTENT(IN) :: DataHandle
2589 CHARACTER*(*) , INTENT(IN) :: Element
2590 CHARACTER*(*) , INTENT(IN) :: VarName
2591 integer :: Data(*)
2592 INTEGER , INTENT(IN) :: Count
2593 INTEGER :: OutCount
2594 INTEGER :: Status
2595 #endif
2596 RETURN
2597 END SUBROUTINE wrf_quilt_get_var_ti_integer
2598
2599 SUBROUTINE wrf_quilt_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status )
2600 !<DESCRIPTION>
2601 ! Instruct the I/O quilt servers to write Count words of time independent
2602 ! attribute "Element" of variable "Varname"
2603 ! to the open dataset described by DataHandle.
2604 ! Attribute of type integer is
2605 ! copied from array Data.
2606 ! This routine is called only by client (compute) tasks.
2607 !
2608 ! This is not yet supported.
2609 !</DESCRIPTION>
2610 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2611 IMPLICIT NONE
2612 INTEGER , INTENT(IN) :: DataHandle
2613 CHARACTER*(*) , INTENT(IN) :: Element
2614 CHARACTER*(*) , INTENT(IN) :: VarName
2615 integer , INTENT(IN) :: Data(*)
2616 INTEGER , INTENT(IN) :: Count
2617 INTEGER :: Status
2618 #endif
2619 RETURN
2620 END SUBROUTINE wrf_quilt_put_var_ti_integer
2621
2622 SUBROUTINE wrf_quilt_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
2623 !<DESCRIPTION>
2624 ! Instruct the I/O quilt servers to attempt to read Count words of time
2625 ! independent attribute "Element" of variable "Varname"
2626 ! from the open dataset described by DataHandle.
2627 ! Attribute of type logical is
2628 ! stored in array Data.
2629 ! Actual number of words read is returned in OutCount.
2630 ! This routine is called only by client (compute) tasks.
2631 !
2632 ! This is not yet supported.
2633 !</DESCRIPTION>
2634 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2635 IMPLICIT NONE
2636 INTEGER , INTENT(IN) :: DataHandle
2637 CHARACTER*(*) , INTENT(IN) :: Element
2638 CHARACTER*(*) , INTENT(IN) :: VarName
2639 logical :: Data(*)
2640 INTEGER , INTENT(IN) :: Count
2641 INTEGER :: OutCount
2642 INTEGER :: Status
2643 #endif
2644 RETURN
2645 END SUBROUTINE wrf_quilt_get_var_ti_logical
2646
2647 SUBROUTINE wrf_quilt_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status )
2648 !<DESCRIPTION>
2649 ! Instruct the I/O quilt servers to write Count words of time independent
2650 ! attribute "Element" of variable "Varname"
2651 ! to the open dataset described by DataHandle.
2652 ! Attribute of type logical is
2653 ! copied from array Data.
2654 ! This routine is called only by client (compute) tasks.
2655 !
2656 ! This is not yet supported.
2657 !</DESCRIPTION>
2658 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2659 IMPLICIT NONE
2660 INTEGER , INTENT(IN) :: DataHandle
2661 CHARACTER*(*) , INTENT(IN) :: Element
2662 CHARACTER*(*) , INTENT(IN) :: VarName
2663 logical , INTENT(IN) :: Data(*)
2664 INTEGER , INTENT(IN) :: Count
2665 INTEGER :: Status
2666 #endif
2667 RETURN
2668 END SUBROUTINE wrf_quilt_put_var_ti_logical
2669
2670 SUBROUTINE wrf_quilt_get_var_ti_char ( DataHandle,Element, Varname, Data, Status )
2671 !<DESCRIPTION>
2672 ! Instruct the I/O quilt servers to attempt to read time independent
2673 ! attribute "Element" of variable "Varname"
2674 ! from the open dataset described by DataHandle.
2675 ! Attribute of type char is
2676 ! stored in string Data.
2677 ! This routine is called only by client (compute) tasks.
2678 !
2679 ! This is not yet supported.
2680 !</DESCRIPTION>
2681 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2682 IMPLICIT NONE
2683 INTEGER , INTENT(IN) :: DataHandle
2684 CHARACTER*(*) , INTENT(IN) :: Element
2685 CHARACTER*(*) , INTENT(IN) :: VarName
2686 CHARACTER*(*) :: Data
2687 INTEGER :: Status
2688 #endif
2689 RETURN
2690 END SUBROUTINE wrf_quilt_get_var_ti_char
2691
2692 SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Status )
2693 !<DESCRIPTION>
2694 ! Instruct the I/O quilt servers to write time independent
2695 ! attribute "Element" of variable "Varname"
2696 ! to the open dataset described by DataHandle.
2697 ! Attribute of type char is
2698 ! copied from string Data.
2699 ! This routine is called only by client (compute) tasks.
2700 !</DESCRIPTION>
2701
2702 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2703 USE module_wrf_quilt
2704 IMPLICIT NONE
2705 INCLUDE 'mpif.h'
2706 #include "intio_tags.h"
2707 INTEGER , INTENT(IN) :: DataHandle
2708 CHARACTER*(*) , INTENT(IN) :: Element
2709 CHARACTER*(*) , INTENT(IN) :: VarName
2710 CHARACTER*(*) , INTENT(IN) :: Data
2711 INTEGER :: Status
2712 INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
2713 REAL dummy
2714 !
2715
2716 !JMTIMING CALL start_timing
2717 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_var_ti_char' )
2718
2719 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
2720 IF ( int_handle_in_use( DataHandle ) ) THEN
2721 CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
2722 IF ( wrf_dm_on_monitor() ) THEN
2723 CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
2724 DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), int_var_ti_char )
2725 ELSE
2726 CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
2727 ENDIF
2728 iserver = get_server_id ( DataHandle )
2729 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
2730 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
2731
2732 !JMTIMING CALL start_timing
2733 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
2734 reduced = 0
2735 reduced(1) = hdrbufsize
2736 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
2737 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
2738 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
2739 comm_io_group, ierr )
2740 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_var_ti_char")
2741 ! send data to the i/o processor
2742 CALL collect_on_comm( comm_io_group, &
2743 onebyte, &
2744 hdrbuf, hdrbufsize , &
2745 dummy, 0 )
2746 ENDIF
2747 ENDIF
2748 !JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char" )
2749
2750 #endif
2751 RETURN
2752 END SUBROUTINE wrf_quilt_put_var_ti_char
2753
2754 SUBROUTINE wrf_quilt_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
2755 !<DESCRIPTION>
2756 ! Instruct the I/O quilt servers to attempt to read Count words of time
2757 ! dependent attribute "Element" of variable "Varname" valid at time DateStr
2758 ! from the open dataset described by DataHandle.
2759 ! Attribute of type real is
2760 ! stored in array Data.
2761 ! Actual number of words read is returned in OutCount.
2762 ! This routine is called only by client (compute) tasks.
2763 !
2764 ! This is not yet supported.
2765 !</DESCRIPTION>
2766 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2767 IMPLICIT NONE
2768 INTEGER , INTENT(IN) :: DataHandle
2769 CHARACTER*(*) , INTENT(IN) :: Element
2770 CHARACTER*(*) , INTENT(IN) :: DateStr
2771 CHARACTER*(*) , INTENT(IN) :: VarName
2772 real :: Data(*)
2773 INTEGER , INTENT(IN) :: Count
2774 INTEGER :: OutCount
2775 INTEGER :: Status
2776 #endif
2777 RETURN
2778 END SUBROUTINE wrf_quilt_get_var_td_real
2779
2780 SUBROUTINE wrf_quilt_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
2781 !<DESCRIPTION>
2782 ! Instruct the I/O quilt servers to write Count words of time dependent
2783 ! attribute "Element" of variable "Varname" valid at time DateStr
2784 ! to the open dataset described by DataHandle.
2785 ! Attribute of type real is
2786 ! copied from array Data.
2787 ! This routine is called only by client (compute) tasks.
2788 !
2789 ! This is not yet supported.
2790 !</DESCRIPTION>
2791 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2792 IMPLICIT NONE
2793 INTEGER , INTENT(IN) :: DataHandle
2794 CHARACTER*(*) , INTENT(IN) :: Element
2795 CHARACTER*(*) , INTENT(IN) :: DateStr
2796 CHARACTER*(*) , INTENT(IN) :: VarName
2797 real , INTENT(IN) :: Data(*)
2798 INTEGER , INTENT(IN) :: Count
2799 INTEGER :: Status
2800 #endif
2801 RETURN
2802 END SUBROUTINE wrf_quilt_put_var_td_real
2803
2804 SUBROUTINE wrf_quilt_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
2805 !<DESCRIPTION>
2806 ! Instruct the I/O quilt servers to attempt to read Count words of time
2807 ! dependent attribute "Element" of variable "Varname" valid at time DateStr
2808 ! from the open dataset described by DataHandle.
2809 ! Attribute of type double is
2810 ! stored in array Data.
2811 ! Actual number of words read is returned in OutCount.
2812 ! This routine is called only by client (compute) tasks.
2813 !
2814 ! This is not yet supported.
2815 !</DESCRIPTION>
2816 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2817 IMPLICIT NONE
2818 INTEGER , INTENT(IN) :: DataHandle
2819 CHARACTER*(*) , INTENT(IN) :: Element
2820 CHARACTER*(*) , INTENT(IN) :: DateStr
2821 CHARACTER*(*) , INTENT(IN) :: VarName
2822 real*8 :: Data(*)
2823 INTEGER , INTENT(IN) :: Count
2824 INTEGER :: OutCount
2825 INTEGER :: Status
2826 #endif
2827 CALL wrf_error_fatal('wrf_quilt_get_var_td_double not supported yet')
2828 RETURN
2829 END SUBROUTINE wrf_quilt_get_var_td_double
2830
2831 SUBROUTINE wrf_quilt_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
2832 !<DESCRIPTION>
2833 ! Instruct the I/O quilt servers to write Count words of time dependent
2834 ! attribute "Element" of variable "Varname" valid at time DateStr
2835 ! to the open dataset described by DataHandle.
2836 ! Attribute of type double is
2837 ! copied from array Data.
2838 ! This routine is called only by client (compute) tasks.
2839 !
2840 ! This is not yet supported.
2841 !</DESCRIPTION>
2842 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2843 IMPLICIT NONE
2844 INTEGER , INTENT(IN) :: DataHandle
2845 CHARACTER*(*) , INTENT(IN) :: Element
2846 CHARACTER*(*) , INTENT(IN) :: DateStr
2847 CHARACTER*(*) , INTENT(IN) :: VarName
2848 real*8 , INTENT(IN) :: Data(*)
2849 INTEGER , INTENT(IN) :: Count
2850 INTEGER :: Status
2851 #endif
2852 CALL wrf_error_fatal('wrf_quilt_put_var_td_double not supported yet')
2853 RETURN
2854 END SUBROUTINE wrf_quilt_put_var_td_double
2855
2856 SUBROUTINE wrf_quilt_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount,Status)
2857 !<DESCRIPTION>
2858 ! Instruct the I/O quilt servers to attempt to read Count words of time
2859 ! dependent attribute "Element" of variable "Varname" valid at time DateStr
2860 ! from the open dataset described by DataHandle.
2861 ! Attribute of type integer is
2862 ! stored in array Data.
2863 ! Actual number of words read is returned in OutCount.
2864 ! This routine is called only by client (compute) tasks.
2865 !
2866 ! This is not yet supported.
2867 !</DESCRIPTION>
2868 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2869 IMPLICIT NONE
2870 INTEGER , INTENT(IN) :: DataHandle
2871 CHARACTER*(*) , INTENT(IN) :: Element
2872 CHARACTER*(*) , INTENT(IN) :: DateStr
2873 CHARACTER*(*) , INTENT(IN) :: VarName
2874 integer :: Data(*)
2875 INTEGER , INTENT(IN) :: Count
2876 INTEGER :: OutCount
2877 INTEGER :: Status
2878 #endif
2879 RETURN
2880 END SUBROUTINE wrf_quilt_get_var_td_integer
2881
2882 SUBROUTINE wrf_quilt_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
2883 !<DESCRIPTION>
2884 ! Instruct the I/O quilt servers to write Count words of time dependent
2885 ! attribute "Element" of variable "Varname" valid at time DateStr
2886 ! to the open dataset described by DataHandle.
2887 ! Attribute of type integer is
2888 ! copied from array Data.
2889 ! This routine is called only by client (compute) tasks.
2890 !
2891 ! This is not yet supported.
2892 !</DESCRIPTION>
2893 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2894 IMPLICIT NONE
2895 INTEGER , INTENT(IN) :: DataHandle
2896 CHARACTER*(*) , INTENT(IN) :: Element
2897 CHARACTER*(*) , INTENT(IN) :: DateStr
2898 CHARACTER*(*) , INTENT(IN) :: VarName
2899 integer , INTENT(IN) :: Data(*)
2900 INTEGER , INTENT(IN) :: Count
2901 INTEGER :: Status
2902 #endif
2903 RETURN
2904 END SUBROUTINE wrf_quilt_put_var_td_integer
2905
2906 SUBROUTINE wrf_quilt_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
2907 !<DESCRIPTION>
2908 ! Instruct the I/O quilt servers to attempt to read Count words of time
2909 ! dependent attribute "Element" of variable "Varname" valid at time DateStr
2910 ! from the open dataset described by DataHandle.
2911 ! Attribute of type logical is
2912 ! stored in array Data.
2913 ! Actual number of words read is returned in OutCount.
2914 ! This routine is called only by client (compute) tasks.
2915 !
2916 ! This is not yet supported.
2917 !</DESCRIPTION>
2918 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2919 IMPLICIT NONE
2920 INTEGER , INTENT(IN) :: DataHandle
2921 CHARACTER*(*) , INTENT(IN) :: Element
2922 CHARACTER*(*) , INTENT(IN) :: DateStr
2923 CHARACTER*(*) , INTENT(IN) :: VarName
2924 logical :: Data(*)
2925 INTEGER , INTENT(IN) :: Count
2926 INTEGER :: OutCount
2927 INTEGER :: Status
2928 #endif
2929 RETURN
2930 END SUBROUTINE wrf_quilt_get_var_td_logical
2931
2932 SUBROUTINE wrf_quilt_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
2933 !<DESCRIPTION>
2934 ! Instruct the I/O quilt servers to write Count words of time dependent
2935 ! attribute "Element" of variable "Varname" valid at time DateStr
2936 ! to the open dataset described by DataHandle.
2937 ! Attribute of type logical is
2938 ! copied from array Data.
2939 ! This routine is called only by client (compute) tasks.
2940 !
2941 ! This is not yet supported.
2942 !</DESCRIPTION>
2943 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2944 IMPLICIT NONE
2945 INTEGER , INTENT(IN) :: DataHandle
2946 CHARACTER*(*) , INTENT(IN) :: Element
2947 CHARACTER*(*) , INTENT(IN) :: DateStr
2948 CHARACTER*(*) , INTENT(IN) :: VarName
2949 logical , INTENT(IN) :: Data(*)
2950 INTEGER , INTENT(IN) :: Count
2951 INTEGER :: Status
2952 #endif
2953 RETURN
2954 END SUBROUTINE wrf_quilt_put_var_td_logical
2955
2956 SUBROUTINE wrf_quilt_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status )
2957 !<DESCRIPTION>
2958 ! Instruct the I/O quilt servers to attempt to read time dependent
2959 ! attribute "Element" of variable "Varname" valid at time DateStr
2960 ! from the open dataset described by DataHandle.
2961 ! Attribute of type char is
2962 ! stored in string Data.
2963 ! This routine is called only by client (compute) tasks.
2964 !
2965 ! This is not yet supported.
2966 !</DESCRIPTION>
2967 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2968 IMPLICIT NONE
2969 INTEGER , INTENT(IN) :: DataHandle
2970 CHARACTER*(*) , INTENT(IN) :: Element
2971 CHARACTER*(*) , INTENT(IN) :: DateStr
2972 CHARACTER*(*) , INTENT(IN) :: VarName
2973 CHARACTER*(*) :: Data
2974 INTEGER :: Status
2975 #endif
2976 RETURN
2977 END SUBROUTINE wrf_quilt_get_var_td_char
2978
2979 SUBROUTINE wrf_quilt_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status )
2980 !<DESCRIPTION>
2981 ! Instruct the I/O quilt servers to write time dependent
2982 ! attribute "Element" of variable "Varname" valid at time DateStr
2983 ! to the open dataset described by DataHandle.
2984 ! Attribute of type char is
2985 ! copied from string Data.
2986 ! This routine is called only by client (compute) tasks.
2987 !
2988 ! This is not yet supported.
2989 !</DESCRIPTION>
2990 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
2991 IMPLICIT NONE
2992 INTEGER , INTENT(IN) :: DataHandle
2993 CHARACTER*(*) , INTENT(IN) :: Element
2994 CHARACTER*(*) , INTENT(IN) :: DateStr
2995 CHARACTER*(*) , INTENT(IN) :: VarName
2996 CHARACTER*(*) , INTENT(IN) :: Data
2997 INTEGER :: Status
2998 #endif
2999 RETURN
3000 END SUBROUTINE wrf_quilt_put_var_td_char
3001
3002 SUBROUTINE wrf_quilt_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
3003 DomainDesc , MemoryOrder , Stagger , DimNames , &
3004 DomainStart , DomainEnd , &
3005 MemoryStart , MemoryEnd , &
3006 PatchStart , PatchEnd , &
3007 Status )
3008 !<DESCRIPTION>
3009 ! Instruct the I/O quilt servers to read the variable named VarName from the
3010 ! dataset pointed to by DataHandle.
3011 ! This routine is called only by client (compute) tasks.
3012 !
3013 ! This is not yet supported.
3014 !</DESCRIPTION>
3015 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
3016 IMPLICIT NONE
3017 INTEGER , INTENT(IN) :: DataHandle
3018 CHARACTER*(*) , INTENT(INOUT) :: DateStr
3019 CHARACTER*(*) , INTENT(INOUT) :: VarName
3020 INTEGER , INTENT(INOUT) :: Field(*)
3021 integer ,intent(in) :: FieldType
3022 integer ,intent(inout) :: Comm
3023 integer ,intent(inout) :: IOComm
3024 integer ,intent(in) :: DomainDesc
3025 character*(*) ,intent(in) :: MemoryOrder
3026 character*(*) ,intent(in) :: Stagger
3027 character*(*) , dimension (*) ,intent(in) :: DimNames
3028 integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
3029 integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
3030 integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
3031 integer ,intent(out) :: Status
3032 Status = 0
3033 #endif
3034 RETURN
3035 END SUBROUTINE wrf_quilt_read_field
3036
3037 SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
3038 DomainDesc , MemoryOrder , Stagger , DimNames , &
3039 DomainStart , DomainEnd , &
3040 MemoryStart , MemoryEnd , &
3041 PatchStart , PatchEnd , &
3042 Status )
3043 !<DESCRIPTION>
3044 ! Prepare instructions for the I/O quilt servers to write the variable named
3045 ! VarName to the dataset pointed to by DataHandle.
3046 !
3047 ! During a "training" write this routine accumulates number and sizes of
3048 ! messages that will be sent to the I/O server associated with this compute
3049 ! (client) task.
3050 !
3051 ! During a "real" write, this routine begins by allocating
3052 ! int_local_output_buffer if it has not already been allocated. Sizes
3053 ! accumulated during "training" are used to determine how big
3054 ! int_local_output_buffer must be. This routine then stores "int_field"
3055 ! headers and associated field data in int_local_output_buffer. The contents
3056 ! of int_local_output_buffer are actually sent to the I/O quilt server in
3057 ! routine wrf_quilt_iosync(). This scheme allows output of multiple variables
3058 ! to be aggregated into a single "iosync" operation.
3059 ! This routine is called only by client (compute) tasks.
3060 !</DESCRIPTION>
3061 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
3062 USE module_state_description
3063 USE module_wrf_quilt
3064 IMPLICIT NONE
3065 INCLUDE 'mpif.h'
3066 #include "wrf_io_flags.h"
3067 INTEGER , INTENT(IN) :: DataHandle
3068 CHARACTER*(*) , INTENT(IN) :: DateStr
3069 CHARACTER*(*) , INTENT(IN) :: VarName
3070 ! INTEGER , INTENT(IN) :: Field(*)
3071 integer ,intent(in) :: FieldType
3072 integer ,intent(inout) :: Comm
3073 integer ,intent(inout) :: IOComm
3074 integer ,intent(in) :: DomainDesc
3075 character*(*) ,intent(in) :: MemoryOrder
3076 character*(*) ,intent(in) :: Stagger
3077 character*(*) , dimension (*) ,intent(in) :: DimNames
3078 integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
3079 integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
3080 integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
3081 integer ,intent(out) :: Status
3082
3083 integer ii,jj,kk,myrank
3084
3085 REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
3086 MemoryStart(2):MemoryEnd(2), &
3087 MemoryStart(3):MemoryEnd(3) ) :: Field
3088 INTEGER locsize , typesize, inttypesize
3089 INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
3090 INTEGER, EXTERNAL :: use_package
3091
3092 !JMTIMING CALL start_timing
3093 CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_write_field' )
3094
3095 IF ( .NOT. (DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles) ) THEN
3096 CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: invalid data handle" )
3097 ENDIF
3098 IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
3099 CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: DataHandle not opened" )
3100 ENDIF
3101
3102 locsize = (PatchEnd(1)-PatchStart(1)+1)* &
3103 (PatchEnd(2)-PatchStart(2)+1)* &
3104 (PatchEnd(3)-PatchStart(3)+1)
3105
3106 CALL mpi_type_size( MPI_INTEGER, inttypesize, ierr )
3107 ! Note that the WRF_DOUBLE branch of this IF statement must come first since
3108 ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds.
3109 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3110 CALL mpi_type_size( MPI_DOUBLE_PRECISION, typesize, ierr )
3111 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3112 CALL mpi_type_size( MPI_REAL, typesize, ierr )
3113 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3114 CALL mpi_type_size( MPI_INTEGER, typesize, ierr )
3115 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
3116 CALL mpi_type_size( MPI_LOGICAL, typesize, ierr )
3117 ENDIF
3118
3119 IF ( .NOT. okay_to_write( DataHandle ) ) THEN
3120
3121 ! This is a "training" write.
3122 ! it is not okay to actually write; what we do here is just "bookkeep": count up
3123 ! the number and size of messages that we will output to io server associated with
3124 ! this task
3125
3126 CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, &
3127 DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
3128 333933 , MemoryOrder , Stagger , DimNames , & ! 333933 means training; magic number
3129 DomainStart , DomainEnd , &
3130 MemoryStart , MemoryEnd , &
3131 PatchStart , PatchEnd )
3132
3133 int_num_bytes_to_write(DataHandle) = int_num_bytes_to_write(DataHandle) + locsize * typesize + hdrbufsize
3134
3135 ! Send the hdr for the write in case the interface is calling the I/O API in "learn" mode
3136
3137 iserver = get_server_id ( DataHandle )
3138 !JMDEBUGwrite(0,*)'wrf_quilt_write_field (dryrun) ',iserver
3139 CALL get_mpi_comm_io_groups( comm_io_group , iserver )
3140 ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here)
3141
3142 CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
3143
3144 IF ( .NOT. wrf_dm_on_monitor() ) THEN ! only one task in compute grid sends this message; send noops on others
3145 CALL int_gen_noop_header( hdrbuf, hdrbufsize, inttypesize )
3146 ENDIF
3147
3148
3149 !JMTIMING CALL start_timing
3150 ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
3151 reduced = 0
3152 reduced(1) = hdrbufsize
3153 IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
3154 CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
3155 MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
3156 comm_io_group, ierr )
3157 !JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun")
3158 ! send data to the i/o processor
3159
3160 CALL collect_on_comm( comm_io_group, &
3161 onebyte, &
3162 hdrbuf, hdrbufsize , &
3163 dummy, 0 )
3164
3165 ELSE
3166
3167 IF ( .NOT. associated( int_local_output_buffer ) ) THEN
3168 ALLOCATE ( int_local_output_buffer( (int_num_bytes_to_write( DataHandle )+1)/inttypesize ) )
3169 int_local_output_cursor = 1
3170 ENDIF
3171 iserver = get_server_id ( DataHandle )
3172 !JMDEBUGwrite(0,*)'wrf_quilt_write_field (writing) ',iserver
3173
3174 ! This is NOT a "training" write. It is OK to write now.
3175 CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, &
3176 DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
3177 0 , MemoryOrder , Stagger , DimNames , & ! non-333933 means okay to write; magic number
3178 DomainStart , DomainEnd , &
3179 MemoryStart , MemoryEnd , &
3180 PatchStart , PatchEnd )
3181
3182 ! Pack header into int_local_output_buffer. It will be sent to the
3183 ! I/O servers during the next "iosync" operation.
3184 #ifdef DEREF_KLUDGE
3185 CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer(1), int_local_output_cursor )
3186 #else
3187 CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer, int_local_output_cursor )
3188 #endif
3189
3190 ! Pack field data into int_local_output_buffer. It will be sent to the
3191 ! I/O servers during the next "iosync" operation.
3192 #ifdef DEREF_KLUDGE
3193 CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), &
3194 locsize * typesize , int_local_output_buffer(1), int_local_output_cursor )
3195 #else
3196 CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), &
3197 locsize * typesize , int_local_output_buffer, int_local_output_cursor )
3198 #endif
3199
3200 ENDIF
3201 Status = 0
3202 !JMTIMING CALL end_timing("wrf_quilt_write_field")
3203
3204 #endif
3205 RETURN
3206 END SUBROUTINE wrf_quilt_write_field
3207
3208 SUBROUTINE wrf_quilt_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
3209 DomainStart , DomainEnd , Status )
3210 !<DESCRIPTION>
3211 ! This routine applies only to a dataset that is open for read. It instructs
3212 ! the I/O quilt servers to return information about variable VarName.
3213 ! This routine is called only by client (compute) tasks.
3214 !
3215 ! This is not yet supported.
3216 !</DESCRIPTION>
3217 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
3218 IMPLICIT NONE
3219 integer ,intent(in) :: DataHandle
3220 character*(*) ,intent(in) :: VarName
3221 integer :: NDim
3222 character*(*) :: MemoryOrder
3223 character*(*) :: Stagger
3224 integer ,dimension(*) :: DomainStart, DomainEnd
3225 integer :: Status
3226 #endif
3227 RETURN
3228 END SUBROUTINE wrf_quilt_get_var_info
3229
3230 SUBROUTINE get_mpi_comm_io_groups( retval, isrvr )
3231 !<DESCRIPTION>
3232 ! This routine returns the compute+io communicator to which this
3233 ! compute task belongs for I/O server group "isrvr".
3234 ! This routine is called only by client (compute) tasks.
3235 !</DESCRIPTION>
3236 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
3237 USE module_wrf_quilt
3238 IMPLICIT NONE
3239 INTEGER, INTENT(IN ) :: isrvr
3240 INTEGER, INTENT(OUT) :: retval
3241 retval = mpi_comm_io_groups(isrvr)
3242 #endif
3243 RETURN
3244 END SUBROUTINE get_mpi_comm_io_groups
3245
3246 SUBROUTINE get_nio_tasks_in_group( retval )
3247 !<DESCRIPTION>
3248 ! This routine returns the number of I/O server tasks in each
3249 ! I/O server group. It can be called by both clients and
3250 ! servers.
3251 !</DESCRIPTION>
3252 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
3253 USE module_wrf_quilt
3254 IMPLICIT NONE
3255 INTEGER, INTENT(OUT) :: retval
3256 retval = nio_tasks_in_group
3257 #endif
3258 RETURN
3259 END SUBROUTINE get_nio_tasks_in_group
3260
3261