/wrfv2_fire/frame/module_io_quilt.F
FORTRAN Legacy | 5118 lines | 2434 code | 470 blank | 2214 comment | 109 complexity | f10468d5f1c7c19ff9c349ed06e1796e MD5 | raw file
Possible License(s): AGPL-1.0
- !WRF:DRIVER_LAYER:IO
- !
- #define DEBUG_LVL 50
- !#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) ; write(0,*) __LINE__
- #define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k )
- ! Workaround for bug in the IBM MPI implementation. Look near the
- ! bottom of this file for an explanation.
- #ifdef IBM_REDUCE_BUG_WORKAROUND
- #define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) reduce_add_integer(sb,rb,c,r,com)
- #else
- #define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) MPI_Reduce(sb,rb,c,dt,op,r,com,ierr)
- #endif
- MODULE module_wrf_quilt
- !<DESCRIPTION>
- !<PRE>
- ! This module contains WRF-specific I/O quilt routines called by both
- ! client (compute) and server (I/O quilt) tasks. I/O quilt servers are
- ! a run-time optimization that allow I/O operations, executed on the I/O
- ! quilt server tasks, to be overlapped with useful computation, executed on
- ! the compute tasks. Since I/O operations are often quite slow compared to
- ! computation, this performance optimization can increase parallel
- ! efficiency.
- !
- ! Currently, one group of I/O servers can be specified at run-time. Namelist
- ! variable "nio_tasks_per_group" is used to specify the number of I/O server
- ! tasks in this group. In most cases, parallel efficiency is optimized when
- ! the minimum number of I/O server tasks are used. If memory needed to cache
- ! I/O operations fits on a single processor, then set nio_tasks_per_group=1.
- ! If not, increase the number of I/O server tasks until I/O operations fit in
- ! memory. In the future, multiple groups of I/O server tasks will be
- ! supported. The number of groups will be specified by namelist variable
- ! "nio_groups". For now, nio_groups must be set to 1. Currently, I/O servers
- ! only support overlap of output operations with computation. Also, only I/O
- ! packages that do no support native parallel I/O may be used with I/O server
- ! tasks. This excludes PHDF5 and MCEL.
- !
- ! In this module, the I/O quilt server tasks call package-dependent
- ! WRF-specific I/O interfaces to perform I/O operations requested by the
- ! client (compute) tasks. All of these calls occur inside subroutine
- ! quilt().
- !
- ! The client (compute) tasks call package-independent WRF-specific "quilt I/O"
- ! interfaces that send requests to the I/O quilt servers. All of these calls
- ! are made from module_io.F.
- !
- ! These routines have the same names and (roughly) the same arguments as those
- ! specified in the WRF I/O API except that:
- ! - "Quilt I/O" routines defined in this file and called by routines in
- ! module_io.F have the "wrf_quilt_" prefix.
- ! - Package-dependent routines called from routines in this file are defined
- ! in the external I/O packages and have the "ext_" prefix.
- !
- ! Both client (compute) and server tasks call routine init_module_wrf_quilt()
- ! which then calls setup_quilt_servers() determine which tasks are compute
- ! tasks and which are server tasks. Before the end of init_module_wrf_quilt()
- ! server tasks call routine quilt() and remain there for the rest of the model
- ! run. Compute tasks return from init_module_wrf_quilt() to perform model
- ! computations.
- !
- ! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
- ! version of the WRF I/O API. This document includes detailed descriptions
- ! of subroutines and their arguments that are not duplicated here.
- !</PRE>
- !</DESCRIPTION>
- USE module_internal_header_util
- USE module_timing
- INTEGER, PARAMETER :: int_num_handles = 99
- INTEGER, PARAMETER :: max_servers = int_num_handles+1 ! why +1?
- LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, int_handle_in_use, okay_to_commit
- INTEGER, DIMENSION(int_num_handles) :: int_num_bytes_to_write, io_form
- REAL, POINTER,SAVE :: int_local_output_buffer(:)
- INTEGER, SAVE :: int_local_output_cursor
- LOGICAL :: quilting_enabled
- LOGICAL :: disable_quilt = .FALSE.
- INTEGER :: prev_server_for_handle = -1
- INTEGER :: server_for_handle(int_num_handles)
- INTEGER :: reduced(2), reduced_dummy(2)
- LOGICAL, EXTERNAL :: wrf_dm_on_monitor
- INTEGER :: mpi_comm_avail,availrank
- LOGICAL :: in_avail=.false., poll_servers=.false.
- INTEGER nio_groups
- #ifdef DM_PARALLEL
- INTEGER :: mpi_comm_local
- LOGICAL :: compute_node
- LOGICAL :: compute_group_master(max_servers)
- INTEGER :: mpi_comm_io_groups(max_servers)
- INTEGER :: nio_tasks_in_group
- INTEGER :: nio_tasks_per_group
- INTEGER :: ncompute_tasks
- INTEGER :: ntasks
- INTEGER :: mytask
- INTEGER, PARAMETER :: onebyte = 1
- INTEGER comm_io_servers, iserver, hdrbufsize, obufsize
- INTEGER, DIMENSION(4096) :: hdrbuf
- INTEGER, DIMENSION(int_num_handles) :: handle
- #endif
- #ifdef IBM_REDUCE_BUG_WORKAROUND
- ! Workaround for bug in the IBM MPI implementation. Look near the
- ! bottom of this file for an explanation.
- interface reduce_add_integer
- module procedure reduce_add_int_arr
- module procedure reduce_add_int_scl
- end interface
- #endif
- CONTAINS
- #if defined(DM_PARALLEL) && !defined( STUBMPI )
- INTEGER FUNCTION get_server_id ( dhandle )
- !<DESCRIPTION>
- ! Logic in the client side to know which io server
- ! group to send to. If the unit corresponds to a file that's
- ! already been opened, then we have no choice but to send the
- ! data to that group again, regardless of whether there are
- ! other server-groups. If it's a new file, we can chose a new
- ! server group. I.e. opening a file locks it onto a server
- ! group. Closing the file unlocks it.
- !</DESCRIPTION>
- IMPLICIT NONE
- INTEGER, INTENT(IN) :: dhandle
- IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN
- IF ( server_for_handle ( dhandle ) .GE. 1 ) THEN
- get_server_id = server_for_handle ( dhandle )
- ELSE
- IF(poll_servers) THEN
- ! Poll server group masters to find an inactive I/O server group:
- call wrf_quilt_find_server(server_for_handle(dhandle))
- ELSE
- ! Server polling is disabled, so cycle through servers:
- prev_server_for_handle = mod ( prev_server_for_handle + 1 , nio_groups )
- server_for_handle( dhandle ) = prev_server_for_handle+1
- ENDIF
- get_server_id=server_for_handle(dhandle)
- ENDIF
- ELSE
- CALL wrf_message('module_io_quilt: get_server_id bad dhandle' )
- ENDIF
- END FUNCTION get_server_id
- #endif
- SUBROUTINE set_server_id ( dhandle, value )
- IMPLICIT NONE
- INTEGER, INTENT(IN) :: dhandle, value
- IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN
- server_for_handle(dhandle) = value
- ELSE
- CALL wrf_message('module_io_quilt: set_server_id bad dhandle' )
- ENDIF
- END SUBROUTINE set_server_id
- LOGICAL FUNCTION get_poll_servers()
- implicit none
- get_poll_servers=poll_servers
- end FUNCTION get_poll_servers
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- SUBROUTINE int_get_fresh_handle( retval )
- !<DESCRIPTION>
- ! Find an unused "client file handle" and return it in retval.
- ! The "client file handle" is used to remember how a file was opened
- ! so clients do not need to ask the I/O quilt servers for this information.
- ! It is also used as a file identifier in communications with the I/O
- ! server task.
- !
- ! Note that client tasks know nothing about package-specific handles.
- ! Only the I/O quilt servers know about them.
- !</DESCRIPTION>
- INTEGER i, retval
- retval = -1
- DO i = 1, int_num_handles
- IF ( .NOT. int_handle_in_use(i) ) THEN
- retval = i
- GOTO 33
- ENDIF
- ENDDO
- 33 CONTINUE
- IF ( retval < 0 ) THEN
- CALL wrf_error_fatal("frame/module_io_quilt.F: int_get_fresh_handle() can not")
- ENDIF
- int_handle_in_use(i) = .TRUE.
- NULLIFY ( int_local_output_buffer )
- END SUBROUTINE int_get_fresh_handle
- SUBROUTINE setup_quilt_servers ( nio_tasks_per_group, &
- mytask, &
- ntasks, &
- n_groups_arg, &
- nio, &
- mpi_comm_wrld, &
- mpi_comm_local, &
- mpi_comm_io_groups)
- !<DESCRIPTION>
- ! Both client (compute) and server tasks call this routine to
- ! determine which tasks are compute tasks and which are I/O server tasks.
- !
- ! Module variables MPI_COMM_LOCAL and MPI_COMM_IO_GROUPS(:) are set up to
- ! contain MPI communicators as follows:
- !
- ! MPI_COMM_LOCAL is the Communicator for the local groups of tasks. For the
- ! compute tasks it is the group of compute tasks; for a server group it the
- ! communicator of tasks in the server group.
- !
- ! Elements of MPI_COMM_IO_GROUPS are communicators that each contain one or
- ! more compute tasks and a single I/O server assigned to those compute tasks.
- ! The I/O server tasks is always the last task in these communicators.
- ! On a compute task, which has a single associate in each of the server
- ! groups, MPI_COMM_IO_GROUPS is treated as an array; each element corresponds
- ! to a different server group.
- ! On a server task only the first element of MPI_COMM_IO_GROUPS is used
- ! because each server task is part of only one io_group.
- !
- ! I/O server tasks in each I/O server group are divided among compute tasks as
- ! evenly as possible.
- !
- ! When multiple I/O server groups are used, each must have the same number of
- ! tasks. When the total number of extra I/O tasks does not divide evenly by
- ! the number of io server groups requested, the remainder tasks are not used
- ! (wasted).
- !
- ! For example, communicator membership for 18 tasks with nio_groups=2 and
- ! nio_tasks_per_group=3 is shown below:
- !
- !<PRE>
- ! Membership for MPI_COMM_LOCAL communicators:
- ! COMPUTE TASKS: 0 1 2 3 4 5 6 7 8 9 10 11
- ! 1ST I/O SERVER GROUP: 12 13 14
- ! 2ND I/O SERVER GROUP: 15 16 17
- !
- ! Membership for MPI_COMM_IO_GROUPS(1):
- ! COMPUTE TASKS 0, 3, 6, 9: 0 3 6 9 12
- ! COMPUTE TASKS 1, 4, 7,10: 1 4 7 10 13
- ! COMPUTE TASKS 2, 5, 8,11: 2 5 8 11 14
- ! I/O SERVER TASK 12: 0 3 6 9 12
- ! I/O SERVER TASK 13: 1 4 7 10 13
- ! I/O SERVER TASK 14: 2 5 8 11 14
- ! I/O SERVER TASK 15: 0 3 6 9 15
- ! I/O SERVER TASK 16: 1 4 7 10 16
- ! I/O SERVER TASK 17: 2 5 8 11 17
- !
- ! Membership for MPI_COMM_IO_GROUPS(2):
- ! COMPUTE TASKS 0, 3, 6, 9: 0 3 6 9 15
- ! COMPUTE TASKS 1, 4, 7,10: 1 4 7 10 16
- ! COMPUTE TASKS 2, 5, 8,11: 2 5 8 11 17
- ! I/O SERVER TASK 12: ** not used **
- ! I/O SERVER TASK 13: ** not used **
- ! I/O SERVER TASK 14: ** not used **
- ! I/O SERVER TASK 15: ** not used **
- ! I/O SERVER TASK 16: ** not used **
- ! I/O SERVER TASK 17: ** not used **
- !</PRE>
- !</DESCRIPTION>
- USE module_configure
- #ifdef DM_PARALLEL
- USE module_dm, ONLY : compute_mesh
- #endif
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- INTEGER, INTENT(IN) :: nio_tasks_per_group, mytask, ntasks, &
- n_groups_arg, mpi_comm_wrld
- INTEGER, INTENT(OUT) :: mpi_comm_local, nio
- INTEGER, DIMENSION(100), INTENT(OUT) :: mpi_comm_io_groups
- ! Local
- INTEGER :: i, j, ii, comdup, ierr, niotasks, n_groups, iisize
- INTEGER, DIMENSION(ntasks) :: icolor
- CHARACTER*128 mess
- INTEGER :: io_form_setting
- INTEGER :: me
- INTEGER :: k, m, nprocx, nprocy
- LOGICAL :: reorder_mesh
- !check the namelist and make sure there are no output forms specified
- !that cannot be quilted
- CALL nl_get_io_form_history(1, io_form_setting) ; call sokay( 'history', io_form_setting )
- CALL nl_get_io_form_restart(1, io_form_setting) ; call sokay( 'restart', io_form_setting )
- CALL nl_get_io_form_auxhist1(1, io_form_setting) ; call sokay( 'auxhist1', io_form_setting )
- CALL nl_get_io_form_auxhist2(1, io_form_setting) ; call sokay( 'auxhist2', io_form_setting )
- CALL nl_get_io_form_auxhist3(1, io_form_setting) ; call sokay( 'auxhist3', io_form_setting )
- CALL nl_get_io_form_auxhist4(1, io_form_setting) ; call sokay( 'auxhist4', io_form_setting )
- CALL nl_get_io_form_auxhist5(1, io_form_setting) ; call sokay( 'auxhist5', io_form_setting )
- CALL nl_get_io_form_auxhist6(1, io_form_setting) ; call sokay( 'auxhist6', io_form_setting )
- CALL nl_get_io_form_auxhist7(1, io_form_setting) ; call sokay( 'auxhist7', io_form_setting )
- CALL nl_get_io_form_auxhist8(1, io_form_setting) ; call sokay( 'auxhist8', io_form_setting )
- CALL nl_get_io_form_auxhist9(1, io_form_setting) ; call sokay( 'auxhist9', io_form_setting )
- CALL nl_get_io_form_auxhist10(1, io_form_setting) ; call sokay( 'auxhist10', io_form_setting )
- CALL nl_get_io_form_auxhist11(1, io_form_setting) ; call sokay( 'auxhist11', io_form_setting )
- n_groups = n_groups_arg
- IF ( n_groups .LT. 1 ) n_groups = 1
- compute_node = .TRUE.
- !<DESCRIPTION>
- ! nio is number of io tasks per group. If there arent enough tasks to satisfy
- ! the requirement that there be at least as many compute tasks as io tasks in
- ! each group, then just print a warning and dump out of quilting
- !</DESCRIPTION>
- nio = nio_tasks_per_group
- ncompute_tasks = ntasks - (nio * n_groups)
- IF ( ncompute_tasks .LT. nio ) THEN
- WRITE(mess,'("Not enough tasks to have ",I3," groups of ",I3," I/O tasks. No quilting.")')n_groups,nio
- nio = 0
- ncompute_tasks = ntasks
- ELSE
- WRITE(mess,'("Quilting with ",I3," groups of ",I3," I/O tasks.")')n_groups,nio
- ENDIF
- CALL wrf_message(mess)
- IF ( nio .LT. 0 ) THEN
- nio = 0
- ENDIF
- IF ( nio .EQ. 0 ) THEN
- quilting_enabled = .FALSE.
- mpi_comm_local = mpi_comm_wrld
- mpi_comm_io_groups = mpi_comm_wrld
- RETURN
- ENDIF
- quilting_enabled = .TRUE.
- ! First construct the local communicators
- ! prepare to split the communicator by designating compute-only tasks
- DO i = 1, ncompute_tasks
- icolor(i) = 0
- ENDDO
- ii = 1
- ! and designating the groups of i/o tasks
- DO i = ncompute_tasks+1, ntasks, nio
- DO j = i, i+nio-1
- icolor(j) = ii
- ENDDO
- ii = ii+1
- ENDDO
- CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr)
- CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr)
- ! Now construct the communicators for the io_groups
- CALL nl_get_reorder_mesh(1,reorder_mesh)
- IF ( reorder_mesh ) THEN
- reorder_mesh = .FALSE.
- CALL nl_set_reorder_mesh(1,reorder_mesh)
- CALL wrf_message('Warning: reorder_mesh does not work with quilting. Disabled reorder_mesh.')
- ENDIF
- ! assign the compute tasks to the i/o tasks in full rows
- CALL compute_mesh( ncompute_tasks, nprocx, nprocy )
- nio = min(nio,nprocy)
- m = mod(nprocy,nio) ! divide up remainder, 1 row per, until gone
- ii = 1
- DO j = 1, nio, 1
- DO k = 1,nprocy/nio+min(m,1)
- DO i = 1, nprocx
- icolor(ii) = j - 1
- ii = ii + 1
- ENDDO
- ENDDO
- m = max(m-1,0)
- ENDDO
- ! ... and add the io servers as the last task in each group
- DO j = 1, n_groups
- ! TBH: each I/O group will contain only one I/O server
- DO i = ncompute_tasks+1,ntasks
- icolor(i) = MPI_UNDEFINED
- ENDDO
- ii = 0
- DO i = ncompute_tasks+(j-1)*nio+1,ncompute_tasks+j*nio
- icolor(i) = ii
- ii = ii+1
- ENDDO
- CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr)
- CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask, &
- mpi_comm_io_groups(j),ierr)
- ENDDO
- #ifdef PNETCDF_QUILT
- if(poll_servers) then
- poll_servers=.false.
- call wrf_message('Warning: server polling does not work with pnetcdf_quilt. Disabled poll_servers.')
- else
- #endif
- if(nio_groups==1) then
- poll_servers=.false.
- call wrf_message('Server polling is useless with one io group. Disabled poll_servers.')
- endif
- #ifdef PNETCDF_QUILT
- endif
- #endif
- if(poll_servers) then
- ! If server polling is enabled, we need to create mpi_comm_avail,
- ! which contains the monitor process, and the I/O server master process
- ! for each I/O server group. This will be used in the routines
- ! wrf_quilt_find_server and wrf_quilt_server_ready to find inactive
- ! I/O servers for new data handles in get_server_id.
- ! The "in_avail" is set to true iff I am in the mpi_comm_avail.
- call mpi_comm_rank(mpi_comm_wrld,me,ierr)
- icolor=MPI_UNDEFINED
- in_avail=.false.
- if(wrf_dm_on_monitor()) then
- in_avail=.true. ! monitor process is in mpi_comm_avail
- endif
- icolor(1)=1
- do j=1,n_groups
- i=ncompute_tasks+j*nio-1
- if(me+1==i) then
- in_avail=.true. ! I/O server masters are in mpi_comm_avail
- endif
- icolor(i)=1
- enddo
- CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr)
- CALL MPI_Comm_split(comdup,icolor(me+1),me, &
- mpi_comm_avail,ierr)
- availrank=MPI_UNDEFINED
- if(in_avail) then
- call mpi_comm_rank(mpi_comm_avail,availrank,ierr)
- endif
- endif
- compute_group_master = .FALSE.
- compute_node = .FALSE.
- DO j = 1, n_groups
- IF ( mytask .LT. ncompute_tasks .OR. & ! I am a compute task
- (ncompute_tasks+(j-1)*nio .LE. mytask .AND. mytask .LT. ncompute_tasks+j*nio) & ! I am the I/O server for this group
- ) THEN
- CALL MPI_Comm_Size( mpi_comm_io_groups(j) , iisize, ierr )
- ! Get the rank of this compute task in the compute+io
- ! communicator to which it belongs
- CALL MPI_Comm_Rank( mpi_comm_io_groups(j) , me , ierr )
- ! If I am an I/O server for this group then make that group's
- ! communicator the first element in the mpi_comm_io_groups array
- ! (I will ignore all of the other elements).
- IF (ncompute_tasks+(j-1)*nio .LE. mytask .AND. mytask .LT. ncompute_tasks+j*nio) THEN
- mpi_comm_io_groups(1) = mpi_comm_io_groups(j)
- ELSE
- compute_node = .TRUE.
- ! If I am a compute task, check whether I am the member of my
- ! group that will communicate things that should be sent just
- ! once (e.g. commands) to the IO server of my group.
- compute_group_master(j) = (me .EQ. 0)
- ! IF( compute_group_master(j) ) WRITE(*,*) mytask,': ARPDBG : I will talk to IO server in group ',j
- ENDIF
- ENDIF
- ENDDO
- END SUBROUTINE setup_quilt_servers
- SUBROUTINE sokay ( stream, io_form )
- USE module_state_description
- CHARACTER*(*) stream
- CHARACTER*256 mess
- INTEGER io_form
- SELECT CASE (io_form)
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- RETURN
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- RETURN
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- RETURN
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- RETURN
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- RETURN
- #endif
- CASE (0)
- RETURN
- CASE DEFAULT
- WRITE(mess,*)' An output format has been specified that is incompatible with quilting: io_form: ',io_form,' ',TRIM(stream)
- CALL wrf_error_fatal(mess)
- END SELECT
- END SUBROUTINE sokay
- SUBROUTINE quilt
- !<DESCRIPTION>
- ! I/O server tasks call this routine and remain in it for the rest of the
- ! model run. I/O servers receive I/O requests from compute tasks and
- ! perform requested I/O operations by calling package-dependent WRF-specific
- ! I/O interfaces. Requests are sent in the form of "data headers". Each
- ! request has a unique "header" message associated with it. For requests that
- ! contain large amounts of data, the data is appended to the header. See
- ! file module_internal_header_util.F for detailed descriptions of all
- ! headers.
- !
- ! We wish to be able to link to different packages depending on whether
- ! the I/O is restart, initial, history, or boundary.
- !</DESCRIPTION>
- USE module_state_description
- USE module_quilt_outbuf_ops
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- #include "wrf_io_flags.h"
- INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr
- INTEGER istat
- INTEGER mytask_io_group
- INTEGER :: nout_set = 0
- INTEGER :: obufsize, bigbufsize, chunksize, sz
- REAL, DIMENSION(1) :: dummy
- INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf
- REAL, ALLOCATABLE, DIMENSION(:) :: RDATA
- INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA
- CHARACTER (LEN=512) :: CDATA
- CHARACTER (LEN=80) :: fname
- INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg
- INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count
- INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
- INTEGER :: dummybuf(1)
- INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag
- CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess
- INTEGER, EXTERNAL :: use_package
- LOGICAL :: stored_write_record, retval
- INTEGER iii, jjj, vid, CC, DD
- LOGICAL :: call_server_ready
- logical okay_to_w
- character*120 sysline
- ! If we've been built with PNETCDF_QUILT defined then we use parallel I/O
- ! within the group of I/O servers rather than gathering the data onto the
- ! root I/O server. Unfortunately, this approach means that we can no-longer
- ! select different I/O layers for use with quilting at run time. ARPDBG.
- ! This code is sufficiently different that it is kept in the separate
- ! quilt_pnc() routine.
- #ifdef PNETCDF_QUILT
- CALL quilt_pnc()
- RETURN
- #endif
- ! Call ext_pkg_ioinit() routines to initialize I/O packages.
- SysDepInfo = " "
- #ifdef NETCDF
- CALL ext_ncd_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef INTIO
- CALL ext_int_ioinit( SysDepInfo, ierr )
- #endif
- #ifdef XXX
- CALL ext_xxx_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef YYY
- CALL ext_yyy_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef ZZZ
- CALL ext_zzz_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef GRIB1
- CALL ext_gr1_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef GRIB2
- CALL ext_gr2_ioinit( SysDepInfo, ierr)
- #endif
- call_server_ready = .true. ! = true when the server is ready for a new file
- okay_to_commit = .false.
- stored_write_record = .false.
- ninbuf = 0
- ! get info. about the I/O server group that this I/O server task
- ! belongs to
- ! Last task in this I/O server group is the I/O server "root"
- ! The I/O server "root" actually writes data to disk
- ! TBH: WARNING: This is also implicit in the call to collect_on_comm().
- CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr )
- CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr )
- CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr )
- CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr )
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- IF ( itypesize <= 0 ) THEN
- CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid")
- ENDIF
- ! Work out whether this i/o server processor has one fewer associated compute proc than
- ! the most any processor has. Can happen when number of i/o tasks does not evenly divide
- ! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the
- ! same message when they start commmunicating to stitch together an output.
- !
- ! Compute processes associated with this task:
- CC = ntasks_io_group - 1
- ! Number of compute tasks per I/O task (less remainder)
- DD = ncompute_tasks / ntasks_local_group
- !
- ! If CC-DD is 1 on servrs with the maximum number of compute clients,
- ! 0 on servrs with one less than maximum
- ! infinite loop until shutdown message received
- ! This is the main request-handling loop. I/O quilt servers stay in this loop
- ! until the model run ends.
- okay_to_w = .false.
- DO WHILE (.TRUE.) ! {
- !<DESCRIPTION>
- ! Each I/O server receives requests from its compute tasks. Each request
- ! is contained in a data header (see module_internal_header_util.F for
- ! detailed descriptions of data headers).
- ! Each request is sent in two phases. First, sizes of all messages that
- ! will be sent from the compute tasks to this I/O server are summed on the
- ! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf"
- ! and receives concatenated messages from the compute tasks in it via the
- ! call to collect_on_comm(). Note that "sizes" are generally expressed in
- ! *bytes* in this code so conversion to "count" (number of Fortran words) is
- ! required for Fortran indexing and MPI calls.
- !</DESCRIPTION>
- if(poll_servers .and. call_server_ready) then
- call_server_ready=.false.
- ! Send a message to the monitor telling it we're ready
- ! for a new data handle.
- call wrf_quilt_server_ready()
- endif
- ! wait for info from compute tasks in the I/O group that we're ready to rock
- ! obufsize will contain number of *bytes*
- !CALL start_timing()
- ! first element of reduced is obufsize, second is DataHandle
- ! if needed (currently needed only for ioclose).
- reduced_dummy = 0
- CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1), ierr )
- obufsize = reduced(1)
- !CALL end_timing("MPI_Reduce at top of forever loop")
- !JMDEBUGwrite(0,*)'obufsize = ',obufsize
- ! Negative obufsize will trigger I/O server exit.
- IF ( obufsize .LT. 0 ) THEN
- IF ( obufsize .EQ. -100 ) THEN ! magic number
- #ifdef NETCDF
- CALL ext_ncd_ioexit( Status )
- #endif
- #ifdef INTIO
- CALL ext_int_ioexit( Status )
- #endif
- #ifdef XXX
- CALL ext_xxx_ioexit( Status )
- #endif
- #ifdef YYY
- CALL ext_yyy_ioexit( Status )
- #endif
- #ifdef ZZZ
- CALL ext_zzz_ioexit( Status )
- #endif
- #ifdef GRIB1
- CALL ext_gr1_ioexit( Status )
- #endif
- #ifdef GRIB2
- CALL ext_gr2_ioexit( Status )
- #endif
- CALL wrf_message ( 'I/O QUILT SERVERS DONE' )
- CALL mpi_finalize(ierr)
- STOP
- ELSE
- WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.'
- CALL wrf_error_fatal(mess)
- ENDIF
- ENDIF
- ! CALL start_timing()
- ! Obufsize of zero signals a close
- ! Allocate buffer obuf to be big enough for the data the compute tasks
- ! will send. Note: obuf is size in *bytes* so we need to pare this
- ! down, since the buffer is INTEGER.
- IF ( obufsize .GT. 0 ) THEN
- ALLOCATE( obuf( (obufsize+1)/itypesize ) )
- ! let's roll; get the data from the compute procs and put in obuf
- CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1), &
- onebyte, &
- dummy, 0, &
- obuf, obufsize )
- ! CALL end_timing( "quilt on server: collecting data from compute procs" )
- ELSE
- ! Necessarily, the compute processes send the ioclose signal,
- ! if there is one, after the iosync, which means they
- ! will stall on the ioclose message waiting for the quilt
- ! processes if we handle the way other messages are collected,
- ! using collect_on_comm. This avoids this, but we need
- ! a special signal (obufsize zero) and the DataHandle
- ! to be closed. That handle is send as the second
- ! word of the io_close message received by the MPI_Reduce above.
- ! Then a header representing the ioclose message is constructed
- ! here and handled below as if it were received from the
- ! compute processes. The clients (compute processes) must be
- ! careful to send this correctly (one compule process sends the actual
- ! handle and everone else sends a zero, so the result sums to
- ! the value of the handle).
- !
- ALLOCATE( obuf( 4096 ) )
- ! DataHandle is provided as second element of reduced
- CALL int_gen_handle_header( obuf, obufsize, itypesize, &
- reduced(2) , int_ioclose )
- if(poll_servers) then
- ! Once we're done closing, we need to tell the master
- ! process that we're ready for more data.
- call_server_ready=.true.
- endif
- ENDIF
- !write(0,*)'calling init_store_piece_of_field'
- ! Now all messages received from the compute clients are stored in
- ! obuf. Scan through obuf and extract headers and field data and store in
- ! internal buffers. The scan is done twice, first to determine sizes of
- ! internal buffers required for storage of headers and fields and second to
- ! actually store the headers and fields. This bit of code does not do the
- ! "quilting" (assembly of patches into full domains). For each field, it
- ! simply concatenates all received patches for the field into a separate
- ! internal buffer (i.e. one buffer per field). Quilting is done later by
- ! routine store_patch_in_outbuf().
- CALL init_store_piece_of_field
- CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr )
- !write(0,*)'mpi_type_size returns ', itypesize
- ! Scan obuf the first time to calculate the size of the buffer required for
- ! each field. Calls to add_to_bufsize_for_field() accumulate sizes.
- vid = 0
- icurs = itypesize
- num_noops = 0
- num_commit_messages = 0
- num_field_training_msgs = 0
- DO WHILE ( icurs .lt. obufsize ) ! {
- hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
- SELECT CASE ( hdr_tag )
- CASE ( int_field )
- CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
- DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
- (PatchEnd(3)-PatchStart(3)+1)*ftypesize
- IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks
- IF ( num_field_training_msgs .EQ. 0 ) THEN
- call add_to_bufsize_for_field( VarName, hdrbufsize )
- !write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- num_field_training_msgs = num_field_training_msgs + 1
- ELSE
- call add_to_bufsize_for_field( VarName, hdrbufsize )
- !write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- icurs = icurs + hdrbufsize
- !write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ! If this is a real write (i.e. not a training write), accumulate
- ! buffersize for this field.
- IF ( DomainDesc .NE. 333933 ) THEN ! magic number
- !write(0,*) 'X-1a', chunksize, TRIM(VarName)
- call add_to_bufsize_for_field( VarName, chunksize )
- icurs = icurs + chunksize
- ENDIF
- CASE ( int_open_for_write_commit ) ! only one per group of tasks
- hdrbufsize = obuf(icurs/itypesize)
- IF (num_commit_messages.EQ.0) THEN
- call add_to_bufsize_for_field( 'COMMIT', hdrbufsize )
- ENDIF
- num_commit_messages = num_commit_messages + 1
- icurs = icurs + hdrbufsize
- CASE DEFAULT
- hdrbufsize = obuf(icurs/itypesize)
- ! This logic and the logic in the loop below is used to determine whether
- ! to send a noop records sent by the compute processes to allow to go
- ! through. The purpose is to make sure that the communications between this
- ! server and the other servers in this quilt group stay synchronized in
- ! the collection loop below, even when the servers are serving different
- ! numbers of clients. Here are some conditions:
- !
- ! 1. The number of compute clients served will not differ by more than 1
- ! 2. The servers with +1 number of compute clients begin with task 0
- ! of mpi_comm_local, the commicator shared by this group of servers
- !
- ! 3. For each collective field or metadata output from the compute tasks,
- ! there will be one record sent to the associated i/o server task. The
- ! i/o server task collects these records and stores them contiguously
- ! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this
- ! server task will contain one record from each associated compute
- ! task, in order.
- !
- ! 4. In the case of replicated output from the compute tasks
- ! (e.g. put_dom_ti records and control records like
- ! open_for_write_commit type records), compute task 0 is the only
- ! one that sends the record. The other compute tasks send noop
- ! records. Thus, obuf on server task zero will contain the output
- ! record from task 0 followed by noop records from the rest of the
- ! compute tasks associated with task 0. Obuf on the other server
- ! tasks will contain nothing but noop records.
- !
- ! 5. The logic below will not allow any noop records from server task 0.
- ! It allows only one noop record from each of the other server tasks
- ! in the i/o group. This way, for replicated output, when the records
- ! are collected on one server task below, using collect_on_comm on
- ! mpi_comm_local, each task will provide exactly one record for each
- ! call to collect_on_comm: 1 bona fide output record from server task
- ! 0 and noops from the rest.
- IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) &
- .OR.hdr_tag.NE.int_noop) THEN
- write(VarName,'(I5.5)')vid
- !write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- call add_to_bufsize_for_field( VarName, hdrbufsize )
- vid = vid+1
- ENDIF
- IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
- icurs = icurs + hdrbufsize
- END SELECT
- ENDDO ! }
- ! Store the headers and field data in internal buffers. The first call to
- ! store_piece_of_field() allocates internal buffers using sizes computed by
- ! calls to add_to_bufsize_for_field().
- vid = 0
- icurs = itypesize
- num_noops = 0
- num_commit_messages = 0
- num_field_training_msgs = 0
- DO WHILE ( icurs .lt. obufsize ) !{
- !write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize
- hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
- SELECT CASE ( hdr_tag )
- CASE ( int_field )
- CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
- DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
- (PatchEnd(3)-PatchStart(3)+1)*ftypesize
- IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks
- IF ( num_field_training_msgs .EQ. 0 ) THEN
- call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
- !write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- num_field_training_msgs = num_field_training_msgs + 1
- ELSE
- call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
- !write(0,*) 'A-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- icurs = icurs + hdrbufsize
- ! If this is a real write (i.e. not a training write), store
- ! this piece of this field.
- IF ( DomainDesc .NE. 333933 ) THEN ! magic number
- !write(0,*) 'A-1a', chunksize, TRIM(VarName),PatchStart(1:3),PatchEnd(1:3)
- call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize )
- icurs = icurs + chunksize
- ENDIF
- CASE ( int_open_for_write_commit ) ! only one per group of tasks
- hdrbufsize = obuf(icurs/itypesize)
- IF (num_commit_messages.EQ.0) THEN
- call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize )
- ENDIF
- num_commit_messages = num_commit_messages + 1
- icurs = icurs + hdrbufsize
- CASE DEFAULT
- hdrbufsize = obuf(icurs/itypesize)
- IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) &
- .OR.hdr_tag.NE.int_noop) THEN
- write(VarName,'(I5.5)')vid
- !write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
- vid = vid+1
- ENDIF
- IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
- icurs = icurs + hdrbufsize
- END SELECT
- ENDDO !}
- ! Now, for each field, retrieve headers and patches (data) from the internal
- ! buffers and collect them all on the I/O quilt server "root" task.
- CALL init_retrieve_pieces_of_field
- ! Retrieve header and all patches for the first field from the internal
- ! buffers.
- CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
- ! Sum sizes of all headers and patches (data) for this field from all I/O
- ! servers in this I/O server group onto the I/O server "root".
- CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER, MPI_SUM, ntasks_local_group-1, mpi_comm_local, ierr )
- !write(0,*)'seed: sz ',sz,' bigbufsize ',bigbufsize,' VarName ', TRIM(VarName),' retval ',retval
- ! Loop until there are no more fields to retrieve from the internal buffers.
- DO WHILE ( retval ) !{
- #if 0
- #else
- ! I/O server "root" allocates space to collect headers and fields from all
- ! other servers in this I/O server group.
- IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN
- ALLOCATE( bigbuf( (bigbufsize+1)/itypesize ) )
- ENDIF
- ! Collect buffers and fields from all I/O servers in this I/O server group
- ! onto the I/O server "root"
- CALL collect_on_comm_debug2(__FILE__,__LINE__,Trim(VarName), &
- get_hdr_tag(obuf),sz,get_hdr_rec_size(obuf), &
- mpi_comm_local, &
- onebyte, &
- obuf, sz, &
- bigbuf, bigbufsize )
- ! The I/O server "root" now handles collected requests from all compute
- ! tasks served by this I/O server group (i.e. all compute tasks).
- IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN
- !jjj = 4
- !do iii = 1, ntasks_local_group
- ! write(0,*)'i,j,tag,size ', iii, jjj, get_hdr_tag(bigbuf(jjj/4)),get_hdr_rec_size(bigbuf(jjj/4))
- ! jjj = jjj + get_hdr_rec_size(bigbuf(jjj/4))
- !enddo
- icurs = itypesize ! icurs is a byte counter, but buffer is integer
- stored_write_record = .false.
- ! The I/O server "root" loops over the collected requests.
- DO WHILE ( icurs .lt. bigbufsize ) !{
- CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr )
- !write(0,*)'B tag,size ',icurs,get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
- ! The I/O server "root" gets the request out of the next header and
- ! handles it by, in most cases, calling the appropriate external I/O package
- ! interface.
- SELECT CASE ( get_hdr_tag( bigbuf(icurs/itypesize) ) )
- ! The I/O server "root" handles the "noop" (do nothing) request. This is
- ! actually quite easy. "Noop" requests exist to help avoid race conditions.
- ! In some cases, only one compute task will everything about a request so
- ! other compute tasks send "noop" requests.
- CASE ( int_noop )
- CALL int_get_noop_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize )
- icurs = icurs + hdrbufsize
- ! The I/O server "root" handles the "put_dom_td_real" request.
- CASE ( int_dom_td_real )
- CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
- ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, DateStr, Element, RData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( RData )
- ! The I/O server "root" handles the "put_dom_ti_real" request.
- CASE ( int_dom_ti_real )
- !write(0,*)' int_dom_ti_real '
- CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
- ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, Element, RData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- !write(0,*)'ext_ncd_put_dom_ti_real ',handle(DataHandle),TRIM(Element),RData,Status
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( RData )
- ! The I/O server "root" handles the "put_dom_td_integer" request.
- CASE ( int_dom_td_integer )
- !write(0,*)' int_dom_td_integer '
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, DateStr, Element, IData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( IData )
- ! The I/O server "root" handles the "put_dom_ti_integer" request.
- CASE ( int_dom_ti_integer )
- !write(0,*)' int_dom_ti_integer '
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, Element, IData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- !write(0,*)'ext_ncd_put_dom_ti_integer ',handle(DataHandle),TRIM(Element),IData,Status
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( IData)
-
- ! The I/O server "root" handles the "set_time" request.
- CASE ( int_set_time )
- !write(0,*)' int_set_time '
- CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle, Element, VarName, CData, code )
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- icurs = icurs + hdrbufsize
- ! The I/O server "root" handles the "put_dom_ti_char" request.
- CASE ( int_dom_ti_char )
- !write(0,*)' before int_get_ti_header_char '
- CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle, Element, VarName, CData, code )
- !write(0,*)' after int_get_ti_header_char ',VarName
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- icurs = icurs + hdrbufsize
- ! The I/O server "root" handles the "put_var_ti_char" request.
- CASE ( int_var_ti_char )
- !write(0,*)' int_var_ti_char '
- CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle, Element, VarName, CData, code )
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- icurs = icurs + hdrbufsize
- CASE ( int_ioexit )
- ! ioexit is now handled by sending negative message length to server
- CALL wrf_error_fatal( &
- "quilt: should have handled int_ioexit already")
- ! The I/O server "root" handles the "ioclose" request.
- CASE ( int_ioclose )
- CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle , code )
- icurs = icurs + hdrbufsize
- IF ( DataHandle .GE. 1 ) THEN
- !JMDEBUGwrite(0,*)'closing DataHandle ',DataHandle,' io_form ',io_form(DataHandle)
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_ncd_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef PNETCDF
- CASE ( IO_PNETCDF )
- CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_pnc_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_int_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_yyy_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr1_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr2_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- ENDIF
- ! The I/O server "root" handles the "open_for_write_begin" request.
- CASE ( int_open_for_write_begin )
- CALL int_get_ofwb_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
- FileName,SysDepInfo,io_form_arg,DataHandle )
- !write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize
- !write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize
- !JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle
- !write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo)
- icurs = icurs + hdrbufsize
- !write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
-
- io_form(DataHandle) = io_form_arg
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- !write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
-
- okay_to_write(DataHandle) = .false.
- ! The I/O server "root" handles the "open_for_write_commit" request.
- ! In this case, the "okay_to_commit" is simply set to .true. so "write_field"
- ! requests will initiate writes to disk. Actual commit will be done after
- ! all requests in this batch have been handled.
- CASE ( int_open_for_write_commit )
- CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle , code )
- icurs = icurs + hdrbufsize
- okay_to_commit(DataHandle) = .true.
- ! The I/O server "root" handles the "write_field" (int_field) request.
- ! If okay_to_write(DataHandle) is .true. then the patch in the
- ! header (bigbuf) is written to a globally-sized internal output buffer via
- ! the call to store_patch_in_outbuf(). Note that this is where the actual
- ! "quilting" (reassembly of patches onto a full-size domain) is done. If
- ! okay_to_write(DataHandle) is .false. then external I/O package interfaces
- ! are called to write metadata for I/O formats that support native metadata.
- !
- ! NOTE that the I/O server "root" will only see write_field (int_field)
- ! requests AFTER an "iosync" request.
- CASE ( int_field )
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- CALL int_get_write_field_header ( bigbuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
- DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- !write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle)
- icurs = icurs + hdrbufsize
- IF ( okay_to_write(DataHandle) ) THEN
- ! WRITE(0,*)'>>> ',TRIM(DateStr), ' ', TRIM(VarName), ' ', TRIM(MemoryOrder), ' ', &
- ! (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1)
- IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN
- ! Note that the WRF_DOUBLE branch of this IF statement must come first since
- ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds.
- IF ( FieldType .EQ. WRF_DOUBLE) THEN
- ! this branch has not been tested TBH: 20050406
- CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr )
- ELSE
- CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
- ENDIF
- stored_write_record = .true.
- CALL store_patch_in_outbuf ( bigbuf(icurs/itypesize), dummybuf, TRIM(DateStr), TRIM(VarName) , &
- FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- stored_write_record = .true.
- CALL store_patch_in_outbuf ( dummybuf, bigbuf(icurs/itypesize), TRIM(DateStr), TRIM(VarName) , &
- FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
- ftypesize = LWORDSIZE
- ENDIF
- icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
- (PatchEnd(3)-PatchStart(3)+1)*ftypesize
- ELSE
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , &
- TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
- DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- Status )
- #endif
- #if 0
- ! since this is training and the grib output doesn't need training, disable this branch.
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , &
- TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
- DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- Status )
- #endif
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- ENDIF
- CASE ( int_iosync )
- CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle , code )
- icurs = icurs + hdrbufsize
- CASE DEFAULT
- WRITE(mess,*)'quilt: bad tag: ',get_hdr_tag( bigbuf(icurs/itypesize) ),' icurs ',icurs/itypesize
- CALL wrf_error_fatal( mess )
- END SELECT
- ENDDO !}
- ! Now, the I/O server "root" has finshed handling all commands from the latest
- ! call to retrieve_pieces_of_field().
- IF (stored_write_record) THEN
- ! If any fields have been stored in a globally-sized internal output buffer
- ! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write
- ! them to disk now.
- ! NOTE that the I/O server "root" will only have called
- ! store_patch_in_outbuf() when handling write_field (int_field)
- ! commands which only arrive AFTER an "iosync" command.
- ! CALL start_timing
- CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle)))
- ! CALL end_timing( "quilt: call to write_outbuf" )
- ENDIF
- ! If one or more "open_for_write_commit" commands were encountered from the
- ! latest call to retrieve_pieces_of_field() then call the package-specific
- ! routine to do the commit.
- IF (okay_to_commit(DataHandle)) THEN
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_int_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- okay_to_commit(DataHandle) = .false.
- ENDIF
- DEALLOCATE( bigbuf )
- ENDIF
- #endif
- ! Retrieve header and all patches for the next field from the internal
- ! buffers.
- CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
- ! Sum sizes of all headers and patches (data) for this field from all I/O
- ! servers in this I/O server group onto the I/O server "root".
- CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER,MPI_SUM, ntasks_local_group-1,mpi_comm_local, ierr )
- ! Then, return to the top of the loop to collect headers and data from all
- ! I/O servers in this I/O server group onto the I/O server "root" and handle
- ! the next batch of commands.
- END DO !}
- DEALLOCATE( obuf )
- ! flush output files if needed
- IF (stored_write_record) THEN
- ! CALL start_timing()
- SELECT CASE ( use_package(io_form) )
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_iosync( handle(DataHandle), Status )
- #endif
- #ifdef XXX
- CASE ( IO_XXX )
- CALL ext_xxx_iosync( handle(DataHandle), Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_iosync( handle(DataHandle), Status )
- #endif
- #ifdef ZZZ
- CASE ( IO_ZZZ )
- CALL ext_zzz_iosync( handle(DataHandle), Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_iosync( handle(DataHandle), Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_iosync( handle(DataHandle), Status )
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_iosync( handle(DataHandle), Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- !CALL end_timing( "quilt: flush" )
- ENDIF
- END DO ! }
- END SUBROUTINE quilt
- SUBROUTINE quilt_pnc
- !<DESCRIPTION>
- ! Same as quilt() routine except that _all_ of the IO servers that call it
- ! actually write data to disk using pNetCDF. This version is only used when
- ! the code is compiled with PNETCDF_QUILT defined.
- !</DESCRIPTION>
- USE module_state_description
- USE module_quilt_outbuf_ops
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- #include "wrf_io_flags.h"
- INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr
- INTEGER istat
- INTEGER mytask_io_group
- INTEGER :: nout_set = 0
- INTEGER :: obufsize, bigbufsize, chunksize, sz
- REAL, DIMENSION(1) :: dummy
- INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf
- REAL, ALLOCATABLE, DIMENSION(:) :: RDATA
- INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA
- CHARACTER (LEN=512) :: CDATA
- CHARACTER (LEN=80) :: fname
- INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg
- INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count
- INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
- INTEGER :: dummybuf(1)
- INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag
- CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess
- INTEGER, EXTERNAL :: use_package
- LOGICAL :: stored_write_record, retval, written_record
- INTEGER iii, jjj, vid, CC, DD
- ! logical okay_to_w
- ! character*120 sysline
- ! Call ext_pkg_ioinit() routines to initialize I/O packages.
- SysDepInfo = " "
- #ifdef NETCDF
- CALL ext_ncd_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef PNETCDF_QUILT
- CALL ext_pnc_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef INTIO
- CALL ext_int_ioinit( SysDepInfo, ierr )
- #endif
- #ifdef XXX
- CALL ext_xxx_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef YYY
- CALL ext_yyy_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef ZZZ
- CALL ext_zzz_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef GRIB1
- CALL ext_gr1_ioinit( SysDepInfo, ierr)
- #endif
- #ifdef GRIB2
- CALL ext_gr2_ioinit( SysDepInfo, ierr)
- #endif
- okay_to_commit = .false.
- stored_write_record = .false.
- ninbuf = 0
- ! get info. about the I/O server group that this I/O server task
- ! belongs to
- CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr )
- CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr )
- CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr )
- CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr )
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- IF ( itypesize <= 0 ) THEN
- CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid")
- ENDIF
- ! Work out whether this i/o server processor has one fewer associated compute proc than
- ! the most any processor has. Can happen when number of i/o tasks does not evenly divide
- ! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the
- ! same message when they start commmunicating to stitch together an output.
- !
- ! Compute processes associated with this task:
- CC = ntasks_io_group - 1
- ! Number of compute tasks per I/O task (less remainder)
- DD = ncompute_tasks / ntasks_local_group
- !
- ! If CC-DD is 1 on servrs with the maximum number of compute clients,
- ! 0 on servrs with one less than maximum
- ! infinite loop until shutdown message received
- ! This is the main request-handling loop. I/O quilt servers stay in this loop
- ! until the model run ends.
- !okay_to_w = .false.
- DO WHILE (.TRUE.) ! {
- !<DESCRIPTION>
- ! Each I/O server receives requests from its compute tasks. Each request
- ! is contained in a data header (see module_internal_header_util.F for
- ! detailed descriptions of data headers).
- ! Each request is sent in two phases. First, sizes of all messages that
- ! will be sent from the compute tasks to this I/O server are summed on the
- ! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf"
- ! and receives concatenated messages from the compute tasks in it via the
- ! call to collect_on_comm(). Note that "sizes" are generally expressed in
- ! *bytes* in this code so conversion to "count" (number of Fortran words) is
- ! required for Fortran indexing and MPI calls.
- !</DESCRIPTION>
- ! wait for info from compute tasks in the I/O group that we're ready to rock
- ! obufsize will contain number of *bytes*
- !CALL start_timing
- ! first element of reduced is obufsize, second is DataHandle
- ! if needed (currently needed only for ioclose).
- reduced_dummy = 0
- CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1), ierr )
- obufsize = reduced(1)
- !CALL end_timing("MPI_Reduce at top of forever loop")
- !JMDEBUGwrite(0,*)'obufsize = ',obufsize
- ! Negative obufsize will trigger I/O server exit.
- IF ( obufsize .LT. 0 ) THEN
- IF ( obufsize .EQ. -100 ) THEN ! magic number
- #ifdef NETCDF
- CALL ext_ncd_ioexit( Status )
- #endif
- #ifdef PNETCDF_QUILT
- CALL ext_pnc_ioexit( Status )
- #endif
- #ifdef INTIO
- CALL ext_int_ioexit( Status )
- #endif
- #ifdef XXX
- CALL ext_xxx_ioexit( Status )
- #endif
- #ifdef YYY
- CALL ext_yyy_ioexit( Status )
- #endif
- #ifdef ZZZ
- CALL ext_zzz_ioexit( Status )
- #endif
- #ifdef GRIB1
- CALL ext_gr1_ioexit( Status )
- #endif
- #ifdef GRIB2
- CALL ext_gr2_ioexit( Status )
- #endif
- CALL wrf_message ( 'I/O QUILT SERVERS DONE' )
- CALL mpi_finalize(ierr)
- STOP
- ELSE
- WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.'
- CALL wrf_error_fatal(mess)
- ENDIF
- ENDIF
- ! CALL start_timing
- ! Obufsize of zero signals a close
- ! Allocate buffer obuf to be big enough for the data the compute tasks
- ! will send. Note: obuf is size in *bytes* so we need to pare this
- ! down, since the buffer is INTEGER.
- IF ( obufsize .GT. 0 ) THEN
- ALLOCATE( obuf( (obufsize+1)/itypesize ) )
- ! let's roll; get the data from the compute procs and put in obuf
- CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1), &
- onebyte, &
- dummy, 0, &
- obuf, obufsize )
- ! CALL end_timing( "quilt on server: collecting data from compute procs" )
- ELSE
- ! Necessarily, the compute processes send the ioclose signal,
- ! if there is one, after the iosync, which means they
- ! will stall on the ioclose message waiting for the quilt
- ! processes if we handle the way other messages are collected,
- ! using collect_on_comm. This avoids this, but we need
- ! a special signal (obufsize zero) and the DataHandle
- ! to be closed. That handle is send as the second
- ! word of the io_close message received by the MPI_Reduce above.
- ! Then a header representing the ioclose message is constructed
- ! here and handled below as if it were received from the
- ! compute processes. The clients (compute processes) must be
- ! careful to send this correctly (one compule process sends the actual
- ! handle and everone else sends a zero, so the result sums to
- ! the value of the handle).
- !
- ALLOCATE( obuf( 4096 ) )
- ! DataHandle is provided as second element of reduced
- CALL int_gen_handle_header( obuf, obufsize, itypesize, &
- reduced(2) , int_ioclose )
- ENDIF
- !write(0,*)'calling init_store_piece_of_field'
- ! Now all messages received from the compute clients are stored in
- ! obuf. Scan through obuf and extract headers and field data and store in
- ! internal buffers. The scan is done twice, first to determine sizes of
- ! internal buffers required for storage of headers and fields and second to
- ! actually store the headers and fields. This bit of code does not do any
- ! "quilting" (assembly of patches into full domains). For each field, it
- ! simply writes all received patches for the field to disk.
- ! ARPDBG we can vastly reduce the number of writes to disk by stitching
- ! any contiguous patches together first. Has implications for synchronisation
- ! of pNetCDF calls though.
- CALL init_store_piece_of_field
- CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr )
- !write(0,*)'mpi_type_size returns ', itypesize
- ! Scan obuf the first time to calculate the size of the buffer required for
- ! each field. Calls to add_to_bufsize_for_field() accumulate sizes.
- vid = 0
- icurs = itypesize
- num_noops = 0
- num_commit_messages = 0
- num_field_training_msgs = 0
- DO WHILE ( icurs .lt. obufsize ) ! {
- hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
- SELECT CASE ( hdr_tag )
- CASE ( int_field )
- CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
- DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
- (PatchEnd(3)-PatchStart(3)+1)*ftypesize
- IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks
- IF ( num_field_training_msgs .EQ. 0 ) THEN
- call add_to_bufsize_for_field( VarName, hdrbufsize )
- !write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- num_field_training_msgs = num_field_training_msgs + 1
- ELSE
- call add_to_bufsize_for_field( VarName, hdrbufsize )
- !write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- icurs = icurs + hdrbufsize
- !write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ! If this is a real write (i.e. not a training write), accumulate
- ! buffersize for this field.
- IF ( DomainDesc .NE. 333933 ) THEN ! magic number
- !write(0,*) 'X-1a', chunksize, TRIM(VarName)
- call add_to_bufsize_for_field( VarName, chunksize )
- icurs = icurs + chunksize
- ENDIF
- CASE ( int_open_for_write_commit ) ! only one per group of tasks
- hdrbufsize = obuf(icurs/itypesize)
- IF (num_commit_messages.EQ.0) THEN
- call add_to_bufsize_for_field( 'COMMIT', hdrbufsize )
- ENDIF
- num_commit_messages = num_commit_messages + 1
- icurs = icurs + hdrbufsize
- CASE DEFAULT
- hdrbufsize = obuf(icurs/itypesize)
- ! This logic and the logic in the loop below is used to determine whether
- ! to send a noop records sent by the compute processes to allow to go
- ! through. The purpose is to make sure that the communications between this
- ! server and the other servers in this quilt group stay synchronized in
- ! the collection loop below, even when the servers are serving different
- ! numbers of clients. Here are some conditions:
- !
- ! 1. The number of compute clients served will not differ by more than 1
- ! 2. The servers with +1 number of compute clients begin with task 0
- ! of mpi_comm_local, the commicator shared by this group of servers
- !
- ! 3. For each collective field or metadata output from the compute tasks,
- ! there will be one record sent to the associated i/o server task. The
- ! i/o server task collects these records and stores them contiguously
- ! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this
- ! server task will contain one record from each associated compute
- ! task, in order.
- ! !
- ! 4. In the case of replicated output from the compute tasks
- ! (e.g. put_dom_ti records and control records like
- ! open_for_write_commit type records), only compute tasks for which
- ! (compute_group_master == .TRUE) send the record. The other compute
- ! tasks send noop records. This is done so that each server task
- ! receives exactly one record plus noops from the other compute tasks.
- !
- ! 5. Logic below does not allow any noop records through since each IO
- ! server task now receives a valid record (from the 'compute-group master'
- ! when doing replicated output
- IF (hdr_tag.NE.int_noop) THEN
- write(VarName,'(I5.5)')vid
- !write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- call add_to_bufsize_for_field( VarName, hdrbufsize )
- vid = vid+1
- ENDIF
- IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
- icurs = icurs + hdrbufsize
- END SELECT
- ENDDO ! }
- ! Store the headers and field data in internal buffers. The first call to
- ! store_piece_of_field() allocates internal buffers using sizes computed by
- ! calls to add_to_bufsize_for_field().
- vid = 0
- icurs = itypesize
- num_noops = 0
- num_commit_messages = 0
- num_field_training_msgs = 0
- DO WHILE ( icurs .lt. obufsize ) !{
- !write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize
- hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
- SELECT CASE ( hdr_tag )
- CASE ( int_field )
- CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
- DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* &
- (PatchEnd(3)-PatchStart(3)+1)*ftypesize
- IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks
- IF ( num_field_training_msgs .EQ. 0 ) THEN
- call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
- !write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- num_field_training_msgs = num_field_training_msgs + 1
- ELSE
- call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
- !write(0,*) 'A-2a', icurs, hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- ENDIF
- icurs = icurs + hdrbufsize
- ! If this is a real write (i.e. not a training write), store
- ! this piece of this field.
- IF ( DomainDesc .NE. 333933 ) THEN ! magic number
- call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize )
- icurs = icurs + chunksize
- !write(0,*) 'A-1a',TRIM(VarName),' icurs ',icurs,PatchStart(1:3),PatchEnd(1:3)
- ENDIF
- CASE ( int_open_for_write_commit ) ! only one per group of tasks
- hdrbufsize = obuf(icurs/itypesize)
- IF (num_commit_messages.EQ.0) THEN
- call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize )
- ENDIF
- num_commit_messages = num_commit_messages + 1
- icurs = icurs + hdrbufsize
- CASE DEFAULT
- hdrbufsize = obuf(icurs/itypesize)
- IF (hdr_tag.NE.int_noop) THEN
- write(VarName,'(I5.5)')vid
- !write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
- call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
- vid = vid+1
- ENDIF
- IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
- icurs = icurs + hdrbufsize
- END SELECT
- ENDDO !} while(icurs < obufsize)
- ! Now, for each field, retrieve headers and patches (data) from the internal
- ! buffers
- CALL init_retrieve_pieces_of_field
- ! Retrieve header and all patches for the first field from the internal
- ! buffers.
- CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
- written_record = .false.
- ! Loop until there are no more fields to retrieve from the internal buffers.
- DO WHILE ( retval ) !{
- ! This I/O server now handles the collected requests from the compute
- ! tasks it serves
- icurs = itypesize ! icurs is a byte counter, but buffer is integer
- stored_write_record = .false.
- ! ALL I/O servers in this group loop over the collected requests they have
- ! received.
- DO WHILE ( icurs .lt. sz)! bigbufsize ) !{
- ! The I/O server gets the request out of the next header and
- ! handles it by, in most cases, calling the appropriate external I/O package
- ! interface.
- !write(0,*)__FILE__,__LINE__,'get_hdr_tag ',icurs,sz,get_hdr_tag( obuf(icurs/itypesize) )
- SELECT CASE ( get_hdr_tag( obuf(icurs/itypesize) ) )
- ! The I/O server handles the "noop" (do nothing) request. This is
- ! actually quite easy. "Noop" requests exist to help avoid race conditions.
- CASE ( int_noop )
- CALL int_get_noop_header( obuf(icurs/itypesize), &
- hdrbufsize, itypesize )
- icurs = icurs + hdrbufsize
- ! The I/O server "root" handles the "put_dom_td_real" request.
- CASE ( int_dom_td_real )
- CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
- ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, DateStr, Element, RData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE (IO_PNETCDF )
- CALL ext_pnc_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( RData )
- ! Every I/O server handles the "put_dom_ti_real" request.
- CASE ( int_dom_ti_real )
- CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
- ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, Element, RData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE (IO_PNETCDF )
- CALL ext_pnc_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( RData )
- ! Every I/O server handles the "put_dom_td_integer" request.
- CASE ( int_dom_td_integer )
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, DateStr, Element, IData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE (IO_PNETCDF )
- CALL ext_pnc_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( IData )
- ! Every I/O server handles the "put_dom_ti_integer" request.
- CASE ( int_dom_ti_integer )
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
- CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
- DataHandle, Element, IData, Count, code )
- icurs = icurs + hdrbufsize
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE (IO_PNETCDF )
- CALL ext_pnc_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- DEALLOCATE( IData)
-
- ! Every I/O server handles the "set_time" request.
- CASE ( int_set_time )
- CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle, Element, VarName, CData, code )
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- icurs = icurs + hdrbufsize
- ! Every I/O server handles the "put_dom_ti_char" request.
- CASE ( int_dom_ti_char )
- CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle, Element, VarName, CData, code )
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE (IO_PNETCDF )
- CALL ext_pnc_put_dom_ti_char ( handle(DataHandle), TRIM(Element), Trim(CData), Status)
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- icurs = icurs + hdrbufsize
- ! Every I/O server handles the "put_var_ti_char" request.
- CASE ( int_var_ti_char )
- CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle, Element, VarName, CData, code )
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE (IO_PNETCDF )
- CALL ext_pnc_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status )
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- icurs = icurs + hdrbufsize
- CASE ( int_ioexit )
- ! ioexit is now handled by sending negative message length to server
- CALL wrf_error_fatal( &
- "quilt: should have handled int_ioexit already")
- ! Every I/O server handles the "ioclose" request.
- CASE ( int_ioclose )
- CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle , code )
- icurs = icurs + hdrbufsize
- IF ( DataHandle .GE. 1 ) THEN
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE ( IO_PNETCDF )
- CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_pnc_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_ncd_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_int_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_yyy_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr1_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr2_ioclose(handle(DataHandle),Status)
- ENDIF
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- ENDIF
- ! Every I/O server handles the "open_for_write_begin" request.
- CASE ( int_open_for_write_begin )
- CALL int_get_ofwb_header( obuf(icurs/itypesize), hdrbufsize, itypesize, &
- FileName,SysDepInfo,io_form_arg,DataHandle )
- !write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize
- !write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize
- !JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle
- !write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo)
- icurs = icurs + hdrbufsize
- !write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
-
- io_form(DataHandle) = io_form_arg
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE (IO_PNETCDF )
- CALL ext_pnc_open_for_write_begin(FileName,mpi_comm_local,mpi_comm_local,SysDepInfo,handle(DataHandle),Status )
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- !write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
-
- okay_to_write(DataHandle) = .false.
- ! Every I/O server handles the "open_for_write_commit" request.
- ! In this case, the "okay_to_commit" is simply set to .true. so "write_field"
- ! (int_field) requests will initiate writes to disk. Actual commit will be done after
- ! all requests in this batch have been handled.
- CASE ( int_open_for_write_commit )
- CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle , code )
- icurs = icurs + hdrbufsize
- okay_to_commit(DataHandle) = .true.
- ! Every I/O server handles the "write_field" (int_field) request.
- ! If okay_to_write(DataHandle) is .true. then the patch in the
- ! header (bigbuf) is written to disk using pNetCDF. Note that this is where the actual
- ! "quilting" (reassembly of patches onto a full-size domain) is done. If
- ! okay_to_write(DataHandle) is .false. then external I/O package interfaces
- ! are called to write metadata for I/O formats that support native metadata.
- !
- ! NOTE that the I/O servers will only see write_field (int_field)
- ! requests AFTER an "iosync" request.
- CASE ( int_field )
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
- DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- !write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle)
- icurs = icurs + hdrbufsize
- IF ( okay_to_write(DataHandle) ) THEN
- !!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,A2,I6,1x,3('[',I3,',',I3,'] '))") &
- !!$ TRIM(DateStr), TRIM(VarName), TRIM(MemoryOrder), &
- !!$ (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1), &
- !!$PatchStart(1),PatchEnd(1),PatchStart(2),PatchEnd(2),PatchStart(3),PatchEnd(3)
- !!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") &
- !!$ TRIM(DateStr), TRIM(VarName), DomainDesc, &
- !!$ DomainStart(1),DomainEnd(1),DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3)
- IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN
- ! Note that the WRF_DOUBLE branch of this IF statement must come first since
- ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds.
- IF ( FieldType .EQ. WRF_DOUBLE) THEN
- ! this branch has not been tested TBH: 20050406
- CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr )
- ELSE
- CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
- ENDIF
- #ifdef PNETCDF_QUILT
- ! WRITE(mess,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") &
- ! TRIM(DateStr), TRIM(VarName), DomainDesc, &
- ! DomainStart(1),DomainEnd(1), &
- ! DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3)
- ! CALL wrf_message(mess)
- CALL store_patch_in_outbuf_pnc(obuf(icurs/itypesize), &
- dummybuf, TRIM(DateStr), &
- TRIM(VarName) , &
- FieldType, &
- TRIM(MemoryOrder), &
- TRIM(Stagger), &
- DimNames, &
- DomainStart , DomainEnd ,&
- MemoryStart , MemoryEnd ,&
- PatchStart , PatchEnd, &
- ntasks_io_group-1 )
- stored_write_record = .true.
- !!$ IF(VarName .eq. "PSFC")THEN
- !!$ CALL dump_real_array_c(obuf(icurs/itypesize), DomainStart,&
- !!$ DomainEnd, PatchStart, PatchEnd, &
- !!$ mytask_local, DomainDesc)
- !!$ ENDIF
- #endif
- ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
- CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
- #ifdef PNETCDF_QUILT
- CALL store_patch_in_outbuf_pnc ( dummybuf, &
- obuf(icurs/itypesize) , &
- TRIM(DateStr) , &
- TRIM(VarName) , &
- FieldType, &
- TRIM(MemoryOrder) , &
- TRIM(Stagger), DimNames, &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd , &
- ntasks_io_group-1 )
- stored_write_record = .true.
- #endif
- ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
- ftypesize = LWORDSIZE
- ENDIF
- icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)* &
- (PatchEnd(2)-PatchStart(2)+1)* &
- (PatchEnd(3)-PatchStart(3)+1)*ftypesize
- ELSE ! Write metadata only (or do 'training'?)
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE ( IO_PNETCDF )
- CALL ext_pnc_write_field ( handle(DataHandle) , TRIM(DateStr), &
- TRIM(VarName) , dummy , FieldType , mpi_comm_local , mpi_comm_local, &
- DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger), DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd, &
- Status )
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , &
- TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
- DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- Status )
- #endif
- #if 0
- ! since this is training and the grib output doesn't need training, disable this branch.
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , &
- TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
- DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- DomainStart , DomainEnd , &
- Status )
- #endif
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- ENDIF
- CASE ( int_iosync )
- CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, &
- DataHandle , code )
- icurs = icurs + hdrbufsize
- CASE DEFAULT
- WRITE(mess,*)'quilt: bad tag: ', &
- get_hdr_tag( obuf(icurs/itypesize) ),' icurs ',&
- icurs/itypesize
- CALL wrf_error_fatal( mess )
- END SELECT
- ENDDO !}
- ! Now, we have finshed handling all commands from the latest
- ! call to retrieve_pieces_of_field().
- IF (stored_write_record) THEN
- ! If any field patches have been stored in internal output buffers
- ! (via a call to store_patch_in_outbuf_pnc()) then call write_outbuf_pnc()
- ! to write them to disk now.
- ! NOTE that the I/O server will only have called
- ! store_patch_in_outbuf() when handling write_field (int_field)
- ! commands which only arrive AFTER an "iosync" command.
- ! CALL start_timing
- #ifdef PNETCDF_QUILT
- CALL write_outbuf_pnc( handle(DataHandle), &
- use_package(io_form(DataHandle)), &
- mpi_comm_local, mytask_local, &
- ntasks_local_group)
- #endif
- ! CALL end_timing( "quilt_pnc: call to write_outbuf_pnc" )
- stored_write_record = .false.
- written_record = .true.
- ENDIF
- ! If one or more "open_for_write_commit" commands were encountered from the
- ! latest call to retrieve_pieces_of_field() then call the package-specific
- ! routine to do the commit.
- IF (okay_to_commit(DataHandle)) THEN
- SELECT CASE (use_package(io_form(DataHandle)))
- #ifdef PNETCDF_QUILT
- CASE ( IO_PNETCDF )
- CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_pnc_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef NETCDF
- CASE ( IO_NETCDF )
- CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef INTIO
- CASE ( IO_INTIO )
- CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_int_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef YYY
- CASE ( IO_YYY )
- CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef GRIB1
- CASE ( IO_GRIB1 )
- CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- #ifdef GRIB2
- CASE ( IO_GRIB2 )
- CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
- IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
- CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status)
- okay_to_write(DataHandle) = .true.
- ENDIF
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- okay_to_commit(DataHandle) = .false.
- ENDIF
- !!endif
- ! Retrieve header and all patches for the next field from the internal
- ! buffers.
- CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
- END DO !}
- DEALLOCATE( obuf )
- ! flush output files if needed
- IF (written_record) THEN
- !CALL start_timing
- SELECT CASE ( use_package(io_form) )
- #ifdef PNETCDF_QUILT
- CASE ( IO_PNETCDF )
- CALL ext_pnc_iosync( handle(DataHandle), Status )
- #endif
- CASE DEFAULT
- Status = 0
- END SELECT
- written_record = .false.
- !CALL end_timing( "quilt_pnc: flush" )
- ENDIF
- END DO ! }
- END SUBROUTINE quilt_pnc
- ! end of #endif of DM_PARALLEL
- #endif
- SUBROUTINE init_module_wrf_quilt
- !<DESCRIPTION>
- ! Both client (compute) and server tasks call this routine to initialize the
- ! module. Routine setup_quilt_servers() is called from this routine to
- ! determine which tasks are compute tasks and which are server tasks. Server
- ! tasks then call routine quilt() and remain there for the rest of the model
- ! run. Compute tasks return from init_module_wrf_quilt() to perform model
- ! computations.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- INTEGER i
- NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups, poll_servers
- INTEGER ntasks, mytask, ierr, io_status
- # if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
- INTEGER thread_support_provided, thread_support_requested
- #endif
- INTEGER mpi_comm_here, temp_poll
- LOGICAL mpi_inited
- LOGICAL esmf_coupling
- !TODO: Change this to run-time switch
- #ifdef ESMFIO
- esmf_coupling = .TRUE.
- #else
- esmf_coupling = .FALSE.
- #endif
- quilting_enabled = .FALSE.
- IF ( disable_quilt ) RETURN
- DO i = 1,int_num_handles
- okay_to_write(i) = .FALSE.
- int_handle_in_use(i) = .FALSE.
- server_for_handle(i) = 0
- int_num_bytes_to_write(i) = 0
- ENDDO
- CALL MPI_INITIALIZED( mpi_inited, ierr )
- IF ( .NOT. mpi_inited ) THEN
- # if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
- thread_support_requested = MPI_THREAD_FUNNELED
- CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr )
- IF ( thread_support_provided .lt. thread_support_requested ) THEN
- CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support")
- ENDIF
- # else
- CALL mpi_init ( ierr )
- # endif
- CALL wrf_set_dm_communicator( MPI_COMM_WORLD )
- CALL wrf_termio_dup
- ENDIF
- CALL wrf_get_dm_communicator( mpi_comm_here )
- CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ;
- CALL mpi_x_comm_size ( mpi_comm_here, ntasks, ierr ) ;
- IF ( mytask .EQ. 0 ) THEN
- OPEN ( unit=27, file="namelist.input", form="formatted", status="old" )
- nio_groups = 1
- nio_tasks_per_group = 0
- poll_servers = .false.
- READ ( 27 , NML = namelist_quilt, IOSTAT=io_status )
- IF (io_status .NE. 0) THEN
- CALL wrf_error_fatal( "ERROR reading namelist namelist_quilt" )
- ENDIF
- CLOSE ( 27 )
- IF ( esmf_coupling ) THEN
- IF ( nio_tasks_per_group > 0 ) THEN
- CALL wrf_error_fatal("frame/module_io_quilt.F: cannot use "// &
- "ESMF coupling with quilt tasks") ;
- ENDIF
- ENDIF
- if(poll_servers) then
- temp_poll=1
- else
- temp_poll=0
- endif
- ENDIF
- CALL mpi_bcast( nio_tasks_per_group , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
- CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
- CALL mpi_bcast( temp_poll , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
- poll_servers = (temp_poll == 1)
- CALL setup_quilt_servers( nio_tasks_per_group, &
- mytask, &
- ntasks, &
- nio_groups, &
- nio_tasks_in_group, &
- mpi_comm_here, &
- mpi_comm_local, &
- mpi_comm_io_groups)
- ! provide the communicator for the integration tasks to RSL
- IF ( compute_node ) THEN
- CALL wrf_set_dm_communicator( mpi_comm_local )
- #ifdef HWRF
- call ATM_SET_COMM(mpi_comm_local)
- #endif
- ELSE
- #ifdef HWRF
- call ATM_LEAVE_COUPLING()
- #endif
- CALL quilt ! will not return on io server tasks
- ENDIF
- #endif
- RETURN
- END SUBROUTINE init_module_wrf_quilt
- #ifdef IBM_REDUCE_BUG_WORKAROUND
- ! These three subroutines re-implement MPI_Reduce on MPI_INTEGER
- ! with OP=MPI_ADD.
- ! This is a workaround for a bug in the IBM MPI implementation.
- ! Some MPI processes will get stuck in MPI_Reduce and not
- ! return until the PREVIOUS I/O server group finishes writing.
- ! This workaround replaces the MPI_Reduce call with many
- ! MPI_Send and MPI_Recv calls that perform the sum on the
- ! root of the communicator.
- ! There are two reduce routines: one for a sum of scalars
- ! and one for a sum of arrays. The get_reduce_tag generates
- ! MPI tags for the communication.
- integer function get_reduce_tag(root,comm)
- implicit none
- include 'mpif.h'
- integer, intent(in) :: comm,root
- integer :: i,j, tag, here
- integer :: ierr,me,size
- integer, pointer :: nexttags(:)
- integer, target :: dummy(1)
- character(255) :: message
- integer(kind=4) :: comm4,hashed
- integer, parameter :: hashsize = 113 ! should be prime, >max_servers+1
- integer, parameter :: tagloop = 100000 ! number of tags reserved per communicator
- integer, parameter :: origin = 1031102 ! lowest tag number we'll use
- integer, save :: nexttag=origin ! next tag to use for a new communicator
- integer, save :: comms(hashsize)=-1, firsttag(hashsize)=0, curtag(hashsize)=0
- ! If integers are not four bytes, this implementation will still
- ! work, but it may be inefficient (O(N) lookup instead of O(1)).
- ! To fix that, an eight byte hash function would be needed, but
- ! integers are four bytes in WRF, so that is not a problem right
- ! now.
- comm4=comm
- call int_hash(comm4,hashed)
- hashed=mod(abs(hashed),hashsize)+1
- if(hashed<0) call wrf_error_fatal('hashed<0')
- do i=0,hashsize-1
- j=1+mod(i+hashed-1,hashsize)
- if(firsttag(j)/=0 .and. comms(j)==comm) then
- ! Found the communicator
- if(curtag(j)-firsttag(j) >= tagloop) then
- ! Hit the max tag number so we need to reset.
- ! To make sure >tagloop reduces don't happen
- ! before someone finishes an old reduce, we
- ! have an MPI_Barrier here.
- !call wrf_message('Hit tagloop limit so calling mpi_barrier in get_reduce_tag...')
- call mpi_barrier(comm,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_barrier')
- !call wrf_message(' ...back from mpi_barrier in get_reduce_tag.')
- curtag(j)=firsttag(j)
- endif
- tag=curtag(j)
- curtag(j)=tag+1
- get_reduce_tag=tag
- return
- endif
- enddo
- ! ==================== HANDLE NEW COMMUNICATORS ====================
- !write(message,'("Found a new communicator ",I0," in get_reduce_tag, so making a tag range for it")') comm
- ! If we get here, the communicator is new to us, so we need
- ! to add it to the hash and give it a new tag.
- ! First, figure out where we'll put the tag in the hashtable
- here=-1
- do i=0,hashsize-1
- j=1+mod(i+hashed-1,hashsize)
- if(firsttag(j)==0) then
- here=j
- exit
- endif
- enddo
- if(here==-1) call wrf_error_fatal('no room in hashtable; increase hashsize in get_reduce_tag (should be >max_servers+1)')
- ! Now, find out the new tag's number. To do this, we need to
- ! get the next tag number that is not used by any ranks.
- call mpi_comm_rank(comm,me,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank')
- call mpi_comm_size(comm,size,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size')
- if(me==root) then
- allocate(nexttags(size))
- else
- nexttags=>dummy
- endif
- call mpi_gather(nexttag,1,MPI_INTEGER,nexttags,1,MPI_INTEGER,root,comm,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_gather')
- if(me==root) then
- nexttag=max(nexttag,maxval(nexttags))
- deallocate(nexttags)
- endif
- call mpi_bcast(nexttag,1,MPI_INTEGER,root,comm,ierr)
- comms(here)=comm
- firsttag(here)=nexttag
- curtag(here)=nexttag
- get_reduce_tag=nexttag
- !write(message,'("Stored comm ",I0," with tag ",I0,"=",I0," in hash element ",I0)') &
- ! comms(here),firsttag(here),curtag(here),here
- !call wrf_message(message)
- nexttag=nexttag+tagloop
- end function get_reduce_tag
- subroutine reduce_add_int_scl(send,recv,count,root,comm)
- implicit none
- include 'mpif.h'
- integer, intent(in) :: count,root,comm
- integer, intent(inout) :: recv
- integer, intent(in) :: send
- integer :: me, size, ierr, you, temp, tag
- character*255 :: message
- if(root<0) call wrf_error_fatal('root is less than 0')
- tag=get_reduce_tag(root,comm)
- !write(message,'("Send/recv to tag ",I0)') tag
- !call wrf_message(message)
- call mpi_comm_rank(comm,me,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank')
- call mpi_comm_size(comm,size,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size')
- if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank')
- if(me==root) then
- recv=send
- do you=0,size-2
- call mpi_recv(temp,1,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr)
- if(ierr/=0) call wrf_error_fatal('error calling mpi_recv')
- recv=recv+temp
- enddo
- else
- call mpi_send(send,1,MPI_INTEGER,root,tag,comm,ierr)
- if(ierr/=0) call wrf_error_fatal('error calling mpi_send')
- endif
- end subroutine reduce_add_int_scl
- subroutine reduce_add_int_arr(sendbuf,recvbuf,count,root,comm)
- implicit none
- include 'mpif.h'
- integer, intent(in) :: count,root,comm
- integer, intent(in) :: sendbuf(count)
- integer, intent(inout) :: recvbuf(count)
- integer :: me, size, ierr, you, tempbuf(count), tag
- character*255 :: message
- if(root<0) call wrf_error_fatal('root is less than 0')
- tag=get_reduce_tag(root,comm)
- !write(message,'("Send/recv to tag ",I0)') tag
- !call wrf_message(message)
- call mpi_comm_rank(comm,me,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank')
- call mpi_comm_size(comm,size,ierr)
- if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size')
- if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank')
- if(me==root) then
- recvbuf=sendbuf
- do you=0,size-2
- call mpi_recv(tempbuf,count,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr)
- if(ierr/=0) call wrf_error_fatal('error calling mpi_recv')
- recvbuf=recvbuf+tempbuf
- enddo
- else
- call mpi_send(sendbuf,count,MPI_INTEGER,root,tag,comm,ierr)
- if(ierr/=0) call wrf_error_fatal('error calling mpi_send')
- endif
- end subroutine reduce_add_int_arr
- #endif
- END MODULE module_wrf_quilt
- !<DESCRIPTION>
- ! Remaining routines in this file are defined outside of the module
- ! either to defeat arg/param type checking or to avoid an explicit use
- ! dependence.
- !</DESCRIPTION>
- SUBROUTINE disable_quilting
- !<DESCRIPTION>
- ! Call this in programs that you never want to be quilting (e.g. real)
- ! Must call before call to init_module_wrf_quilt().
- !</DESCRIPTION>
- USE module_wrf_quilt
- disable_quilt = .TRUE.
- RETURN
- END SUBROUTINE disable_quilting
- LOGICAL FUNCTION use_output_servers()
- !<DESCRIPTION>
- ! Returns .TRUE. if I/O quilt servers are in-use for write operations.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- USE module_wrf_quilt
- use_output_servers = quilting_enabled
- RETURN
- END FUNCTION use_output_servers
- LOGICAL FUNCTION use_input_servers()
- !<DESCRIPTION>
- ! Returns .TRUE. if I/O quilt servers are in-use for read operations.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- USE module_wrf_quilt
- use_input_servers = .FALSE.
- RETURN
- END FUNCTION use_input_servers
- SUBROUTINE wrf_quilt_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
- DataHandle , io_form_arg, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to begin data definition ("training") phase
- ! for writing to WRF dataset FileName. io_form_arg indicates file format.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- USE module_state_description, ONLY: IO_PNETCDF
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- CHARACTER *(*), INTENT(IN) :: FileName
- INTEGER , INTENT(IN) :: Comm_compute , Comm_io
- CHARACTER *(*), INTENT(IN) :: SysDepInfo
- INTEGER , INTENT(OUT) :: DataHandle
- INTEGER , INTENT(IN) :: io_form_arg
- INTEGER , INTENT(OUT) :: Status
- ! Local
- CHARACTER*132 :: locFileName, locSysDepInfo
- INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
- REAL dummy
- INTEGER, EXTERNAL :: use_package
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_begin' )
- CALL int_get_fresh_handle(i)
- okay_to_write(i) = .false.
- DataHandle = i
- locFileName = FileName
- locSysDepInfo = SysDepInfo
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- SELECT CASE(use_package(io_form_arg))
- #ifdef PNETCDF_QUILT
- CASE(IO_PNETCDF)
- IF(compute_group_master(1)) THEN
- CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
- locFileName,locSysDepInfo,io_form_arg,&
- DataHandle )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- END IF
- #endif
- CASE DEFAULT
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
- locFileName,locSysDepInfo,io_form_arg,DataHandle )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- END SELECT
- iserver = get_server_id ( DataHandle )
- !JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin iserver = ', iserver
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- !JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin comm_io_group = ', comm_io_group
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- !JMDEBUGwrite(0,*)'mpi_x_comm_size tasks_in_group ',tasks_in_group, ierr
- !!JMTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) reduced(2) = i
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = i
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_begin")
- ! send data to the i/o processor
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- Status = 0
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_open_for_write_begin
- SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to switch an internal flag to enable output
- ! for the dataset referenced by DataHandle. The call to
- ! wrf_quilt_open_for_write_commit() must be paired with a call to
- ! wrf_quilt_open_for_write_begin().
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(IN ) :: DataHandle
- INTEGER , INTENT(OUT) :: Status
- INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
- REAL dummy
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_commit' )
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- okay_to_write( DataHandle ) = .true.
- ENDIF
- ENDIF
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- #ifdef PNETCDF_QUILT
- !ARP Only want one command to be received by each IO server when using
- !ARP parallel IO
- IF(compute_group_master(1)) THEN
- CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, int_open_for_write_commit )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- END IF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, int_open_for_write_commit )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- iserver = get_server_id ( DataHandle )
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- !!JMTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_commit")
- ! send data to the i/o processor
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- Status = 0
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_open_for_write_commit
- SUBROUTINE wrf_quilt_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
- DataHandle , Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to open WRF dataset FileName for reading.
- ! This routine is called only by client (compute) tasks.
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- CHARACTER *(*), INTENT(IN) :: FileName
- INTEGER , INTENT(IN) :: Comm_compute , Comm_io
- CHARACTER *(*), INTENT(IN) :: SysDepInfo
- INTEGER , INTENT(OUT) :: DataHandle
- INTEGER , INTENT(OUT) :: Status
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_read' )
- DataHandle = -1
- Status = -1
- CALL wrf_error_fatal ( "frame/module_io_quilt.F: wrf_quilt_open_for_read not yet supported" )
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_open_for_read
- SUBROUTINE wrf_quilt_inquire_opened ( DataHandle, FileName , FileStatus, Status )
- !<DESCRIPTION>
- ! Inquire if the dataset referenced by DataHandle is open.
- ! Does not require communication with I/O servers.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- #include "wrf_io_flags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER *(*), INTENT(IN) :: FileName
- INTEGER , INTENT(OUT) :: FileStatus
- INTEGER , INTENT(OUT) :: Status
- Status = 0
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_opened' )
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- IF ( okay_to_write( DataHandle ) ) THEN
- FileStatus = WRF_FILE_OPENED_FOR_WRITE
- ENDIF
- ENDIF
- ENDIF
- Status = 0
-
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_inquire_opened
- SUBROUTINE wrf_quilt_inquire_filename ( DataHandle, FileName , FileStatus, Status )
- !<DESCRIPTION>
- ! Return the Filename and FileStatus associated with DataHandle.
- ! Does not require communication with I/O servers.
- !
- ! Note that the current implementation does not actually return FileName.
- ! Currenlty, WRF does not use this returned value. Fixing this would simply
- ! require saving the file names on the client tasks in an array similar to
- ! okay_to_write().
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- #include "wrf_io_flags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER *(*), INTENT(OUT) :: FileName
- INTEGER , INTENT(OUT) :: FileStatus
- INTEGER , INTENT(OUT) :: Status
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_filename' )
- Status = 0
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- IF ( okay_to_write( DataHandle ) ) THEN
- FileStatus = WRF_FILE_OPENED_FOR_WRITE
- ELSE
- FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
- ENDIF
- ELSE
- FileStatus = WRF_FILE_NOT_OPENED
- ENDIF
- Status = 0
- FileName = "bogusfornow"
- ELSE
- Status = -1
- ENDIF
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_inquire_filename
- SUBROUTINE wrf_quilt_iosync ( DataHandle, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to synchronize the disk copy of a dataset
- ! with memory buffers.
- !
- ! After the "iosync" header (request) is sent to the I/O quilt server,
- ! the compute tasks will then send the entire contents (headers and data) of
- ! int_local_output_buffer to their I/O quilt server. This communication is
- ! done in subroutine send_to_io_quilt_servers(). After the I/O quilt servers
- ! receive this data, they will write all accumulated fields to disk.
- !
- ! Significant time may be required for the I/O quilt servers to organize
- ! fields and write them to disk. Therefore, the "iosync" request should be
- ! sent only when the compute tasks are ready to run for a while without
- ! needing to communicate with the servers. Otherwise, the compute tasks
- ! will end up waiting for the servers to finish writing to disk, thus wasting
- ! any performance benefits of having servers at all.
- !
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && ! defined (STUBMPI)
- USE module_wrf_quilt
- IMPLICIT NONE
- include "mpif.h"
- INTEGER , INTENT(IN) :: DataHandle
- INTEGER , INTENT(OUT) :: Status
- INTEGER locsize , itypesize
- INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' )
- ! CALL start_timing
- IF ( associated ( int_local_output_buffer ) ) THEN
- iserver = get_server_id ( DataHandle )
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- locsize = int_num_bytes_to_write(DataHandle)
- ! CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = locsize
- #ifdef PNETCDF_QUILT
- ! ARP Only want one command per IOServer if doing parallel IO
- IF ( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- ! CALL end_timing("MPI_Reduce in wrf_quilt_iosync")
- ! send data to the i/o processor
- #ifdef DEREF_KLUDGE
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- int_local_output_buffer(1), locsize , &
- dummy, 0 )
- #else
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- int_local_output_buffer, locsize , &
- dummy, 0 )
- #endif
- int_local_output_cursor = 1
- ! int_num_bytes_to_write(DataHandle) = 0
- DEALLOCATE ( int_local_output_buffer )
- NULLIFY ( int_local_output_buffer )
- ELSE
- CALL wrf_message ("frame/module_io_quilt.F: wrf_quilt_iosync: no buffer allocated")
- ENDIF
- ! CALL end_timing("wrf_quilt_iosync")
- Status = 0
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_iosync
- SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to close the dataset referenced by
- ! DataHandle.
- ! This routine also clears the client file handle and, if needed, deallocates
- ! int_local_output_buffer.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && ! defined( STUBMPI)
- USE module_wrf_quilt
- USE module_timing
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(IN) :: DataHandle
- INTEGER , INTENT(OUT) :: Status
- INTEGER i, itypesize, tasks_in_group, comm_io_group, ierr
- REAL dummy
- !!JMTIMING CALL start_timing
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioclose' )
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- ! If we're using pnetcdf then each IO server will need to receive the
- ! handle just once as there is
- ! no longer a reduce over the IO servers to get it.
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) )THEN
- CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, int_ioclose )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
- DataHandle , int_ioclose )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- iserver = get_server_id ( DataHandle )
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- !!JMTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- #ifdef PNETCDF_QUILT
- ! If we're using pnetcdf then each IO server will need the handle as there is
- ! no longer a reduce over the IO servers to get it.
- IF ( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!JMTIMING CALL end_timing("MPI_Reduce in ioclose")
- #if 0
- ! send data to the i/o processor
- !!JMTIMING CALL start_timing
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- !!JMTIMING CALL end_timing("collect_on_comm in io_close")
- #endif
- int_handle_in_use(DataHandle) = .false.
- CALL set_server_id( DataHandle, 0 )
- okay_to_write(DataHandle) = .false.
- okay_to_commit(DataHandle) = .false.
- int_local_output_cursor = 1
- int_num_bytes_to_write(DataHandle) = 0
- IF ( associated ( int_local_output_buffer ) ) THEN
- DEALLOCATE ( int_local_output_buffer )
- NULLIFY ( int_local_output_buffer )
- ENDIF
- Status = 0
- !!JMTIMING CALL end_timing( "wrf_quilt_ioclose" )
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_ioclose
- SUBROUTINE wrf_quilt_ioexit( Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to shut down the WRF I/O system.
- ! Do not call any wrf_quilt_*() routines after this routine has been called.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && ! defined (STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(OUT) :: Status
- INTEGER :: DataHandle, actual_iserver
- INTEGER i, itypesize, tasks_in_group, comm_io_group, me, ierr
- REAL dummy
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioexit' )
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- !ARPDBG - potential bug. Have no access to what type of IO is being used for
- ! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
- #ifdef PNETCDF_QUILT
- !ARP Send the ioexit message just once to each IOServer when using parallel IO
- IF( compute_group_master(1) ) THEN
- CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, int_ioexit )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- END IF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
- DataHandle , int_ioexit ) ! Handle is dummy
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- DO iserver = 1, nio_groups
- if(poll_servers) then
- ! We're using server polling mode, so we must call
- ! *_find_server to receive the mpi_ssend sent by the servers,
- ! otherwise WRF will hang at the mpi_x_reduce below.
- call wrf_quilt_find_server(actual_iserver)
- ! The actual_iserver is now set to the next available I/O server.
- ! That may not be the same as iserver, but that's okay as long
- ! as we run through this loop exactly nio_groups times.
- else
- ! Not using server polling, so just access servers in numeric order.
- actual_iserver=iserver
- endif
- CALL get_mpi_comm_io_groups( comm_io_group , actual_iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- CALL mpi_comm_rank( comm_io_group , me , ierr )
- ! BY SENDING A NEGATIVE SIZE WE GET THE SERVERS TO SHUT DOWN
- hdrbufsize = -100
- reduced = 0
- IF ( me .eq. 0 ) reduced(1) = hdrbufsize
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- ENDDO
- Status = 0
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_ioexit
- SUBROUTINE wrf_quilt_get_next_time ( DataHandle, DateStr, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to return the next time stamp.
- ! This is not yet supported.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && ! defined (STUBMPI)
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) :: DateStr
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_next_time
- SUBROUTINE wrf_quilt_get_previous_time ( DataHandle, DateStr, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to return the previous time stamp.
- ! This is not yet supported.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && ! defined (STUBMPI)
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) :: DateStr
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_previous_time
- SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to set the time stamp in the dataset
- ! referenced by DataHandle.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- USE module_state_description, ONLY: IO_PNETCDF
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Data
- INTEGER :: Status
- INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
- REAL dummy
- INTEGER :: Count
- INTEGER, EXTERNAL :: use_package
- !
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_set_time' )
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- Count = 0 ! there is no count for character strings
- !ARPDBG - potential bug. Have no access to what type of IO is being used for
- ! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
- #ifdef PNETCDF_QUILT
- IF(compute_group_master(1) )THEN
- ! Only want to send one time header to each IO server as
- ! can't tell that's what they are on the IO servers themselves - therefore use
- ! the compute_group_master process.
- CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, "TIMESTAMP", "", Data, int_set_time )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- END IF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, "TIMESTAMP", "", Data, int_set_time )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- iserver = get_server_id ( DataHandle )
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- ! send data to the i/o processor
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- ENDIF
- ENDIF
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_set_time
- SUBROUTINE wrf_quilt_get_next_var ( DataHandle, VarName, Status )
- !<DESCRIPTION>
- ! When reading, instruct the I/O quilt servers to return the name of the next
- ! variable in the current time frame.
- ! This is not yet supported.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) :: VarName
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_next_var
- SUBROUTINE wrf_quilt_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent domain metadata named "Element"
- ! from the open dataset described by DataHandle.
- ! Metadata of type real are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- REAL, INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Outcount
- INTEGER :: Status
- CALL wrf_message('wrf_quilt_get_dom_ti_real not supported yet')
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_ti_real
- SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! domain metadata named "Element"
- ! to the open dataset described by DataHandle.
- ! Metadata of type real are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- REAL , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- !Local
- CHARACTER*132 :: locElement
- INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group
- REAL dummy
- !
- !!JMTIMING CALL start_timing
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_real' )
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- locElement = Element
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- CALL MPI_TYPE_SIZE( MPI_REAL, typesize, ierr )
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) THEN
- CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
- DataHandle, locElement, Data, Count, int_dom_ti_real )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
- DataHandle, locElement, Data, Count, int_dom_ti_real )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- iserver = get_server_id ( DataHandle )
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- !!JMTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_real")
- ! send data to the i/o processor
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- ENDIF
- ENDIF
- Status = 0
- !!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_real")
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_ti_real
- SUBROUTINE wrf_quilt_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent domain metadata named "Element"
- ! from the open dataset described by DataHandle.
- ! Metadata of type double are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- real*8 :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- CALL wrf_error_fatal('wrf_quilt_get_dom_ti_double not supported yet')
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_ti_double
- SUBROUTINE wrf_quilt_put_dom_ti_double ( DataHandle,Element, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! domain metadata named "Element"
- ! to the open dataset described by DataHandle.
- ! Metadata of type double are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- REAL*8 , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- CALL wrf_error_fatal('wrf_quilt_put_dom_ti_double not supported yet')
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_ti_double
- SUBROUTINE wrf_quilt_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent domain metadata named "Element"
- ! from the open dataset described by DataHandle.
- ! Metadata of type integer are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- integer :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- CALL wrf_message('wrf_quilt_get_dom_ti_integer not supported yet')
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_ti_integer
- SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! domain metadata named "Element"
- ! to the open dataset described by DataHandle.
- ! Metadata of type integer are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- USE module_state_description, ONLY: IO_PNETCDF
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- INTEGER , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- ! Local
- CHARACTER*132 :: locElement
- INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group
- REAL dummy
- INTEGER, EXTERNAL :: use_package
- !
- !!JMTIMING CALL start_timing
- locElement = Element
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_integer' )
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- CALL MPI_TYPE_SIZE( MPI_INTEGER, typesize, ierr )
- !ARPDBG - potential bug. Have no access to what type of IO is being used for
- ! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) )THEN
- CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
- DataHandle, locElement, Data, Count, &
- int_dom_ti_integer )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
- DataHandle, locElement, Data, Count, &
- int_dom_ti_integer )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- iserver = get_server_id ( DataHandle )
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- !!JMTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_integer")
- ! send data to the i/o processor
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- ENDIF
- ENDIF
- CALL wrf_debug ( DEBUG_LVL, 'returning from wrf_quilt_put_dom_ti_integer' )
- !!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_integer" )
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_ti_integer
- SUBROUTINE wrf_quilt_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent domain metadata named "Element"
- ! from the open dataset described by DataHandle.
- ! Metadata of type logical are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- logical :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- ! CALL wrf_message('wrf_quilt_get_dom_ti_logical not supported yet')
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_ti_logical
- SUBROUTINE wrf_quilt_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! domain metadata named "Element"
- ! to the open dataset described by DataHandle.
- ! Metadata of type logical are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- logical , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- ! Local
- INTEGER i
- INTEGER one_or_zero(Count)
- DO i = 1, Count
- IF ( Data(i) ) THEN
- one_or_zero(i) = 1
- ELSE
- one_or_zero(i) = 0
- ENDIF
- ENDDO
- CALL wrf_quilt_put_dom_ti_integer ( DataHandle,Element, one_or_zero, Count, Status )
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_ti_logical
- SUBROUTINE wrf_quilt_get_dom_ti_char ( DataHandle,Element, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read time independent
- ! domain metadata named "Element"
- ! from the open dataset described by DataHandle.
- ! Metadata of type char are
- ! stored in string Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) :: Data
- INTEGER :: Status
- CALL wrf_message('wrf_quilt_get_dom_ti_char not supported yet')
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_ti_char
- SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write time independent
- ! domain metadata named "Element"
- ! to the open dataset described by DataHandle.
- ! Metadata of type char are
- ! copied from string Data.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: Data
- INTEGER :: Status
- INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group, me
- REAL dummy
- !
- !!JMTIMING CALL start_timing
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_char' )
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- !ARPDBG - potential bug. Have no access to what type of IO is being used for
- ! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
- #ifdef PNETCDF_QUILT
- IF(compute_group_master(1))THEN
- CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, Element, "", Data, &
- int_dom_ti_char )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- END IF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, Element, "", Data, int_dom_ti_char )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- iserver = get_server_id ( DataHandle )
- ! write(0,*)'wrf_quilt_put_dom_ti_char ',iserver
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here)
- !!JMTIMING! CALL start_timing
- !write(0,*)'calling MPI_Barrier'
- ! CALL MPI_Barrier( mpi_comm_local, ierr )
- !write(0,*)'back from MPI_Barrier'
- !!JMTIMING! CALL end_timing("MPI_Barrier in wrf_quilt_put_dom_ti_char")
- !!JMTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced_dummy = 0
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF(compute_group_master(1)) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- !call mpi_comm_rank( comm_io_group , me, ierr )
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_char")
- ! send data to the i/o processor
- !!JMTIMING CALL start_timing
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- !!JMTIMING CALL end_timing("collect_on_comm in wrf_quilt_put_dom_ti_char")
- ENDIF
- ENDIF
- !!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char")
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_ti_char
- SUBROUTINE wrf_quilt_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent domain metadata named "Element" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Metadata of type real are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- real :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_td_real
- SUBROUTINE wrf_quilt_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! domain metadata named "Element" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Metadata of type real are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- real , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_td_real
- SUBROUTINE wrf_quilt_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent domain metadata named "Element" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Metadata of type double are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- real*8 :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- CALL wrf_error_fatal('wrf_quilt_get_dom_td_double not supported yet')
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_td_double
- SUBROUTINE wrf_quilt_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! domain metadata named "Element" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Metadata of type double are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- real*8 , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- CALL wrf_error_fatal('wrf_quilt_put_dom_td_double not supported yet')
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_td_double
- SUBROUTINE wrf_quilt_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent domain metadata named "Element" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Metadata of type integer are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- integer :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_td_integer
- SUBROUTINE wrf_quilt_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! domain metadata named "Element" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Metadata of type integer are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- integer , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_td_integer
- SUBROUTINE wrf_quilt_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent domain metadata named "Element" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Metadata of type logical are
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- logical :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_td_logical
- SUBROUTINE wrf_quilt_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! domain metadata named "Element" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Metadata of type logical are
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- logical , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_td_logical
- SUBROUTINE wrf_quilt_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read time dependent
- ! domain metadata named "Element" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Metadata of type char are
- ! stored in string Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) :: Data
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_dom_td_char
- SUBROUTINE wrf_quilt_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status )
- !<DESCRIPTION>
- ! Instruct $he I/O quilt servers to write time dependent
- ! domain metadata named "Element" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Metadata of type char are
- ! copied from string Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: Data
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_dom_td_char
- SUBROUTINE wrf_quilt_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent attribute "Element" of variable "Varname"
- ! from the open dataset described by DataHandle.
- ! Attribute of type real is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- real :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_ti_real
- SUBROUTINE wrf_quilt_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! attribute "Element" of variable "Varname"
- ! to the open dataset described by DataHandle.
- ! Attribute of type real is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- real , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_ti_real
- SUBROUTINE wrf_quilt_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent attribute "Element" of variable "Varname"
- ! from the open dataset described by DataHandle.
- ! Attribute of type double is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- real*8 :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- CALL wrf_error_fatal('wrf_quilt_get_var_ti_double not supported yet')
- RETURN
- END SUBROUTINE wrf_quilt_get_var_ti_double
- SUBROUTINE wrf_quilt_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! attribute "Element" of variable "Varname"
- ! to the open dataset described by DataHandle.
- ! Attribute of type double is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- real*8 , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- CALL wrf_error_fatal('wrf_quilt_put_var_ti_double not supported yet')
- RETURN
- END SUBROUTINE wrf_quilt_put_var_ti_double
- SUBROUTINE wrf_quilt_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent attribute "Element" of variable "Varname"
- ! from the open dataset described by DataHandle.
- ! Attribute of type integer is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- integer :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_ti_integer
- SUBROUTINE wrf_quilt_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! attribute "Element" of variable "Varname"
- ! to the open dataset described by DataHandle.
- ! Attribute of type integer is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- integer , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_ti_integer
- SUBROUTINE wrf_quilt_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! independent attribute "Element" of variable "Varname"
- ! from the open dataset described by DataHandle.
- ! Attribute of type logical is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- logical :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_ti_logical
- SUBROUTINE wrf_quilt_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time independent
- ! attribute "Element" of variable "Varname"
- ! to the open dataset described by DataHandle.
- ! Attribute of type logical is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- logical , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_ti_logical
- SUBROUTINE wrf_quilt_get_var_ti_char ( DataHandle,Element, Varname, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read time independent
- ! attribute "Element" of variable "Varname"
- ! from the open dataset described by DataHandle.
- ! Attribute of type char is
- ! stored in string Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- CHARACTER*(*) :: Data
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_ti_char
- SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write time independent
- ! attribute "Element" of variable "Varname"
- ! to the open dataset described by DataHandle.
- ! Attribute of type char is
- ! copied from string Data.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "intio_tags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: VarName
- CHARACTER*(*) , INTENT(IN) :: Data
- INTEGER :: Status
- INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
- REAL dummy
- !
- !!JMTIMING CALL start_timing
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_var_ti_char' )
- IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
- IF ( int_handle_in_use( DataHandle ) ) THEN
- CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) THEN
- CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, TRIM(Element), &
- TRIM(VarName), TRIM(Data), int_var_ti_char )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #else
- IF ( wrf_dm_on_monitor() ) THEN
- CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
- DataHandle, TRIM(Element), &
- TRIM(VarName), TRIM(Data), int_var_ti_char )
- ELSE
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- iserver = get_server_id ( DataHandle )
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- !!JMTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_var_ti_char")
- ! send data to the i/o processor
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- ENDIF
- ENDIF
- !!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char" )
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_ti_char
- SUBROUTINE wrf_quilt_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent attribute "Element" of variable "Varname" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Attribute of type real is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- real :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_td_real
- SUBROUTINE wrf_quilt_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! attribute "Element" of variable "Varname" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Attribute of type real is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- real , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_td_real
- SUBROUTINE wrf_quilt_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent attribute "Element" of variable "Varname" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Attribute of type double is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- real*8 :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- CALL wrf_error_fatal('wrf_quilt_get_var_td_double not supported yet')
- RETURN
- END SUBROUTINE wrf_quilt_get_var_td_double
- SUBROUTINE wrf_quilt_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! attribute "Element" of variable "Varname" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Attribute of type double is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- real*8 , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- CALL wrf_error_fatal('wrf_quilt_put_var_td_double not supported yet')
- RETURN
- END SUBROUTINE wrf_quilt_put_var_td_double
- SUBROUTINE wrf_quilt_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount,Status)
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent attribute "Element" of variable "Varname" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Attribute of type integer is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- integer :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_td_integer
- SUBROUTINE wrf_quilt_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! attribute "Element" of variable "Varname" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Attribute of type integer is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- integer , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_td_integer
- SUBROUTINE wrf_quilt_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read Count words of time
- ! dependent attribute "Element" of variable "Varname" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Attribute of type logical is
- ! stored in array Data.
- ! Actual number of words read is returned in OutCount.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- logical :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: OutCount
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_td_logical
- SUBROUTINE wrf_quilt_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write Count words of time dependent
- ! attribute "Element" of variable "Varname" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Attribute of type logical is
- ! copied from array Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- logical , INTENT(IN) :: Data(*)
- INTEGER , INTENT(IN) :: Count
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_td_logical
- SUBROUTINE wrf_quilt_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to attempt to read time dependent
- ! attribute "Element" of variable "Varname" valid at time DateStr
- ! from the open dataset described by DataHandle.
- ! Attribute of type char is
- ! stored in string Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- CHARACTER*(*) :: Data
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_td_char
- SUBROUTINE wrf_quilt_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to write time dependent
- ! attribute "Element" of variable "Varname" valid at time DateStr
- ! to the open dataset described by DataHandle.
- ! Attribute of type char is
- ! copied from string Data.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: Element
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- CHARACTER*(*) , INTENT(IN) :: Data
- INTEGER :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_put_var_td_char
- SUBROUTINE wrf_quilt_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd , &
- Status )
- !<DESCRIPTION>
- ! Instruct the I/O quilt servers to read the variable named VarName from the
- ! dataset pointed to by DataHandle.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(INOUT) :: DateStr
- CHARACTER*(*) , INTENT(INOUT) :: VarName
- INTEGER , INTENT(INOUT) :: Field(*)
- integer ,intent(in) :: FieldType
- integer ,intent(inout) :: Comm
- integer ,intent(inout) :: IOComm
- integer ,intent(in) :: DomainDesc
- character*(*) ,intent(in) :: MemoryOrder
- character*(*) ,intent(in) :: Stagger
- character*(*) , dimension (*) ,intent(in) :: DimNames
- integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
- integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
- integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
- integer ,intent(out) :: Status
- Status = 0
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_read_field
- SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
- DomainDesc , MemoryOrder , Stagger , DimNames , &
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd , &
- Status )
- !<DESCRIPTION>
- ! Prepare instructions for the I/O quilt servers to write the variable named
- ! VarName to the dataset pointed to by DataHandle.
- !
- ! During a "training" write this routine accumulates number and sizes of
- ! messages that will be sent to the I/O server associated with this compute
- ! (client) task.
- !
- ! During a "real" write, this routine begins by allocating
- ! int_local_output_buffer if it has not already been allocated. Sizes
- ! accumulated during "training" are used to determine how big
- ! int_local_output_buffer must be. This routine then stores "int_field"
- ! headers and associated field data in int_local_output_buffer. The contents
- ! of int_local_output_buffer are actually sent to the I/O quilt server in
- ! routine wrf_quilt_iosync(). This scheme allows output of multiple variables
- ! to be aggregated into a single "iosync" operation.
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_state_description
- USE module_wrf_quilt
- IMPLICIT NONE
- INCLUDE 'mpif.h'
- #include "wrf_io_flags.h"
- INTEGER , INTENT(IN) :: DataHandle
- CHARACTER*(*) , INTENT(IN) :: DateStr
- CHARACTER*(*) , INTENT(IN) :: VarName
- ! INTEGER , INTENT(IN) :: Field(*)
- integer ,intent(in) :: FieldType
- integer ,intent(inout) :: Comm
- integer ,intent(inout) :: IOComm
- integer ,intent(in) :: DomainDesc
- character*(*) ,intent(in) :: MemoryOrder
- character*(*) ,intent(in) :: Stagger
- character*(*) , dimension (*) ,intent(in) :: DimNames
- integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
- integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
- integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
- integer ,intent(out) :: Status
- integer ii,jj,kk,myrank
- REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
- MemoryStart(2):MemoryEnd(2), &
- MemoryStart(3):MemoryEnd(3) ) :: Field
- INTEGER locsize , typesize, itypesize
- INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
- INTEGER, EXTERNAL :: use_package
- !!ARPTIMING CALL start_timing
- CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_write_field' )
- IF ( .NOT. (DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles) ) THEN
- CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: invalid data handle" )
- ENDIF
- IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
- CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: DataHandle not opened" )
- ENDIF
- locsize = (PatchEnd(1)-PatchStart(1)+1)* &
- (PatchEnd(2)-PatchStart(2)+1)* &
- (PatchEnd(3)-PatchStart(3)+1)
- CALL mpi_type_size( MPI_INTEGER, itypesize, ierr )
- ! Note that the WRF_DOUBLE branch of this IF statement must come first since
- ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds.
- IF ( FieldType .EQ. WRF_DOUBLE ) THEN
- CALL mpi_type_size( MPI_DOUBLE_PRECISION, typesize, ierr )
- ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
- CALL mpi_type_size( MPI_REAL, typesize, ierr )
- ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
- CALL mpi_type_size( MPI_INTEGER, typesize, ierr )
- ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
- CALL mpi_type_size( MPI_LOGICAL, typesize, ierr )
- ENDIF
- IF ( .NOT. okay_to_write( DataHandle ) ) THEN
- ! This is a "training" write.
- ! it is not okay to actually write; what we do here is just "bookkeep": count up
- ! the number and size of messages that we will output to io server associated with
- ! this task
- CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, &
- DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
- 333933 , MemoryOrder , Stagger , DimNames , & ! 333933 means training; magic number
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- int_num_bytes_to_write(DataHandle) = int_num_bytes_to_write(DataHandle) + locsize * typesize + hdrbufsize
- ! Send the hdr for the write in case the interface is calling the I/O API in "learn" mode
- iserver = get_server_id ( DataHandle )
- !JMDEBUGwrite(0,*)'wrf_quilt_write_field (dryrun) ',iserver
- CALL get_mpi_comm_io_groups( comm_io_group , iserver )
- ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here)
- CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
- #if 0
- IF ( .NOT. wrf_dm_on_monitor() ) THEN ! only one task in compute grid sends this message; send noops on others
- CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
- ENDIF
- #endif
- !!ARPTIMING CALL start_timing
- ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
- reduced = 0
- reduced(1) = hdrbufsize
- #ifdef PNETCDF_QUILT
- IF ( compute_group_master(1) ) reduced(2) = DataHandle
- #else
- IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
- #endif
- CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr )
- !!ARPTIMING CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun")
- ! send data to the i/o processor
- CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
- onebyte, &
- hdrbuf, hdrbufsize , &
- dummy, 0 )
- ELSE
- IF ( .NOT. associated( int_local_output_buffer ) ) THEN
- ALLOCATE ( int_local_output_buffer( (int_num_bytes_to_write( DataHandle )+1)/itypesize ), Stat=ierr )
- IF(ierr /= 0)THEN
- CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: allocate of int_local_output_buffer failed" )
- END IF
- int_local_output_cursor = 1
- ENDIF
- iserver = get_server_id ( DataHandle )
- !JMDEBUGwrite(0,*)'wrf_quilt_write_field (writing) ',iserver
- ! This is NOT a "training" write. It is OK to write now.
- CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, &
- DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
- 0 , MemoryOrder , Stagger , DimNames , & ! non-333933 means okay to write; magic number
- DomainStart , DomainEnd , &
- MemoryStart , MemoryEnd , &
- PatchStart , PatchEnd )
- ! Pack header into int_local_output_buffer. It will be sent to the
- ! I/O servers during the next "iosync" operation.
- #ifdef DEREF_KLUDGE
- CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer(1), int_local_output_cursor )
- #else
- CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer, int_local_output_cursor )
- #endif
- ! Pack field data into int_local_output_buffer. It will be sent to the
- ! I/O servers during the next "iosync" operation.
- #ifdef DEREF_KLUDGE
- CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), &
- locsize * typesize , int_local_output_buffer(1), int_local_output_cursor )
- #else
- CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), &
- locsize * typesize , int_local_output_buffer, int_local_output_cursor )
- #endif
- ENDIF
- Status = 0
- !!ARPTIMING CALL end_timing("wrf_quilt_write_field")
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_write_field
- SUBROUTINE wrf_quilt_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
- DomainStart , DomainEnd , Status )
- !<DESCRIPTION>
- ! This routine applies only to a dataset that is open for read. It instructs
- ! the I/O quilt servers to return information about variable VarName.
- ! This routine is called only by client (compute) tasks.
- !
- ! This is not yet supported.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- IMPLICIT NONE
- integer ,intent(in) :: DataHandle
- character*(*) ,intent(in) :: VarName
- integer :: NDim
- character*(*) :: MemoryOrder
- character*(*) :: Stagger
- integer ,dimension(*) :: DomainStart, DomainEnd
- integer :: Status
- #endif
- RETURN
- END SUBROUTINE wrf_quilt_get_var_info
- subroutine wrf_quilt_find_server(iserver)
- ! This routine is called by the compute processes when they need an
- ! I/O server to write out a new file. Upon return, this routine will
- ! set iserver to the next available I/O server group.
- ! A mpi_recv to all of mpi_comm_avail is used to implement this, and
- ! that recv will not return until an I/O server group calls
- ! wrf_quilt_server_ready to signal that it is ready for a new file.
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- use module_wrf_quilt, only : in_avail, mpi_comm_avail, mpi_comm_local
- implicit none
- INCLUDE 'mpif.h'
- integer, intent(inout) :: iserver
- integer :: ierr
- character(255) :: message
- call wrf_message('Polling I/O servers...')
- if(in_avail) then
- call mpi_recv(iserver,1,MPI_INTEGER,MPI_ANY_SOURCE,0,mpi_comm_avail,MPI_STATUS_IGNORE,ierr)
- if(ierr/=0) then
- call wrf_error_fatal('mpi_recv failed in wrf_quilt_find_server')
- endif
- endif
- call mpi_bcast(iserver,1,MPI_INTEGER,0,mpi_comm_local,ierr)
- if(ierr/=0) then
- call wrf_error_fatal('mpi_bcast failed in wrf_quilt_find_server')
- endif
- write(message,'("I/O server ",I0," is ready for operations.")') iserver
- call wrf_message(message)
- #endif
- end subroutine wrf_quilt_find_server
- subroutine wrf_quilt_server_ready()
- ! This routine is called by the I/O server group's master process once the
- ! I/O server group is done writing its current file, and is waiting for
- ! a new one. This information is passed to the monitor process by a
- ! blocking send from the I/O server master process to the monitor.
- ! All processes in an I/O group must call this routine, and this routine
- ! will not return (in any process) until the monitor process signals
- ! that it wants the I/O server group to write a file. That signal is
- ! sent in a call to wrf_quilt_find_server on the compute processes.
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- use module_wrf_quilt, only : mpi_comm_local, in_avail, availrank, mpi_comm_avail
- implicit none
- INCLUDE 'mpif.h'
- integer :: ierr
- write(0,*) 'Entering wrf_quilt_server_ready.'
- call mpi_barrier(mpi_comm_local,ierr)
- if(ierr/=0) then
- call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready')
- endif
- if(in_avail) then
- write(0,'("mpi_ssend ioserver=",I0," in wrf_quilt_server_ready")') availrank
- call mpi_ssend(availrank,1,MPI_INTEGER,0,0,mpi_comm_avail,ierr)
- if(ierr/=0) then
- call wrf_error_fatal('mpi_ssend failed in wrf_quilt_server_ready')
- endif
- endif
- call mpi_barrier(mpi_comm_local,ierr)
- if(ierr/=0) then
- call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready')
- endif
- write(0,*) 'Leaving wrf_quilt_server_ready.'
- #endif
- end subroutine wrf_quilt_server_ready
- SUBROUTINE get_mpi_comm_io_groups( retval, isrvr )
- !<DESCRIPTION>
- ! This routine returns the compute+io communicator to which this
- ! compute task belongs for I/O server group "isrvr".
- ! This routine is called only by client (compute) tasks.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- INTEGER, INTENT(IN ) :: isrvr
- INTEGER, INTENT(OUT) :: retval
- retval = mpi_comm_io_groups(isrvr)
- #endif
- RETURN
- END SUBROUTINE get_mpi_comm_io_groups
- SUBROUTINE get_nio_tasks_in_group( retval )
- !<DESCRIPTION>
- ! This routine returns the number of I/O server tasks in each
- ! I/O server group. It can be called by both clients and
- ! servers.
- !</DESCRIPTION>
- #if defined( DM_PARALLEL ) && !defined( STUBMPI )
- USE module_wrf_quilt
- IMPLICIT NONE
- INTEGER, INTENT(OUT) :: retval
- retval = nio_tasks_in_group
- #endif
- RETURN
- END SUBROUTINE get_nio_tasks_in_group
- SUBROUTINE collect_on_comm_debug(file,line, comm_io_group, &
- sze, &
- hdrbuf, hdrbufsize , &
- outbuf, outbufsize )
- IMPLICIT NONE
- CHARACTER*(*) file
- INTEGER line
- INTEGER comm_io_group
- INTEGER sze
- INTEGER hdrbuf(*), outbuf(*)
- INTEGER hdrbufsize, outbufsize
- !write(0,*)'collect_on_comm_debug ',trim(file),line,sze,hdrbufsize,outbufsize
- CALL collect_on_comm( comm_io_group, &
- sze, &
- hdrbuf, hdrbufsize , &
- outbuf, outbufsize )
- !write(0,*)trim(file),line,'returning'
- RETURN
- END
- SUBROUTINE collect_on_comm_debug2(file,line,var,tag,sz,hdr_rec_size, &
- comm_io_group, &
- sze, &
- hdrbuf, hdrbufsize , &
- outbuf, outbufsize )
- IMPLICIT NONE
- CHARACTER*(*) file,var
- INTEGER line,tag,sz,hdr_rec_size
- INTEGER comm_io_group
- INTEGER sze
- INTEGER hdrbuf(*), outbuf(*)
- INTEGER hdrbufsize, outbufsize
- ! write(0,*)'collect_on_comm_debug2 ',trim(file),line,trim(var),tag,sz,hdr_rec_size,sze,hdrbufsize,outbufsize
- CALL collect_on_comm( comm_io_group, &
- sze, &
- hdrbuf, hdrbufsize , &
- outbuf, outbufsize )
- ! write(0,*)'collect_on_comm_debug2 ',trim(file),line,'returning for ',trim(var)
- RETURN
- END