#define __PIO_FILE__ "pio_msg_mod.F90" module pio_msg_mod use pio_kinds use pio_types use pio_support, only : piodie, DebugAsync implicit none private public :: pio_msg_handler_init, pio_msg_handler public :: add_to_file_list, lookupfile, delete_from_file_list, lookupiodesc, add_to_iodesc_list, delete_from_iodesc_list ! PIO ASYNC MESSAGE TAGS integer, parameter, public :: pio_msg_create_file = 300 integer, parameter, public :: pio_msg_open_file = 301 integer, parameter, public :: pio_msg_close_file = 302 integer, parameter, public :: pio_msg_def_dim = 310 integer, parameter, public :: pio_msg_def_var = 312 integer, parameter, public :: pio_msg_enddef = 313 integer, parameter, public :: pio_msg_redef = 314 integer, parameter, public :: pio_msg_initdecomp_dof = 315 integer, parameter, public :: pio_msg_writedarray = 320 integer, parameter, public :: pio_msg_readdarray = 325 integer, parameter, public :: pio_msg_inquire = 330 integer, parameter, public :: pio_msg_inq_att = 331 integer, parameter, public :: pio_msg_inq_attname = 332 integer, parameter, public :: pio_msg_inq_varid = 333 integer, parameter, public :: pio_msg_inq_varname = 334 integer, parameter, public :: pio_msg_inq_vardimid = 335 integer, parameter, public :: pio_msg_inq_varnatts = 336 integer, parameter, public :: pio_msg_inq_varndims = 337 integer, parameter, public :: pio_msg_inq_vartype = 338 integer, parameter, public :: pio_msg_inq_dimid = 339 integer, parameter, public :: pio_msg_inq_dimlen = 340 integer, parameter, public :: pio_msg_inq_dimname = 341 integer, parameter, public :: pio_msg_inq_attlen = 342 integer, parameter, public :: pio_msg_seterrorhandling = 350 integer, parameter, public :: pio_msg_getvar1 = 360 integer, parameter, public :: pio_msg_getvar_0d = 361 integer, parameter, public :: pio_msg_getvar_1d = 362 integer, parameter, public :: pio_msg_getvar_2d = 363 integer, parameter, public :: pio_msg_getvar_3d = 364 integer, parameter, public :: pio_msg_getvar_4d = 365 integer, parameter, public :: pio_msg_getvar_5d = 366 integer, parameter, public :: pio_msg_getvara_1d = 367 integer, parameter, public :: pio_msg_getvara_2d = 368 integer, parameter, public :: pio_msg_getvara_3d = 369 integer, parameter, public :: pio_msg_getvara_4d = 370 integer, parameter, public :: pio_msg_getvara_5d = 371 integer, parameter, public :: pio_msg_putvar1 = 380 integer, parameter, public :: pio_msg_putvar_0d = 381 integer, parameter, public :: pio_msg_putvar_1d = 382 integer, parameter, public :: pio_msg_putvar_2d = 383 integer, parameter, public :: pio_msg_putvar_3d = 384 integer, parameter, public :: pio_msg_putvar_4d = 385 integer, parameter, public :: pio_msg_putvar_5d = 386 integer, parameter, public :: pio_msg_putvara_1d = 387 integer, parameter, public :: pio_msg_putvara_2d = 388 integer, parameter, public :: pio_msg_putvara_3d = 389 integer, parameter, public :: pio_msg_putvara_4d = 390 integer, parameter, public :: pio_msg_putvara_5d = 391 integer, parameter, public :: pio_msg_getatt = 400 integer, parameter, public :: pio_msg_getatt_1d = 401 integer, parameter, public :: pio_msg_putatt = 402 integer, parameter, public :: pio_msg_putatt_1d = 403 integer, parameter, public :: PIO_MSG_SYNC_FILE = 500 integer, parameter, public :: PIO_MSG_FREEDECOMP = 502 integer, parameter, public :: pio_msg_exit = 999 type :: file_desc_list type(file_desc_t), pointer :: file => null() type(file_desc_list), pointer :: next => null() end type file_desc_list type(file_desc_list), target, save :: top_file type :: io_desc_list integer :: index type(io_desc_t), pointer :: iodesc => null() type(io_desc_list), pointer :: next => null() end type io_desc_list type(io_desc_list), target, save :: top_iodesc integer :: io_comm, iorank contains subroutine pio_msg_handler_init(io_comm_in, io_rank_in) integer, intent(in) :: io_comm_in, io_rank_in io_comm = io_comm_in iorank = io_rank_in top_iodesc%index = 1 end subroutine pio_msg_handler_init subroutine pio_msg_handler(numcomps, iosystem) ! use pio_types, only : #ifdef TIMING use perf_mod ! _EXTERNAL #endif #ifndef NO_MPIMOD use mpi !_EXTERNAL #endif implicit none integer, intent(in) :: numcomps type(iosystem_desc_t), target :: iosystem(numcomps) type(iosystem_desc_t), pointer :: ios integer :: msg = 0, ierr #ifdef NO_MPIMOD include 'mpif.h' ! _EXTERNAL #endif integer :: status(MPI_STATUS_SIZE) integer :: req(numcomps) integer :: index #ifdef TIMING call t_startf('pio_msg_mod') #endif if(iorank==0) then req(:) = MPI_REQUEST_NULL do index=1,numcomps ios=>iosystem(index) if(ios%io_comm .ne. mpi_comm_null) then call mpi_irecv(msg, 1, mpi_integer, ios%comproot, 1, ios%union_comm, req(index), ierr) end if enddo end if do while(msg /= -1) if(iorank==0) then if(Debugasync) print *,__PIO_FILE__,__LINE__, ' waiting' call mpi_waitany(numcomps, req, index, status, ierr) if(Debugasync) print *,__PIO_FILE__,__LINE__, ' recieved on ', index end if call mpi_bcast(index, 1, mpi_integer, 0, io_comm, ierr) ios => iosystem(index) if(Debugasync) print *,__PIO_FILE__,__LINE__, index, ios%intercomm call mpi_bcast(msg, 1, mpi_integer, 0, io_comm, ierr) if(debugasync) print *,__PIO_FILE__,__LINE__, msg ,' recieved on ', index select case(msg) case (PIO_MSG_CREATE_FILE) call create_file_handler(ios) case (PIO_MSG_OPEN_FILE) call open_file_handler(ios) case (PIO_MSG_INITDECOMP_DOF) call initdecomp_dof_handler(ios) case (PIO_MSG_WRITEDARRAY) call writedarray_handler(ios) case (PIO_MSG_READDARRAY) call readdarray_handler(ios) case (PIO_MSG_SETERRORHANDLING) call seterrorhandling_handler(ios) case (PIO_MSG_GETVAR1) call var1_handler(ios, msg) case (PIO_MSG_GETVAR_0d) call var_0d_handler(ios, msg) case (PIO_MSG_GETVAR_1d) call var_1d_handler(ios, msg) case (PIO_MSG_GETVAR_2d) call var_2d_handler(ios, msg) case (PIO_MSG_GETVAR_3d) call var_3d_handler(ios, msg) case (PIO_MSG_GETVAR_4d) call var_4d_handler(ios, msg) case (PIO_MSG_GETVAR_5d) call var_5d_handler(ios, msg) case (PIO_MSG_GETVARA_1d) call vara_1d_handler(ios, msg) case (PIO_MSG_GETVARA_2d) call vara_2d_handler(ios, msg) case (PIO_MSG_GETVARA_3d) call vara_3d_handler(ios, msg) case (PIO_MSG_GETVARA_4d) call vara_4d_handler(ios, msg) case (PIO_MSG_GETVARA_5d) call vara_5d_handler(ios, msg) case (PIO_MSG_PUTVAR1) call var1_handler(ios, msg) case (PIO_MSG_PUTVAR_0d) call var_0d_handler(ios, msg) case (PIO_MSG_PUTVAR_1d) call var_1d_handler(ios, msg) case (PIO_MSG_PUTVAR_2d) call var_2d_handler(ios, msg) case (PIO_MSG_PUTVAR_3d) call var_3d_handler(ios, msg) case (PIO_MSG_PUTVAR_4d) call var_4d_handler(ios, msg) case (PIO_MSG_PUTVAR_5d) call var_5d_handler(ios, msg) case (PIO_MSG_PUTVARA_1d) call vara_1d_handler(ios, msg) case (PIO_MSG_PUTVARA_2d) call vara_2d_handler(ios, msg) case (PIO_MSG_PUTVARA_3d) call vara_3d_handler(ios, msg) case (PIO_MSG_PUTVARA_4d) call vara_4d_handler(ios, msg) case (PIO_MSG_PUTVARA_5d) call vara_5d_handler(ios, msg) case (PIO_MSG_GETATT) call att_handler(ios, msg) case (PIO_MSG_GETATT_1D) call att_1d_handler(ios, msg) case (PIO_MSG_PUTATT) call att_handler(ios, msg) case (PIO_MSG_PUTATT_1D) call att_1d_handler(ios, msg) case (PIO_MSG_FREEDECOMP) call freedecomp_handler(ios) case (PIO_MSG_EXIT) print *,'PIO Exiting' ! call mpi_barrier(ios%io_comm,ierr) call finalize_handler(ios) exit case default call pio_callback_handler(ios,msg) end select if(iorank==0) then call mpi_irecv(msg, 1, mpi_integer, ios%comproot, 1, ios%union_comm, req(index), ierr) end if end do #ifdef TIMING call t_stopf('pio_msg_mod') call t_finalizef() #endif if(Debugasync) print *,__PIO_FILE__,__LINE__ call mpi_finalize(ierr) stop end subroutine pio_msg_handler subroutine add_to_file_list(file) type(file_desc_t), pointer :: file type(file_desc_list), pointer :: list_item list_item=> top_file if(associated(list_item%file)) then do while(associated(list_item%file) .and. associated(list_item%next)) if(Debugasync) print *,__PIO_FILE__,__LINE__,list_item%file%fh list_item => list_item%next end do if(associated(list_item%file)) then allocate(list_item%next) list_item=>list_item%next nullify(list_item%next) end if end if if(Debugasync) print *,__PIO_FILE__,__LINE__,file%fh list_item%file => file end subroutine add_to_file_list subroutine add_to_iodesc_list(iodesc) type(io_desc_t), pointer :: iodesc type(io_desc_list), pointer :: list_item integer :: index list_item=> top_iodesc index=top_iodesc%index if(associated(list_item%iodesc)) then do while(associated(list_item%iodesc) .and. associated(list_item%next)) list_item => list_item%next index = index+1 end do if(associated(list_item%iodesc)) then ! id = max(id+1, list_item%iodesc%async_id+1) allocate(list_item%next) list_item=>list_item%next index = index+1 nullify(list_item%next) end if if(debugasync) print *,__PIO_FILE__,__LINE__,index end if iodesc%async_id=index list_item%index=index list_item%iodesc => iodesc if(debugasync) print *,__PIO_FILE__,__LINE__,index,list_item%iodesc%async_id end subroutine add_to_iodesc_list function delete_from_iodesc_list(id) result(iodesc) integer, intent(in) :: id type(io_desc_list), pointer :: list_item, previtem, nextitem type(io_desc_t), pointer :: iodesc list_item=> top_iodesc nullify(previtem) do while(associated(list_item%iodesc) ) if(abs(list_item%iodesc%async_id) == id) then iodesc=>list_item%iodesc iodesc%async_id=-1 nullify(list_item%iodesc) if(associated(previtem)) then if(associated(list_item%next)) then previtem%next => list_item%next else nullify(previtem%next) end if deallocate(list_item) else if(associated(list_item%next)) then nextitem => list_item%next list_item%iodesc=>nextitem%iodesc list_item%index = nextitem%index if(associated(nextitem%next)) then list_item%next => nextitem%next else nullify(list_item%next) end if deallocate(nextitem) end if exit end if if(associated(list_item%next)) then previtem=>list_item list_item=>list_item%next else if(debugasync) then list_item=> top_iodesc do while(associated(list_item)) print *,__PIO_FILE__,__LINE__,id,list_item%index,list_item%iodesc%async_id list_item=>list_item%next enddo endif call piodie(__PIO_FILE__,__LINE__,'delete_from_iodesc_list',id) end if end do end function delete_from_iodesc_list subroutine delete_from_file_list(fh) integer, intent(in) :: fh type(file_desc_list), pointer :: list_item, previtem integer :: fh1 fh1 = abs(fh) list_item=> top_file nullify(previtem) do while(associated(list_item%file) ) if(abs(list_item%file%fh) == fh1) then nullify(list_item%file) if(associated(previtem)) then if(associated(list_item%next)) then previtem%next=>list_item%next else nullify(previtem%next) end if deallocate(list_item) end if exit end if if(associated(list_item%next)) then previtem=>list_item list_item=>list_item%next else call piodie(__PIO_FILE__,__LINE__,'delete_from_file_list') end if end do end subroutine delete_from_file_list function lookupfile(fh) result(file) type(file_desc_t), pointer :: file integer, intent(in) :: fh type(file_desc_list), pointer :: list_item integer :: fh1 fh1 = abs(fh) list_item=> top_file do while(associated(list_item%file) ) if(abs(list_item%file%fh) == fh1) then file => list_item%file exit end if list_item=>list_item%next end do end function lookupfile function lookupiodesc(async_id) result(iodesc) type(io_desc_t), pointer :: iodesc integer, intent(in) :: async_id type(io_desc_list), pointer :: list_item list_item=> top_iodesc nullify(iodesc) do while(associated(list_item%iodesc) ) if(debugasync) print *,__PIO_FILE__,__LINE__,list_item%index,async_id,list_item%iodesc%async_id if(abs(list_item%iodesc%async_id) == async_id) then iodesc => list_item%iodesc if(debugasync) print *,__PIO_FILE__,__LINE__,async_id,list_item%index,iodesc%write%n_elemtype exit end if list_item=>list_item%next end do if(.not.associated(iodesc)) then call piodie(__PIO_FILE__,__LINE__) end if end function lookupiodesc end module pio_msg_mod