C****************************************************************************** C MODULE WRITER C This module is for writer processors which receives values from compute C processors and writes them out asynchronously. C 05 Feb 2007, sb C****************************************************************************** C module writer use sizes, only : sz, mnproc, mnwproc, OFF, ASCII, SPARSE_ASCII, & NETCDF3, NETCDF4, XDMF, iSplit, globalDir, meshType, & controlType, meshFileName_g, controlFileName_g use global, only: c3d, comm, & bufsize_max, buf, resultbuf, outputdatadescript_t, float_type, & debug, echo, info, warning, error, logmessage, allmessage, & setmessagesource, unsetmessagesource, initLogging, nabout, & scratchMessage, & sig_val, sig_write, sig_pause, comm_writer, writer_id, & sig_term, realtype, dbletype, sig_mesh use messenger, only: tag, msg_fini #ifdef HAVE_MPI_MOD use mpi implicit none #else implicit none #endif !tcm v50.27 increased size from 3 to 4, cobell increase to 6, ! jgf51.21.27 decreased size of intbuf to 5 ! jgf51.21.29 increased size of intbuf to 6 for XDMF integer, parameter :: numIntMetadata = 6 integer :: intBuf(numIntMetadata) ! used to transmit pieces of descript via mpi integer, parameter :: numRealMetadata = 2 real(sz) :: reBuf(numRealMetadata) ! used to transmit pieces of descript via mpi ! ! maximum number of buffers that each writer processor has ! for storing data; each writer will only allocate the space that ! it actually needs, so a large value (e.g., 25) does not consume ! any extra or unnecessary resources integer, parameter :: num_buf_max = 25 !st3 100708: increase for swan output ! ! data structure on the writer processor that mirrors the corresponding ! metadata on the compute processor; this is dimensioned by the ! num_buf_max parameter type(OutputDataDescript_t), allocatable :: writer_descripts(:) ! ! .true. if a writer processor has received data into one or more ! of its local buffers but has not written it yet; the nwloaded ! array is dimensioned equal to the number of writer processors; ! this is an array that is updated and used by compute processors ! not writer processors logical, allocatable :: nwloaded(:) !st3 100708: round robin chamber ! ! buffer number on a particular writer processor; each writer ! processor manages its own bufID so it knows where to store the ! next dataset it receives integer :: bufID ! ! wcommID is incremented by and used only by compute processors to ! determine which writer processor to send data to each time integer :: wcommID ! writer processor number (1 -> MNWPROC) C---------------------end of data declarations--------------------------------C !-------- CONTAINS !-------- C----------------------------------------------------------------------- C S U B R O U T I N E W R I T E R _ I N I T C----------------------------------------------------------------------- C jgf51.21.27: This subroutine is executed by each writer processor. C C Initializes round robin chamber; clears mpi communicator id for C this processor; clears flush flag. C----------------------------------------------------------------------- subroutine writer_init () implicit none integer i !#if defined(WRITER_TRACE) || defined(ALL_TRACE) ! nabout = -1 !FIXME: Have padcirc send the actual value of nabout !#else ! nabout = 0 !#endif call setMessageSource("writer_init") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif wcommID = 0 bufID = 0 allocate (nwloaded(1:mnwproc)) !st3 100708: allocate round robin chamber nwloaded(1:mnwproc) = .false. !st3 100708: zeroc round robin chamber allocate(writer_descripts(num_buf_max)) do i=1,num_buf_max writer_descripts(i) % wMD % bufferInitialized = .false. writer_descripts(i) % wMD % bufferLoaded = .false. end do #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() RETURN C----------------------------------------------------------------------- END SUBROUTINE WRITER_INIT C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E W R I T E R _ M A I N C----------------------------------------------------------------------- C jgf51.21.27: This subroutine is executed by each writer processor. C C Writer processor goes into an infinite loop where it waits for C either a signal to receive data, or a signal to write output. C When it receives a signal, it performs the specified action, C then goes back to waiting for another signal. C----------------------------------------------------------------------- subroutine writer_main () USE GLOBAL,ONLY : ScreenUnit IMPLICIT NONE #ifndef HAVE_MPI_MOD include 'mpif.h' #endif integer :: sig,ierr integer :: mpistat(mpi_status_size) C call setMessageSource("writer_main") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif ! ! infinite loop do call mpi_recv(sig, 1, mpi_integer, 0, tag, & comm_writer(writer_id), mpistat, ierr) select case(sig) case(sig_val) write(scratchMessage, & '("Writer processor ",i0," received sig_val.")') writer_id call logMessage(INFO,scratchMessage) call writer_recv_values() case(sig_write) write(scratchMessage, & '("Writer processor ",i0," received sig_write.")') writer_id call logMessage(INFO,scratchMessage) call writer_write() case(sig_mesh) write(scratchMessage, & '("Writer processor ",i0," received sig_mesh.")') writer_id call logMessage(INFO,scratchMessage) call writerReadMesh() case(sig_pause) ! tcm addeded v49.52.01 SIG_PAUSE write(scratchMessage, & '("Writer processor ",i0," received sig_pause.")') writer_id call logMessage(INFO,scratchMessage) exit case(sig_term) write(scratchMessage, & '("Writer processor ",i0," received sig_term.")') writer_id call logMessage(INFO,scratchMessage) exit case default write(scratchMessage, & '("Writer processor ",i0," received invalid signal ",i0,".")') & writer_id, sig exit end select end do #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() C----------------------------------------------------------------------- end subroutine writer_main C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E S E N D D A T A T O W R I T E R C----------------------------------------------------------------------- C jgf51.21.27: This subroutine is executed by all compute processors C to send metadata and then output data to a writer processor. C----------------------------------------------------------------------- subroutine sendDataToWriter(descript, TimeLoc, it, store_cmd) use sizes, only : myproc use global implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif type (OutputDataDescript_t), intent(in) :: descript real(8) :: TimeLoc ! output time in seconds integer :: it ! current time step external store_cmd ! command to pack the buffer for mpi transmission C integer :: ierr integer :: num integer :: bufsize integer :: istart, iend C call setMessageSource("sendDataToWriter") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif ! ! jgf51.21.27: Figure out which mpi communicator to use with this ! writer processor. if (wcommID.ge.mnwproc) then wcommID = 0 endif wcommID = wcommID + 1 ! st3 100708: load the bullet to round robin chamber nwloaded(wcommID) = .true. ! ! jgf51.21.27: proc 0 signals the writer processor to let it know ! that it is time to write and then sends it some metadata if (myproc.eq.0) then write(scratchMessage,'(a,i0,a)') & 'Processor 0 is sending sig_val to writer ',wcommID,'.' call logMessage(DEBUG,scratchMessage) ! ! Send SIG_VAL to a writer to get it ready to receive values. call mpi_send(SIG_VAL, 1, mpi_integer, mnproc, tag, & comm_writer(wcommID), ierr) C... Send minimal set of metadata associated with this file C.... tcm v50.27 added for full/compact record Cobell - Allow writer processors to output netcdf data ! jgf51.21.29: Added outputTimeStepIncrement since it is needed ! by XDMF so it will know when to finalize the output INTBUF(1) = descript % num_fd_records INTBUF(2) = descript % num_items_per_record INTBUF(3) = descript % specifier INTBUF(4) = descript % lun INTBUF(5) = descript % outputTimeStepIncrement INTBUF(6) = it call mpi_send(intbuf, 6, mpi_integer, mnproc, tag, & comm_writer(wcommID),ierr) REBUF(1) = descript % alternate_value REBUF(2) = timeLoc ! send dry value and time in seconds call mpi_send(rebuf, 2, realtype, mnproc, tag, & comm_writer(wcommID),ierr) ! send file name call mpi_send(descript % file_name, 1024, mpi_character, & mnproc, tag, comm_writer(wcommID), ierr) write(scratchMessage,'(a,i0,a,a,a,i0,a)') & 'Processor ',myproc,' is sending file name ', & trim(descript%file_name),' to writer ',wcommID,'.' call logMessage(DEBUG,scratchMessage) endif C... Compute the buffer size bufsize = min(BUFSIZE_MAX, & descript % num_items_per_record * descript % num_fd_records) num = bufsize / descript % num_items_per_record iend = num istart = 1 ! ! now all compute processors send this data to the dedicated writer processor do while (istart.le.iend) buf(:) = descript % initial_value call store_cmd(descript, istart, iend) write(scratchMessage,'(a,i0,a,a,a)') 'proc ',myproc, & ' is sending for ',trim(descript % file_name),'.' call logMessage(DEBUG,scratchMessage) C... The following mpi_reduce sends array values to rank MNPROC, C... which is the writer proc in the group. C... Note that ranks from 0 to (MNPROC-1) are compute procs, and C... rank MNPROC of writer communicators is always the writer proc. call mpi_reduce(buf, resultBuf, bufsize, float_type, MPI_SUM, & MNPROC, comm_writer(wcommID), ierr) istart = iend + 1 iend = min(istart + num - 1, descript % num_fd_records) num = iend - istart + 1 end do C #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() return C----------------------------------------------------------------------- end subroutine sendDataToWriter C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E W R I T E R _ R E C V _ V A L U E S C----------------------------------------------------------------------- C jgf51.21.27: This subroutine is executed by a writer processor C that has received a sig_val from processor 0 indicating that data C are about to be sent. The writer processor receives some metadata C before receiving the actual output data. The data are not actually C written in this subroutine. C----------------------------------------------------------------------- subroutine writer_recv_values() implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif integer :: num, i, j integer :: ierr integer :: bufsize integer :: istart, iend integer :: mpistat(MPI_STATUS_SIZE) logical :: descriptFound ! true if we found the particular buffer we need character(len=8) :: cdigit !st3 100708: split file call setMessageSource("writer_recv_values") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif ! ! Receive minimal set of metadata required to write the file call mpi_recv(intbuf, 6, mpi_integer, 0, tag, & comm_writer(writer_id), mpistat, ierr) ! ! if the file format is XDMF, we need to use the logical unit number ! (lun) to match up the incoming data with the data structure where ! it belongs descriptFound = .false. if (abs(intbuf(3)).eq.XDMF) then do i=1,num_buf_max ! look for the descript that is already set up to write this data if (writer_descripts(i) % lun .eq. intbuf(4)) then bufID = i descriptFound = .true. exit endif end do end if ! either we are not using XDMF or we don't yet have a descript ! set up to write this data in XDMF if (descriptFound.eqv..false.) then !write(6,'(a)') 'DEBUG: Writer did not find a buffer associated with this data.' ! just use one the first one that has not already been filled ! since the last flush do i=1,num_buf_max if (writer_descripts(i) % wMD % bufferLoaded .eqv..false.) & then bufID = i exit endif end do else !write(6,'(a)') 'DEBUG: Writer found a suitable buffer.' endif ! ! place the metadata into the selected buffer writer_descripts(bufid) % num_fd_records = intbuf(1) writer_descripts(bufid) % num_items_per_record = intbuf(2) writer_descripts(bufid) % specifier = intbuf(3) !jgf51.21.27 added writer_descripts(bufid) % lun = intbuf(4) writer_descripts(bufid) % outputTimeStepIncrement = intbuf(5) writer_descripts(bufid) % wMD % myTimeStep = intbuf(6) ! ! receive "dry" data value and current simulation time call mpi_recv(rebuf, 2, realtype, 0, tag, comm_writer(writer_id), & mpistat, ierr) writer_descripts(bufid) % alternate_value = rebuf(1) writer_descripts(bufid) % wMD % myTime = rebuf(2) ! ! receive file name writer_descripts(bufID) % file_name(:) = " " call mpi_recv(writer_descripts(bufID)%file_name, 1024, & mpi_character, 0, tag, comm_writer(writer_id), mpistat, ierr) write(scratchMessage,'(a,i0,a,i0,a,a,a)') 'Writer ',writer_id, & ' buffer ', bufID,' received file name ', & trim(writer_descripts(bufID)%file_name) call logMessage(DEBUG,scratchMessage) ! !st3 100708: split file if (isplit.eqv..true.) then !st3 split files are named by integer part of simulation time write(cdigit,'(i8.8)') & nint(writer_descripts(bufid) % wMD % myTime) writer_descripts(bufid) % file_name = & trim(adjustl(writer_descripts(bufid) % file_name)) & //'.'//cdigit endif ! ! Prepare buffer to store received values if this is the first time ! for this buffer on this writer if ( writer_descripts(bufid) % wMD % bufferInitialized.eqv..false.) then allocate(writer_descripts(bufid) & % array_g(writer_descripts(bufID) % num_fd_records) ) ! also allocate the 2nd component, even though we may not ! need it for storing this particular data set allocate(writer_descripts(bufID) & % array2_g(writer_descripts(bufID) % num_fd_records) ) ! don't need to allocate memory for this buffer on this ! writer again writer_descripts(bufid) % wMD % bufferInitialized = .true. endif C... Compute the writer mpi buffer size bufsize = min(BUFSIZE_MAX, & writer_descripts(bufid) % num_items_per_record & * writer_descripts(bufid) % num_fd_records) num = bufsize / writer_descripts(bufid) % num_items_per_record iend = num istart = 1 ! ! writer processor now actually receives the data do while (istart.le.iend) buf(:) = 0.D0 C... The following mpi_reduce sends array values to rank MNPROC, C... which is a writer proc. C... Note that ranks from 0 to (MNPROC-1) are compute procs, and C... rank MNPROC of writer communicators is always a writer proc. call mpi_reduce(buf, resultBuf, bufsize, float_type, MPI_SUM, & MNPROC, comm_writer(writer_id), ierr) j = 1 do i = istart, iend writer_descripts(bufid) % array_g(i) = resultBuf(j) j = j+1 if (writer_descripts(bufid) % num_items_per_record.EQ.2) then writer_descripts(bufid) % array2_g(i) = resultBuf(j) j = j+1 endif end do istart = iend + 1 iend = min(istart + num - 1, & writer_descripts(bufid) % num_fd_records ) num = iend - istart + 1 end do writer_descripts(bufid) % wMD % bufferLoaded = .true. #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() return C----------------------------------------------------------------------- end subroutine writer_recv_values C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E F L U S H _ W R I T E R S C----------------------------------------------------------------------- C jgf51.21.27: Processor 0 will now check to see which writer C processors have received data but have not written it; C send signals to these writer processors and make each one C actually write the data for all the buffers it may be C holding. C----------------------------------------------------------------------- SUBROUTINE FLUSH_WRITERS() use global implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif INTEGER I,IERR call setMessageSource("flush_writers") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif ! ! return immediately if no writer processor has received data ! since the last flush if ( .not.any(nwloaded).eqv..true. ) then #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() return endif ! ! processor 0 loops over the writer processors and tells the ones ! that have received data in one or more of their buffers that they ! need to write it all now if(myproc.eq.0) then do i=1,mnwproc !st3 100708: flash only loaded chamber if (nwloaded(i).eqv..true.) then !st3 nwloaded()=false:unloaded, true:loaded write(scratchMessage,'(a,i0,a,i0,a)') 'Proc ',myproc, & ' is sending sig_write to writer ',i,'.' call logMessage(DEBUG, scratchMessage) call mpi_send(sig_write,1,mpi_integer,mnproc, & tag,comm_writer(i),ierr) nwloaded(i) = .false. endif enddo endif #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() return C----------------------------------------------------------------------- end subroutine flush_writers C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E W R I T E R _ W R I T E C----------------------------------------------------------------------- C Called when a dedicated writer processor receives a call to write C out the data in its buffers. C C jgf51.21.27: Modified this to use the original C descript % specifier integer instead of FULL_REC and W_NETCDF C----------------------------------------------------------------------- subroutine writer_write() use global #ifdef ADCNETCDF use NETCDFIO, only : initNetCDFOutputFile, writeOutArrayNetCDF #endif #ifdef ADCXDMF use XDMFIO, only : initOutputXDMF, writeOutArrayXDMF, writeControlXDMF #endif implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif integer :: ierr integer :: ibuf,i,j ! loop counters integer :: nnondefval ! non default values for sparse output ! ! the following logicals are dimensioned by the number of nodes (np_g) logical, allocatable :: areDefault1(:) ! true where array_g equals alternate_value logical, allocatable :: areDefault2(:) ! true where array2_g equals alternate_value integer, parameter :: fid = 100 character(len=20) :: fpos ! file position specifier on open statement character(len=20) :: fstat ! file status specifier on open statement logical :: nerr ! netcdf error status indicator call setMessageSource("writer_write") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif write(scratchMessage,'(a,i0,a)') & 'Writer ',writer_id,' is writing...' call logMessage(INFO, scratchMessage) ! ! Loop over the buffers on this writer processor and write out ! the data that are stored in them do ibuf=1, num_buf_max if (writer_descripts(ibuf) % wMD % bufferLoaded .eqv. .false.) then !write(6,'(a,i0,a,i0,a)') 'DEBUG: Writer ',writer_id,' buffer ',ibuf,' is empty.' cycle endif write(scratchMessage,'(a,i0,a,i0,a,a,a)') 'Writer ',writer_id, & ' buffer ',ibuf, & ' is full and will be written to the file "', & trim(writer_descripts(ibuf) % file_name),'"' call logMessage(DEBUG, scratchMessage) ! ! for ascii and sparse ascii, open the file appropriately if ( (abs(writer_descripts(ibuf) % specifier).eq.ASCII).or. & (abs(writer_descripts(ibuf) % specifier).eq.SPARSE_ASCII) & ) then fstat = 'old' fpos = 'append' if (isplit.eqv..true.) then !st3 split file 100708 fstat = 'replace' fpos = 'asis' endif open(fid, file=writer_descripts(ibuf) % file_name, & status=fstat, position=fpos, action='write') endif ! select case(abs(writer_descripts(ibuf) % specifier)) ! ! A S C I I ! ! tcm v50.27 added full record writing options case(ASCII) ! write dataset header write(fid, 100) writer_descripts(ibuf) % wMD % myTime, & writer_descripts(ibuf) % wMD % myTimeStep ! write dataset select case(writer_descripts(ibuf)%num_items_per_record) case(1) do i=1, writer_descripts(ibuf) % num_fd_records write(fid,1000) i, writer_descripts(ibuf) % array_g(i) end do case(2) do i=1, writer_descripts(ibuf) % num_fd_records write(fid,2000) i, writer_descripts(ibuf) % array_g(i), & writer_descripts(ibuf) % array2_g(i) end do case default write(scratchMessage,'(a,i0,a)') 'Writer cannot write ', & writer_descripts(ibuf) % num_items_per_record, & ' component data.' call allMessage(ERROR,scratchMessage) end select close(fid) ! ! S P A R S E A S C I I ! case(SPARSE_ASCII) ! Count non-default values allocate(areDefault1(writer_descripts(ibuf) & % num_fd_records)) areDefault1 = .true. where ( writer_descripts(ibuf) % array_g .ne. & writer_descripts(ibuf) % alternate_value ) areDefault1 = .false. end where ! ! write data select case(writer_descripts(ibuf)%num_items_per_record) ! !.... Sparse ASCII Scalar data case(1) nNonDefVal = count(areDefault1.eqv..false.) ! write dataset header write(fid, 100) writer_descripts(ibuf) % wMD % myTime, & writer_descripts(ibuf) % wMD % myTimeStep, & nNonDefVal, & writer_descripts(ibuf) % alternate_value ! write sparse scalar dataset do i=1, writer_descripts(ibuf) % num_fd_records if (areDefault1(i).eqv..false.) then write(fid,1000) i, & writer_descripts(ibuf) % array_g(i) endif end do close(fid) deallocate(areDefault1) ! !.... Sparse ASCII Vector data case(2) ! now we have to count the non default values on ! the second component as well allocate(areDefault2(writer_descripts(ibuf) & % num_fd_records)) areDefault2 = .true. where ( writer_descripts(ibuf) % array2_g .ne. & writer_descripts(ibuf) % alternate_value ) areDefault2 = .false. end where nNonDefVal = count((areDefault1.eqv..false.) & .and.(areDefault2.eqv..false.)) ! write dataset header write(fid, 100) writer_descripts(ibuf) % wMD % myTime, & writer_descripts(ibuf) % wMD % myTimeStep, & nNonDefVal, & writer_descripts(ibuf) % alternate_value ! write sparse vector dataset do i=1, writer_descripts(ibuf) % num_fd_records if ((areDefault1(i).eqv..false.).or. & (areDefault2(i).eqv..false.)) then write(fid,2000) i, & writer_descripts(ibuf) % array_g(i), & writer_descripts(ibuf) % array2_g(i) endif end do close(fid) deallocate(areDefault1, areDefault2) case default write(scratchMessage,'(a,i0,a)') 'Writer cannot write ', & writer_descripts(ibuf) % num_items_per_record, & ' component data.' call allMessage(ERROR, scratchMessage) end select close(fid) ! ! N E T C D F ! case(NETCDF3, NETCDF4) Cobell ... Added to allow writer core to write NetCDF output without C needing access to the entire descript array which would have C required extra message passing steps. #ifdef ADCNETCDF if (writer_descripts(ibuf)%initialized.eqv..false.) then call initNetCDFOutputFile(writer_descripts(ibuf), nerr) writer_descripts(ibuf)%initialized = .true. endif call writeOutArrayNetCDF(writer_descripts(ibuf) % lun, & writer_descripts(ibuf) % wMD % myTime, & writer_descripts(ibuf) % wMD % myTimeStep, & writer_descripts(ibuf) ) #else write(scratchMessage,'(a)') & 'NetCDF is not available. No output has been written.' call allMessage(ERROR, scratchMessage) #endif ! ! X D M F ! case(XDMF) #ifdef ADCXDMF if (writer_descripts(ibuf)%initialized.eqv..false.) then write(scratchMessage,'(a,i0,a,a)') ' Writer ',writer_id, & ' is calling initOutputXDMF for file ', & trim(writer_descripts(ibuf) % file_name) call logMessage(DEBUG, scratchMessage) call initOutputXDMF(writer_descripts(ibuf)) call writeControlXDMF( & writer_descripts(ibuf) % xdmfMD % xdmfFortranObj) writer_descripts(ibuf)%initialized = .true. endif write(scratchMessage,'(a,i0,a,a)') 'Writer ',writer_id, & ' is calling writeOutArrayXDMF for file ', & trim(writer_descripts(ibuf) % file_name) call logMessage(DEBUG, scratchMessage) call writeOutArrayXDMF( & writer_descripts(ibuf) % wMD % myTime, & writer_descripts(ibuf) % wMD % myTimeStep, & writer_descripts(ibuf) ) #else call allMessage(ERROR, & 'XDMF support was not compiled into this executable.') #endif case default write(scratchMessage,'(a,i0,a)') & 'Output specifier ', & writer_descripts(ibuf) % specifier, & ' is not supported by dedicated writer processors.' call allMessage(ERROR,scratchMessage) end select writer_descripts(ibuf) % wMD % bufferLoaded = .false. end do ! set the buffer counter back to zero on this writer processor bufid = 0 ! changed formats to match those in globalio.F 100 FORMAT(2x,1pE20.10E3,5X,I10,5X,I10,5X,1pE20.10E3) ! tcm v50.27 added for full record 110 FORMAT(2x,1pE20.10E3,5X,I10) write(scratchMessage,'(a,i0,a)') 'Writer ',writer_id, & ' finished writing.' call allMessage(INFO, scratchMessage) #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() RETURN C.... tcm v50.27 changed formats to match those in globalio.F 1000 FORMAT(2X,I8, 2X, 1PE20.10E3) !format(i8, 1x, 1pE20.10) 2000 FORMAT(2X,I8, 2X, 1PE20.10E3, 1PE20.10E3) !format(i8, 1x, 1pE20.10, 1pE20.10) C----------------------------------------------------------------------- END SUBROUTINE WRITER_WRITE C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E S E N D I N I T W R I T E R X D M F C----------------------------------------------------------------------- C jgf51.21.27: This subroutine is executed by processor 0 to send C mesh file info to the writer processor so it can read the mesh C and use it during the writing of XDMF output. C----------------------------------------------------------------------- subroutine sendInitWriterXDMF(descript) use sizes, only : myproc use global implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif type (OutputDataDescript_t), intent(in) :: descript character(len=80) :: fileKeyword character(len=80) :: fileValue integer :: ierr C call setMessageSource("sendInitWriterXDMF") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif ! jgf51.21.27: Figure out which mpi communicator to use with this ! writer processor. if (wcommID.ge.mnwproc) then wcommID = 0 endif wcommID = wcommID + 1 ! ! jgf51.21.27: proc 0 signals the writer processor to tell it that ! the mesh info is coming, and then sends the data if (myproc.eq.0) then write(scratchMessage,'(a,i0,a,i0,a)') & 'Processor ',myproc,' is sending sig_mesh to writer ',wcommID,'.' call logMessage(INFO, scratchMessage) ! ! Send sig_mesh to a writer to get it ready to receive metadata. call mpi_send(sig_mesh, 1, mpi_integer, mnproc, tag, & comm_writer(wcommID), ierr) ! ! read the fulldomain mesh file name and control file name ! so that the writer can load them up and use them (it only ! uses the control file for generating metadata) ... the ! 'fulldomainInputFiles' file is created by adcprep call openFileForRead(30,trim(globaldir)//'/fulldomainInputFiles', ierr) do read(30,fmt='(a80)',end=10) fileKeyword read(30,fmt='(a80)',end=10) fileValue select case(trim(fileKeyword)) case('meshType') call getFormatInteger(fileValue, meshType) case('controlType') call getFormatInteger(fileValue, controlType) case('meshFileName') meshFileName_g = trim(globaldir) // '/' // fileValue case('controlFileName') controlFileName_g = trim(globaldir) // '/' // fileValue case default ! ignore the keywords and values we are not interested in end select end do 10 close(30) call mpi_send(meshFileName_g, 2048, mpi_character, & mnproc, tag, comm_writer(wcommID), ierr) call mpi_send(controlFileName_g, 2048, mpi_character, & mnproc, tag, comm_writer(wcommID), ierr) ! mesh file type call mpi_send(meshType, 1, mpi_integer, mnproc, tag, & comm_writer(wcommID), ierr) ! control file type call mpi_send(controlType, 1, mpi_integer, mnproc, tag, & comm_writer(wcommID), ierr) ! ending time step call mpi_send(nt, 1, mpi_integer, mnproc, tag, & comm_writer(wcommID), ierr) endif C #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() return C----------------------------------------------------------------------- end subroutine sendInitWriterXDMF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E W R I T E R R E A D M E S H C----------------------------------------------------------------------- C jgf51.21.27: This subroutine causes a dedicated writer processor C to read the fulldomain mesh file so that it can later be written C into XDMF output files. C----------------------------------------------------------------------- subroutine writerReadMesh() use global use mesh, only : readMesh, x, y, slam, sfea use sizes, only: MESHFILENAME,CONTROLFILENAME #ifdef ADCXDMF use xdmfio, only : meshInitialized use control, only : readControlFile #endif implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif integer :: ierr integer :: mpistat(mpi_status_size) character(len=8) :: cdigit !st3 100708: split file call setMessageSource("writerReadMesh") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif #ifdef ADCXDMF ! ! receive file name of mesh file call mpi_recv(meshFileName, 2048, mpi_character, 0, tag, & comm_writer(writer_id), mpistat, ierr) call mpi_recv(controlFileName, 2048, mpi_character, 0, tag, & comm_writer(writer_id), mpistat, ierr) ! ! Receive the file type of the mesh file call mpi_recv(meshType, 1, mpi_integer, 0, tag, & comm_writer(writer_id), mpistat, ierr) call mpi_recv(controlType, 1, mpi_integer, 0, tag, & comm_writer(writer_id), mpistat, ierr) write(scratchMessage,'(a,i0,a,a)') 'Writer ',writer_id, & ' received mesh file name ',trim(meshFileName) call logMessage(INFO, scratchMessage) write(scratchMessage,'(a,a,a)') 'Writer GLOBALDIR is ', & trim(GLOBALDIR),'.' call logMessage(INFO,scratchMessage) ! ending time step call mpi_recv(nt, 1, mpi_integer, 0, tag, & comm_writer(writer_id), mpistat, ierr) ! ! now read the mesh so it can be used to create XDMF output files if (meshInitialized.eqv..false.) then call readMesh() ! the x and y will be written to the output filem but the ! readMesh routine only populates the slam and sfea arrays x = slam y = sfea meshInitialized = .true. endif ! read the fort.15 file for metadata call readControlFile(controlFileName_g,.false.) #endif #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() return C----------------------------------------------------------------------- end subroutine writerReadMesh C----------------------------------------------------------------------- C----------------------------------------------------------------------- C S U B R O U T I N E W R I T E R _ P A U S E C----------------------------------------------------------------------- C Sends a signal to all writer processors to pause, which just C means that they exit their infinite loop and return. This C subroutine is only called by processor 0. C----------------------------------------------------------------------- subroutine writer_pause() use global use messenger implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif integer i C call setMessageSource("writer_pause") #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Enter.") #endif ! ! iterate over the writer processors and use their designated ! mpi communicator to signal them to pause do i=1,mnwproc call mpi_send( sig_pause, 1, mpi_integer, mnproc, & tag, comm_writer(i), ierr) enddo C C #if defined(WRITER_TRACE) || defined(ALL_TRACE) call allMessage(DEBUG,"Return.") #endif call unsetMessageSource() return C----------------------------------------------------------------------- end subroutine writer_pause C----------------------------------------------------------------------- C----------------------------------------------------------------------- C----------------------------------------------------------------------- END MODULE WRITER C----------------------------------------------------------------------- C----------------------------------------------------------------------- ! ! ! !! C_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/ C MODULE HSWRITER !st3 C This module is for writer processors for hotstart files based on S.Bunya's C_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/ C MODULE HSWRITER USE SIZES USE GLOBAL USE MESSENGER, ONLY: TAG, COMM_WRITEH, COMM_HSLEEP, WRITER_ID, & SIG_TERM, MSG_FINI #ifdef HAVE_MPI_MOD use mpi #endif IMPLICIT NONE INTEGER :: WCOMMID, WCOMM CONTAINS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!? !------------------------------------------------------------ SUBROUTINE HSWRITER_INIT () WCOMMID = 0 END SUBROUTINE HSWRITER_INIT ! !------------------------------------------------------------ ! SUBROUTINE HSWRITER_MAIN () USE GLOBAL,ONLY : ScreenUnit IMPLICIT NONE #ifndef HAVE_MPI_MOD include 'mpif.h' #endif INTEGER :: SIG,IERR INTEGER :: STAT(MPI_STATUS_SIZE) call setMessageSource("HSWRITER_MAIN") ! WCOMMID=WRITER_ID WCOMM=COMM_WRITEH(WCOMMID) C... Main loop DO WHILE(.TRUE.) CALL MPI_BARRIER(COMM_HSLEEP(WRITER_ID),IERR) !st3 CALL MPI_RECV(SIG, 1, MPI_INTEGER, 0, TAG, & COMM_WRITEH(WRITER_ID),STAT,IERR) IF(SIG == SIG_WRITE) THEN WRITE(ScreenUnit,*) 'HSWRITER PROC ',WRITER_ID, & ' RECEIVED SIG_WRITE' CALL writeHotstart_through_HSwriter(0.0d0, 0) !tcm v49.52.01 added SIG_PAUSE ELSE IF(SIG == SIG_PAUSE) then WRITE(ScreenUnit,*) 'HSWRITER PROC ',WRITER_ID, & ' RECEIVED SIG_PAUSE' EXIT ELSE IF(SIG == SIG_TERM) THEN WRITE(ScreenUnit,*) 'HSWRITER PROC ',WRITER_ID, & ' RECEIVED SIG_TERM' EXIT ENDIF ENDDO !tcm v49.52.01 commented out next two lines ! CALL MSG_FINI() ! STOP call unsetMessageSource() END SUBROUTINE HSWRITER_MAIN ! !------------------------------------------------------------ ! tcm v49.52.01 added the HSWRITER_PAUSE subroutine ! subroutine HSWRITER_PAUSE() use global use messenger implicit none #ifndef HAVE_MPI_MOD include 'mpif.h' #endif integer i DO I=1,MNWPROH CALL MPI_SEND( SIG_PAUSE, 1, MPI_INTEGER, MNPROC, & TAG,COMM_WRITEH(I), IERR) ENDDO return end subroutine HSWRITER_PAUSE ! !------------------------------------------------------------ C C----------------------------------------------------------------------- C SUBROUTINE BASED ON "WRITEHOTSTART" C----------------------------------------------------------------------- C This subroutine was copied from write_output.F writeHotstart C and fitted to writer core algorithm !st3 05.15.2010 C C ******* THIS SUBROUTINE DOES NOT DEAL WITH NETCDF C----------------------------------------------------------------------- SUBROUTINE writeHotstart_through_HSwriter(TimeLoc, IT) USE SIZES USE GLOBAL USE MESH, ONLY : NE, NP USE GLOBAL_IO, ONLY: packOne, unpackOne, packOneInt, unpackOneInt, & packTwo, unpackTwo, HEADER_MAX ! & collectFullDomainArray, collectFullDomainIntArray USE MESSENGER ! IMPLICIT NONE #ifndef HAVE_MPI_MOD include 'mpif.h' #endif INTEGER :: STAT(MPI_STATUS_SIZE) integer :: i REAL(8), intent(in) :: TimeLoc INTEGER, intent(in) :: IT ! double precision :: ttime, dpack(1) !st3 integer :: iit, ipack(26) !st3 character(len=2048) :: cjunk1 !st3 character(len=20) :: cjunk2 !st3 tcm v51.26 changed from 10 to 20 integer :: iNHSINC !tcm v51.26 ! type(OutputDataDescript_t) :: descript INTEGER npx, nex CHARACTER*9 :: itstr !tcm v51.26 added for time-stamped hot start file name adjustments type(OutputDataDescript_t), SAVE :: Elev1Descript type(OutputDataDescript_t), SAVE :: Elev2Descript type(OutputDataDescript_t), SAVE :: VelDescript type(OutputDataDescript_t), SAVE :: CH1Descript type(OutputDataDescript_t), SAVE :: EtaDiscDescript type(OutputDataDescript_t), SAVE :: NodeCodeDescript type(OutputDataDescript_t), SAVE :: NOFFDescript LOGICAL, SAVE :: FirstCall = .true. ! call setMessageSource("writeHotstart_through_HSwriter") if( myproc <= MNPROC-1 ) then CALL GET_NEXT_HSWRITER_COMM(WCOMM) endif ! iit = 0 ttime=0.0d0 ! if( myproc==0 ) then CALL MPI_BARRIER(COMM_HSLEEP(WCOMMID),IERR) !st3 CALL MPI_SEND(SIG_WRITE,1,MPI_INTEGER,MNPROC,TAG,WCOMM,IERR) ipack( 1) = IT ipack( 2) = NHSTAR ipack( 3) = IM ipack( 4) = NP_G ipack( 5) = NE_G ipack( 6) = hss%lun ipack( 7) = FileFmtVersion ipack( 8) = IESTP ipack( 9) = NSCOUE ipack(10) = IVSTP ipack(11) = NSCOUV ipack(12) = ICSTP ipack(13) = NSCOUC ipack(14) = IPSTP ipack(15) = IWSTP ipack(16) = NSCOUM ipack(17) = IGEP ipack(18) = NSCOUGE ipack(19) = IGVP ipack(20) = NSCOUGV ipack(21) = IGCP ipack(22) = NSCOUGC ipack(23) = IGPP ipack(24) = IGWP ipack(25) = NSCOUGW ipack(26) = NHSINC !tcm v51.26 dpack(1) = TimeLoc cjunk1 = trim(adjustl(HOTSTARTDIR)) cjunk2 = trim(adjustl(hss%filename)) CALL MPI_SEND(ipack,26,MPI_INTEGER,MNPROC,TAG,WCOMM,IERR) CALL MPI_SEND(dpack,1,MPI_DOUBLE_PRECISION,MNPROC,TAG,WCOMM,IERR) CALL MPI_SEND(WRITE_LOCAL_HOT_START_FILES,1,MPI_LOGICAL, & MNPROC,TAG,WCOMM,IERR) CALL MPI_SEND(cjunk1,2048,MPI_CHARACTER,MNPROC,TAG,WCOMM,IERR) CALL MPI_SEND(cjunk2, 20,MPI_CHARACTER,MNPROC,TAG,WCOMM,IERR) !tcm v51.26 changed to length 20 endif if( WRITER_ID /= 0 ) then CALL MPI_RECV(ipack,26,MPI_INTEGER,0,TAG,WCOMM,STAT,IERR) CALL MPI_RECV(dpack,1,MPI_DOUBLE_PRECISION,0,TAG,WCOMM,STAT,IERR) CALL MPI_RECV(WRITE_LOCAL_HOT_START_FILES,1,MPI_LOGICAL, & 0, TAG,WCOMM,STAT,IERR) CALL MPI_RECV(cjunk1,2048,MPI_CHARACTER,0,TAG,WCOMM,STAT,IERR) CALL MPI_RECV(cjunk2, 20,MPI_CHARACTER,0,TAG,WCOMM,STAT,IERR) !tcm v51.26 changed from 10 to 20 iit = ipack( 1) NHSTAR = ipack( 2) IM = ipack( 3) NP_G = ipack( 4) NE_G = ipack( 5) hss%lun = ipack( 6) FileFmtVersion = ipack( 7) IESTP = ipack( 8) NSCOUE = ipack( 9) IVSTP = ipack(10) NSCOUV = ipack(11) ICSTP = ipack(12) NSCOUC = ipack(13) IPSTP = ipack(14) IWSTP = ipack(15) NSCOUM = ipack(16) IGEP = ipack(17) NSCOUGE = ipack(18) IGVP = ipack(19) NSCOUGV = ipack(20) IGCP = ipack(21) NSCOUGC = ipack(22) IGPP = ipack(23) IGWP = ipack(24) NSCOUGW = ipack(25) iNHSINC = ipack(26) !tcm v51.26 ttime = dpack(1) HOTSTARTDIR =trim(adjustl(cjunk1)) hss%filename=trim(adjustl(cjunk2)) NP = 0 NE = 0 endif CALL MPI_BARRIER(WCOMM,IERR) !st3 IF (WRITE_LOCAL_HOT_START_FILES) THEN write(6,*) 'HSWriter can not treat Local HOT START FILES' STOP ENDIF ! WRITE(16,*) "***********WRITE HOTSTART*********************" WRITE(16,*) "NHSTAR = ", NHSTAR WRITE(16,*) "FirstCall = ", FirstCall IF (FirstCall) THEN IF ( WRITER_ID /= 0 ) THEN IF (.not.ALLOCATED(ETA1_g)) THEN write(16,*) 'Allocating Elev1Descript' ALLOCATE(ETA1_g(NP_G)) ENDIF ENDIF Elev1Descript % specifier = NHSTAR Elev1Descript % initial_value = 0.0 Elev1Descript % num_items_per_record = 1 Elev1Descript % num_fd_records = NP_G Elev1Descript % num_records_this = NP Elev1Descript % imap => NODES_LG Elev1Descript % array => ETA1 Elev1Descript % array_g => ETA1_g IF ( WRITER_ID /= 0 ) THEN IF (.not.ALLOCATED(ETA2_g)) THEN write(16,*) 'Allocating Elev2Descript' ALLOCATE(ETA2_g(NP_G)) ENDIF ENDIF Elev2Descript % specifier = NHSTAR Elev2Descript % initial_value = 0.0 Elev2Descript % num_items_per_record = 1 Elev2Descript % num_fd_records = NP_G Elev2Descript % num_records_this = NP Elev2Descript % imap => NODES_LG Elev2Descript % array => ETA2 Elev2Descript % array_g => ETA2_g IF ( WRITER_ID /= 0 ) THEN IF (.not.ALLOCATED(UU2_g)) THEN write(16,*) 'Allocating VelDescript' ALLOCATE(UU2_g(NP_G)) ALLOCATE(VV2_g(NP_G)) ENDIF ENDIF VelDescript % specifier = NHSTAR VelDescript % initial_value = 0.0 VelDescript % num_items_per_record = 2 VelDescript % num_fd_records = NP_G VelDescript % num_records_this = NP VelDescript % imap => NODES_LG VelDescript % array => UU2 VelDescript % array2 => VV2 VelDescript % array_g => UU2_g VelDescript % array2_g => VV2_g IF (IM.eq.10) THEN IF ( WRITER_ID /= 0 ) THEN write(16,*) 'Allocating CH1Descript' ALLOCATE(CH1_g(NP_G)) ENDIF CH1Descript % specifier = NHSTAR CH1Descript % initial_value = 0.0 CH1Descript % num_items_per_record = 1 CH1Descript % num_fd_records = NP_G CH1Descript % num_records_this = NP CH1Descript % imap => NODES_LG CH1Descript % array => CH1 CH1Descript % array_g => CH1_g ENDIF IF ( WRITER_ID /= 0 ) THEN write(16,*) 'Allocating EtaDiscDescript' ALLOCATE(EtaDisc_g(NP_G)) ENDIF EtaDiscDescript % specifier = NHSTAR EtaDiscDescript % initial_value = 0.0 EtaDiscDescript % num_items_per_record = 1 EtaDiscDescript % num_fd_records = NP_G EtaDiscDescript % num_records_this = NP EtaDiscDescript % imap => NODES_LG EtaDiscDescript % array => EtaDisc EtaDiscDescript % array_g => EtaDisc_g IF ( WRITER_ID /= 0 ) THEN write(16,*) 'Allocating NodeCodeDescript' ALLOCATE(NodeCode_g(NP_G)) ENDIF NodeCodeDescript % specifier = NHSTAR NodeCodeDescript % int_initial_value = 0 NodeCodeDescript % num_items_per_record = 1 NodeCodeDescript % num_fd_records = NP_G NodeCodeDescript % num_records_this = NP NodeCodeDescript % imap => NODES_LG NodeCodeDescript % iarray => NODECODE NodeCodeDescript % iarray_g => NODECODE_g IF ( WRITER_ID /= 0 ) THEN write(16,*) 'Allocating NOFFDescript' ALLOCATE(NOFF_g(NE_G)) ENDIF NOFFDescript % specifier = NHSTAR NOFFDescript % int_initial_value = 0 NOFFDescript % num_items_per_record = 1 NOFFDescript % num_fd_records = NE_G NOFFDescript % num_records_this = NE NOFFDescript % imap => IMAP_EL_LG NOFFDescript % iarray => NOFF NOFFDescript % iarray_g => NOFF_g FirstCall = .false. ENDIF C collect up the data from subdomains if running in parallel CALL collectFullDomainArrayw(Elev1Descript, packOne, unpackOne) CALL collectFullDomainArrayw(Elev2Descript, packOne, unpackOne) CALL collectFullDomainArrayw(VelDescript, packTwo, unpackTwo) IF (IM.eq.10) THEN CALL collectFullDomainArrayw(CH1Descript, packOne, unpackOne) ENDIF CALL collectFullDomainArrayw(EtaDiscDescript, packOne, unpackOne) CALL collectFullDomainIntArrayw(NodeCodeDescript, packOneInt, unpackOneInt) CALL collectFullDomainIntArrayw(NOFFDescript, packOneInt, unpackOneInt) ! tcm v49.54 -- changed noff to noff_g to fix an allocation bug in hot start writer WHERE (NOFF_G.gt.1) NOFF_g = 1 ! WRITE(16,*) "FINISH collectFullDomainArray" SELECT CASE (NHSTAR) !tcm v51.26 added nhstar=-1 for time-stamped hot starts CASE(-1,1) ! nonportable binary (1 for backwards compatibility) NPX = NP_G NEX = NE_G IF ((WRITER_ID /= 0)) THEN !tcm v51.26 mod for time-stamped hot start files nhstar=-1 IF (NHSTAR.eq.-1) THEN hss % filename(:) = ' ' hss % filename = 'fort.68_' itstr(:) = ' ' WRITE(itstr,'(I9.9)') IIT !note that IIT is the correct value and not IT for writers hss % filename(9:17) = itstr ENDIF OPEN(hss % lun ,FILE=TRIM(adjustl(HOTSTARTDIR))//'/'//trim(adjustl(hss%filename)), $ ACCESS='DIRECT',RECL=8) IHOTSTP=1 WRITE(hss % lun,REC=IHOTSTP) FileFmtVersion IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IM ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) ttime; IHOTSTP = IHOTSTP + 1 !st3 WRITE(hss % lun,REC=IHOTSTP) iit ; IHOTSTP = IHOTSTP + 1 !st3 WRITE(hss % lun,REC=IHOTSTP) NPX ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NEX ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NPX ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NEX ; IHOTSTP = IHOTSTP + 1 ENDIF IF ( WRITER_ID /= 0 ) THEN DO I=1, Elev1Descript % num_fd_records WRITE(hss % lun,REC=IHOTSTP) Elev1Descript % array_g(I) IHOTSTP=IHOTSTP+1 ENDDO DO I=1, Elev2Descript % num_fd_records WRITE(hss % lun,REC=IHOTSTP) Elev2Descript % array_g(I) IHOTSTP=IHOTSTP+1 ENDDO DO I=1, EtaDiscDescript % num_fd_records WRITE(hss % lun,REC=IHOTSTP) EtaDiscDescript % array_g(I) IHOTSTP=IHOTSTP+1 ENDDO DO I=1, VelDescript % num_fd_records WRITE(hss % lun,REC=IHOTSTP) VelDescript % array_g(I) IHOTSTP=IHOTSTP+1 ENDDO DO I=1, VelDescript % num_fd_records WRITE(hss % lun,REC=IHOTSTP) VelDescript % array2_g(I) IHOTSTP=IHOTSTP+1 ENDDO IF (IM.eq.10) THEN DO I=1, CH1Descript % num_fd_records WRITE(hss % lun,REC=IHOTSTP) CH1Descript % array_g(I) IHOTSTP=IHOTSTP+1 ENDDO ENDIF DO I=1, NodeCodeDescript % num_fd_records WRITE(hss % lun,REC=IHOTSTP)NodeCodeDescript % iarray_g(I) IHOTSTP=IHOTSTP+1 ENDDO DO I=1, NOFFDescript % num_fd_records WRITE(hss % lun,REC=IHOTSTP) NOFFDescript % iarray_g(I) IHOTSTP=IHOTSTP+1 ENDDO ENDIF C IF (WRITER_ID /= 0) THEN WRITE(hss % lun,REC=IHOTSTP) IESTP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUE ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IVSTP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUV ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) ICSTP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUC ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IPSTP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IWSTP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUM ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IGEP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUGE ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IGVP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUGV ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IGCP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUGC ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IGPP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) IGWP ; IHOTSTP = IHOTSTP + 1 WRITE(hss % lun,REC=IHOTSTP) NSCOUGW ; IHOTSTP = IHOTSTP + 1 ENDIF CASE(2) ! ascii? write(16,*) 'ASCII Hotstart file not implemented yet.' CASE(3) ! netcdf write(16,*) 'NetCDF Hotstart undergoing testing.' CASE DEFAULT write(ScreenUnit,*) 'The value of NHSTAR=',NHSTAR write(ScreenUnit,*) 'is not supported.' write(ScreenUnit,*) 'Hotstart file not written.' END SELECT C... C... CLOSE THE HOT START OUTPUT FILE C... IF(ABS(NHSTAR).EQ.1) THEN ! added by mcf 7/14/08 tcm v51.26 added abs(nhstar) if (WRITER_ID /= 0) CLOSE(hss % lun) ENDIF ! end NHSTAR=1 IF(NSCREEN.NE.0.AND. WRITER_ID /= 0 ) THEN WRITE(ScreenUnit,24541) hss % lun, WRITER_ID, IIT, ttime !tcm v51.26 changed IT to IIT and TimeLoc to ttime since WRITE(16,24541) hss % lun, WRITER_ID, IIT, ttime !IT and TimeLoc are not known by writer processor id /=0 (echoing to writer file) ELSE WRITE(16,24541) hss % lun,WRITER_ID,IT,TimeLoc ENDIF 24541 FORMAT(1X,'HOT START OUTPUT WRITTEN TO UNIT ',I2,' HSWriter:',i2 & ' AT TIME STEP = ',I9,' TIME = ',E15.8) IF(hss % lun.EQ.67) THEN C jgf45.07 added option to stop ADCIRC after writing hot start file. IF (NHSTAR.EQ.67) THEN WRITE(ScreenUnit,*) 'NHSTAR.EQ.67; ADCIRC stopping.' WRITE(16,*) 'NHSTAR.EQ.67; ADCIRC stopping.' ENDIF hss % lun = 68 IF(NHSTAR.EQ.1) THEN hss % filename(:) = ' ' hss % filename = 'fort.68' ! added by mcf 7/14/08 ENDIF !tcm v51.26 mod for time-stamped nhstar=-1 This section is just a failsafe IF (NHSTAR.eq.-1) THEN hss % filename(:) = ' ' hss % filename = 'fort.68_' itstr(:) = ' ' WRITE(itstr,'(I9.9)') IIT+iNHSINC !setting the name for the next hot start file hss % filename(9:17) = itstr ENDIF ELSE IF (NHSTAR.EQ.68) THEN WRITE(ScreenUnit,*) 'NHSTAR.EQ.68; ADCIRC stopping.' WRITE(16,*) 'NHSTAR.EQ.68; ADCIRC stopping.' ENDIF hss % lun=67 IF(NHSTAR.EQ.1) THEN hss % filename(:) = ' ' hss % filename = 'fort.67' ! added by mcf 7/14/08 ENDIF !tcm v51.26 mod for time-stamped nhstar=-1 This section is just a failsafe IF (NHSTAR.eq.-1) THEN hss % filename(:) = ' ' hss % filename = 'fort.68_' itstr(:) = ' ' WRITE(itstr,'(I9.9)') IIT+iNHSINC !setting the name for the next hot start file hss % filename(9:17) = itstr ENDIF ENDIF call unsetMessageSource() END SUBROUTINE writeHotstart_through_HSwriter ! SUBROUTINE GET_NEXT_HSWRITER_COMM(NEXT_WCOMM) include 'mpif.h' INTEGER,intent(inout) :: NEXT_WCOMM INTEGER :: NEXT_WCOMMID IF(WCOMMID >= MNWPROH) THEN WCOMMID = 0 ENDIF WCOMMID = WCOMMID + 1 NEXT_WCOMMID = MOD(WCOMMID - 1,MNWPROH) + 1 NEXT_WCOMM = COMM_WRITEH(NEXT_WCOMMID) END SUBROUTINE GET_NEXT_HSWRITER_COMM ! ! !-------------------------------------------------------------- subroutine collectFullDomainArrayw(descript, pack_cmd, unpack_cmd) ! !-------------------------------------------------------------- implicit none #ifdef CMPI #ifndef HAVE_MPI_MOD include 'mpif.h' #endif #endif type (OutputDataDescript_t) :: descript external pack_cmd external unpack_cmd #ifdef CMPI ! ! the subroutine used to write the file integer :: ierr, status(MPI_STATUS_SIZE), request integer, save:: tagbase = 6000 integer :: iproc integer :: bufsize integer :: ibucket integer :: istart ! vector tuple to start with integer :: iend ! vector tuple to end on integer :: tag ! ! number of vector tuples in the buffer integer :: num integer :: i, j, k bufsize = min(BUFSIZE_MAX, & descript % num_items_per_record * descript % num_fd_records) num = bufsize / descript % num_items_per_record iend = num istart = 1 if (tagbase == 5000) then tagbase = 6000 else tagbase = 5000 endif ibucket = 0 do while (istart < iend) ! !------------------------------------------------------------ ! ! Initialize ! !------------------------------------------------------------ buf(:) = descript % initial_value ibucket = ibucket + 1 tag = tagbase + mod(ibucket, 8) call pack_cmd(descript, istart, iend) call mpi_reduce(buf, resultBuf, bufsize, float_type, MPI_SUM, & MNPROC, WCOMM, ierr) if (WRITER_ID /= 0) then call unpack_cmd(descript, istart, iend) end if istart = iend + 1 iend = min(istart + num - 1, descript % num_fd_records) num = iend - istart + 1 end do #endif ! !-------------------------------------------------------------- end subroutine collectFullDomainArrayw ! !-------------------------------------------------------------- ! ! !-------------------------------------------------------------- subroutine collectFullDomainIntArrayw(descript, & pack_cmd, unpack_cmd) ! !-------------------------------------------------------------- implicit none #ifdef CMPI #ifndef HAVE_MPI_MOD include 'mpif.h' #endif #endif type (OutputDataDescript_t) :: descript external pack_cmd external unpack_cmd #ifdef CMPI ! ! the subroutine used to write the file integer :: ierr, status(MPI_STATUS_SIZE), request integer, save:: tagbase = 6000 integer :: iproc integer :: bufsize integer :: ibucket integer :: istart ! vector tuple to start with integer :: iend ! vector tuple to end on integer :: tag ! ! number of vector tuples in the buffer integer :: num integer :: i, j, k bufsize = min(BUFSIZE_MAX, & descript % num_items_per_record * descript % num_fd_records) num = bufsize / descript % num_items_per_record iend = num istart = 1 if (tagbase == 5000) then tagbase = 6000 else tagbase = 5000 endif ibucket = 0 do while (istart < iend) ! ! Initialize integerBuffer(:) = descript % int_initial_value ibucket = ibucket + 1 tag = tagbase + mod(ibucket, 8) call pack_cmd(descript, istart, iend) call mpi_reduce(integerBuffer, integerResultBuffer, bufsize, & MPI_INTEGER, MPI_SUM, MNPROC, WCOMM, ierr) if (WRITER_ID /= 0) then call unpack_cmd(descript, istart, iend) end if istart = iend + 1 iend = min(istart + num - 1, descript % num_fd_records) num = iend - istart + 1 end do #endif C! CMPI ! !-------------------------------------------------------------- end subroutine collectFullDomainIntArrayw ! !-------------------------------------------------------------- ! END MODULE HSWRITER