!> @file
!> @brief Contains module WMINIOMD.
!>
!> @author H. L. Tolman @date 28-Sep-2016
!>
#include "w3macros.h"
!/ ------------------------------------------------------------------- /
!>
!> @brief Internal IO routines for the multi-grid model.
!>
!> @author H. L. Tolman @date 28-Sep-2016
!>
MODULE WMINIOMD
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 28-Sep-2016 |
!/ +-----------------------------------+
!/
!/ 29-May-2006 : Origination. ( version 3.09 )
!/ 21-Dec-2006 : VTIME change in WMIOHx and WMIOEx. ( version 3.10 )
!/ 22-Jan-2007 : Adding NAVMAX in WMIOEG. ( version 3.10 )
!/ 30-Jan-2007 : Fix memory leak WMIOBS. ( version 3.10 )
!/ 29-May-2009 : Preparing distribution version. ( version 3.14 )
!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 )
!/ 16-Dec-2020 : Modify WMIOES/G for SMC grid. JGLi ( version 7.13 )
!/
!/ Copyright 2009 National Weather Service (NWS),
!/ National Oceanic and Atmospheric Administration. All rights
!/ reserved. WAVEWATCH III is a trademark of the NWS.
!/ No unauthorized use without permission.
!/
! 1. Purpose :
!
! Internal IO routines for the multi-grid model.
!
! 2. Variables and types :
!
! 3. Subroutines and functions :
!
! Name Type Scope Description
! ----------------------------------------------------------------
! WMIOBS Subr. Public Stage internal boundary data.
! WMIOBG Subr. Public Gather internal boundary data.
! WMIOBF Subr. Public Finalize WMIOBS. ( !/MPI )
! WMIOHS Subr. Public Stage internal high to low data.
! WMIOHG Subr. Public Gather internal high to low data.
! WMIOHF Subr. Public Finalize WMIOHS. ( !/MPI )
! WMIOES Subr. Public Stage internal same rank data.
! WMIOEG Subr. Public Gather internal same rank data.
! WMIOEF Subr. Public Finalize WMIOES. ( !/MPI )
! ----------------------------------------------------------------
!
! 4. Subroutines and functions used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
! Subr. WxxDATMD Manage data structures.
! W3UBPT Subr. W3UBPTMD Update internal bounday spectra.
! W3IOBC Subr W3IOBCMD I/O of boundary data.
! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
! STRACE Sur. W3SERVMD Subroutine tracing.
!
! MPI_ISEND, MPI_IRECV, MPI_TESTALL, MPI_WAITALL
! Subr. mpif.h MPI routines.
! ----------------------------------------------------------------
!
! 5. Remarks :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Enable test output
! !/MPIT
!
! 6. Switches :
!
! 7. Source code :
!
!/ ------------------------------------------------------------------- /
PUBLIC
!/
CONTAINS
!/ ------------------------------------------------------------------- /
!>
!> @brief Stage internal boundary data in the data structure BPSTGE.
!>
!> @details For the shared memory version, arrays are initialized and
!> the data are copied. For the distributed memory version, the data
!> are moved using a non-blocking send. In this case, the arrays
!> are dimensioned on the receiving side.
!>
!> @param[in] IMOD Model number of grid from which data is to
!> be staged.
!>
!> @author H. L. Tolman @date 06-Jun-2018
!>
SUBROUTINE WMIOBS ( IMOD )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 06-Jun-2018 !
!/ +-----------------------------------+
!/
!/ 06-Oct-2005 : Origination. ( version 3.08 )
!/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 )
!/ 30-Jan-2007 : Fix memory leak. ( version 3.10 )
!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 )
!/ 06-Jun-2018 : Use W3PARALL/add DEBUGIOBC/PDLIB ( version 6.04 )
!/
! 1. Purpose :
!
! Stage internal boundary data in the data structure BPSTGE.
!
! 2. Method :
!
! For the shared memory version, arrays are initialized and the
! data are copied. For the distributed memory version, the data
! are moved using a non-blocking send. in this case, the arrays
! are dimensioned on the recieving side.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data is to
! be staged.
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
! Subr. WxxDATMD Manage data structures.
! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
! STRACE Subr. W3SERVMD Subroutine tracing.
! EXTCDE Sur. Id. Program abort.
!
! MPI_ISEND
! Subr. mpif.h MPI routines.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMINIT Subr WMINITMD Multi-grid model initialization.
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! See FORMAT label 1001.
!
! 7. Remarks :
!
! 8. Structure :
!
! See source code.
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Enable test output
! !/MPIT
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE W3GDATMD
USE W3WDATMD
USE W3ADATMD
USE W3ODATMD
USE WMMDATMD
!
USE W3CSPCMD, ONLY: W3CSPC
USE W3SERVMD, ONLY: EXTCDE
USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J, I, IOFF, ISEA, JSEA, IS
#ifdef W3_DIST
INTEGER :: ISPROC
#endif
#ifdef W3_MPI
INTEGER :: IP, IT0, ITAG, IERR_MPI
INTEGER, POINTER :: NRQ, IRQ(:)
#endif
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
REAL, POINTER :: SBPI(:,:), TSTORE(:,:)
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOBS')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD
WRITE (MDST,9001) NBI2G(:,IMOD)
#endif
!
IF ( SUM(NBI2G(:,IMOD)) .EQ. 0 ) RETURN
!
CALL W3SETO ( IMOD, MDSE, MDST )
CALL W3SETG ( IMOD, MDSE, MDST )
CALL W3SETW ( IMOD, MDSE, MDST )
CALL W3SETA ( IMOD, MDSE, MDST )
!
! -------------------------------------------------------------------- /
! 1. Loop over grids
!
DO J=1, NRGRD
!
IF ( NBI2G(J,IMOD) .EQ. 0 ) CYCLE
!
CALL WMSETM ( J , MDSE, MDST )
!
IF ( IMOD .EQ. 1 ) THEN
IOFF = 0
ELSE
IOFF = SUM(NBI2G(J,1:IMOD-1))
END IF
!
#ifdef W3_T
WRITE (MDST,9010) NBI2G(J,IMOD),IMOD,J,IOFF+1,RESPEC(J,IMOD)
#endif
!
! -------------------------------------------------------------------- /
! 2. Allocate arrays
!
#ifdef W3_SHRD
IF ( BPSTGE(J,IMOD)%INIT ) THEN
IF ( SIZE(BPSTGE(J,IMOD)%SBPI(:,1)) .NE. NSPEC .OR. &
SIZE(BPSTGE(J,IMOD)%SBPI(1,:)) &
.NE. NBI2G(J,IMOD) ) THEN
DEALLOCATE ( BPSTGE(J,IMOD)%SBPI )
BPSTGE(J,IMOD)%INIT = .FALSE.
END IF
END IF
#endif
!
#ifdef W3_SHRD
IF ( .NOT. BPSTGE(J,IMOD)%INIT ) THEN
NSPEC => SGRDS(J)%NSPEC
ALLOCATE ( BPSTGE(J,IMOD)%SBPI(NSPEC,NBI2G(J,IMOD)) )
NSPEC => SGRDS(IMOD)%NSPEC
BPSTGE(J,IMOD)%INIT = .TRUE.
END IF
#endif
!
#ifdef W3_SHRD
IF ( RESPEC(J,IMOD) ) THEN
ALLOCATE ( TSTORE(NSPEC,NBI2G(J,IMOD)) )
SBPI => TSTORE
ELSE
SBPI => BPSTGE(J,IMOD)%SBPI
END IF
#endif
!
#ifdef W3_MPI
NAPROC => OUTPTS(J)%NAPROC
ALLOCATE ( IRQ(NBI2G(J,IMOD)*NAPROC+NAPROC) )
ALLOCATE ( BPSTGE(J,IMOD)%TSTORE(NSPEC,NBI2G(J,IMOD)) )
NAPROC => OUTPTS(IMOD)%NAPROC
#endif
!
#ifdef W3_MPI
NRQ => BPSTGE(J,IMOD)%NRQBPS
SBPI => BPSTGE(J,IMOD)%TSTORE
#endif
!
#ifdef W3_MPI
NRQ = 0
IRQ = 0
#endif
!
! -------------------------------------------------------------------- /
! 3. Set the time
! Note that with MPI the send needs to be posted to the local
! processor too to make time management possible.
!
#ifdef W3_T
WRITE (MDST,9030) TIME
#endif
#ifdef W3_MPIT
WRITE (MDST,9080)
#endif
!
#ifdef W3_SHRD
BPSTGE(J,IMOD)%VTIME = TIME
#endif
!
#ifdef W3_MPI
IF ( IAPROC .EQ. 1 ) THEN
BPSTGE(J,IMOD)%STIME = TIME
ITAG = MTAG0 + IMOD + (J-1)*NRGRD
IF ( ITAG .GT. MTAG1 ) THEN
WRITE (MDSE,1001)
CALL EXTCDE (1001)
END IF
DO IP=1, NMPROC
IF ( ALLPRC(IP,J) .NE. 0 .AND. &
ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN
NRQ = NRQ + 1
CALL MPI_ISEND ( BPSTGE(J,IMOD)%STIME, 2, &
MPI_INTEGER, IP-1, ITAG, &
MPI_COMM_MWAVE, IRQ(NRQ), &
IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9081) NRQ, IP, ITAG-MTAG0, &
IRQ(NRQ), IERR_MPI
#endif
#ifdef W3_MPI
END IF
END DO
END IF
#endif
!
! -------------------------------------------------------------------- /
! 4. Stage the spectral data
!
DO I=1, NBI2G(J,IMOD)
!
ISEA = NBI2S(IOFF+I,2)
#ifdef W3_SHRD
JSEA = ISEA
#endif
#ifdef W3_DIST
CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC)
IF ( ISPROC .NE. IAPROC ) CYCLE
#endif
#ifdef W3_MPI
IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:J-1,:)) + &
SUM(NBI2G(J,1:IMOD-1))
#endif
!
DO IS=1, NSPEC
SBPI(IS,I) = VA(IS,JSEA) * SIG2(IS) / CG(1+(IS-1)/NTH,ISEA)
END DO
!
#ifdef W3_MPI
DO IP=1, NMPROC
IF ( ALLPRC(IP,J) .NE. 0 .AND. &
ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN
NRQ = NRQ + 1
ITAG = IT0 + I
IF ( ITAG .GT. MTAG1 ) THEN
WRITE (MDSE,1001)
CALL EXTCDE (1001)
END IF
CALL MPI_ISEND ( SBPI(1,I), NSPEC, MPI_REAL, &
IP-1, ITAG, MPI_COMM_MWAVE, &
IRQ(NRQ), IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG0, &
IRQ(NRQ), IERR_MPI
#endif
#ifdef W3_MPI
END IF
END DO
#endif
!
END DO
!
#ifdef W3_MPIT
WRITE (MDST,9083)
WRITE (MDST,9084) NRQ
#endif
!
#ifdef W3_MPI
IF ( NRQ .GT. 0 ) THEN
ALLOCATE ( BPSTGE(J,IMOD)%IRQBPS(NRQ) )
BPSTGE(J,IMOD)%IRQBPS = IRQ(:NRQ)
ELSE
DEALLOCATE ( BPSTGE(J,IMOD)%TSTORE )
END IF
#endif
!
#ifdef W3_MPI
DEALLOCATE ( IRQ )
#endif
!
! -------------------------------------------------------------------- /
! 5. Convert spectra ( !/SHRD only )
!
#ifdef W3_SHRD
IF ( RESPEC(J,IMOD) ) THEN
SBPI => BPSTGE(J,IMOD)%SBPI
CALL W3CSPC ( TSTORE, NK, NTH, XFR, FR1, TH(1), &
SBPI, SGRDS(J)%NK, SGRDS(J)%NTH, SGRDS(J)%XFR, &
SGRDS(J)%FR1, SGRDS(J)%TH(1), NBI2G(J,IMOD), &
MDST, MDSE, SGRDS(J)%FACHFE )
DEALLOCATE ( TSTORE )
END IF
#endif
!
! ... End of loop over grids
!
END DO
!
RETURN
!
! Formats
!
#ifdef W3_MPI
1001 FORMAT (/' *** ERROR WMIOBS : REQUESTED MPI TAG EXCEEDS', &
' UPPER BOUND (MTAG1) ***')
#endif
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOBS : STAGING DATA FROM GRID ',I3)
9001 FORMAT ( ' TEST WMIOBS : NR. OF SPECTRA PER GRID : '/ &
' ',25I4)
#endif
!
#ifdef W3_T
9010 FORMAT ( ' TEST WMIOBS : STAGING',I4,' SPECTRA FROM GRID ', &
I3,' TO GRID ',I3/ &
' STARTING WITH SPECTRUM ',I4, &
', RESPEC =',L2)
#endif
!
#ifdef W3_T
9030 FORMAT ( ' TEST WMIOBS : TIME :',I10.8,I7.6)
#endif
!
#ifdef W3_MPIT
9080 FORMAT (/' MPIT WMIOBS: COMMUNICATION CALLS '/ &
' +------+------+------+------+--------------+'/ &
' | IH | ID | TARG | TAG | handle err |'/ &
' +------+------+------+------+--------------+')
9081 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |')
9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |')
9083 FORMAT ( ' +------+------+------+------+--------------+')
9084 FORMAT ( ' MPIT WMIOBS: NRQBPT:',I10/)
#endif
!/
!/ End of WMIOBS ----------------------------------------------------- /
!/
END SUBROUTINE WMIOBS
!/ ------------------------------------------------------------------- /
!>
!> @brief Gather internal boundary data for a given model.
!>
!> @details For the shared memory version, data are gathered from
!> the data structure BPSTGE. For the distributed memory version,
!> the gathering of the data are finished first.
!>
!> Gathering of data is triggered by the time stamp of the data
!> that is presently in the storage arrays.
!>
!> This routine preempts the data flow normally executed by
!> W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE.
!>
!> @param[in] IMOD Model number of grid from which data is to
!> be gathered.
!> @param[out] DONE Flag for completion of operation (opt).
!>
!> @author H. L. Tolman @date 29-May-2006
!>
SUBROUTINE WMIOBG ( IMOD, DONE )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 29-May-2006 !
!/ +-----------------------------------+
!/
!/ 18-Oct-2005 : Origination. ( version 3.08 )
!/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 )
!/
! 1. Purpose :
!
! Gather internal boundary data for a given model.
!
! 2. Method :
!
! For the shared memory version, datat are gathered from the data
! structure BPSTGE. For the distributed memeory version, the
! gathering of thee data are finished first.
!
! Gathering of data is triggered by the time stamp of the data
! that is presently in the storage arrays.
!
! This routine preempts the data flow normally executed by
! W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE.
!
! 2. Method :
!
! Using storage array BPSTAGE and time stamps.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data is to
! be gathered.
! DONE Log. O Flag for completion of operation (opt).
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
! Subr. WxxDATMD Manage data structures.
! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
! W3UBPT Subr. W3UBPTMD Update internal bounday spectra.
! W3IOBC Subr W3IOBCMD I/O of boundary data.
! STRACE Sur. W3SERVMD Subroutine tracing.
! EXTCDE Sur. Id. Program abort.
! DSEC21 Func. W3TIMEMD Difference between times.
!
! MPI_IRECV, MPI_TESTALL, MPI_WAITALL
! Subr. mpif.h MPI routines.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMINIT Subr WMINITMD Multi-grid model initialization.
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! See FORMAT labels 1001-1002.
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Enable test output
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE W3GDATMD
USE W3WDATMD
USE W3ADATMD
USE W3ODATMD
USE WMMDATMD
!
USE W3CSPCMD, ONLY: W3CSPC
USE W3TIMEMD, ONLY: DSEC21
USE W3UPDTMD, ONLY: W3UBPT
USE W3IOBCMD, ONLY: W3IOBC
USE W3SERVMD, ONLY: EXTCDE
! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
LOGICAL, INTENT(OUT), OPTIONAL :: DONE
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J, I, IOFF, TTEST(2), ITEST
#ifdef W3_MPI
INTEGER :: IERR_MPI, IT0, ITAG, IFROM, &
ISEA, JSEA, ISPROC
#endif
#ifdef W3_MPIT
INTEGER :: ICOUNT
#endif
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
INTEGER, POINTER :: VTIME(:)
#ifdef W3_MPI
INTEGER, POINTER :: NRQ, IRQ(:)
INTEGER, ALLOCATABLE :: STATUS(:,:)
#endif
REAL :: DTTST, DT1, DT2, W1, W2
REAL, POINTER :: SBPI(:,:)
#ifdef W3_MPI
REAL, ALLOCATABLE :: TSTORE(:,:)
LOGICAL :: FLAGOK
#endif
#ifdef W3_MPIT
LOGICAL :: FLAG
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOBG')
#endif
#ifdef W3_DEBUGIOBC
WRITE(740+IAPROC,*) 'Begin of W3IOBG'
FLUSH(740+IAPROC)
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD
WRITE (MDST,9001) NBI2G(IMOD,:)
#endif
!
IF ( PRESENT(DONE) ) DONE = .FALSE.
!
CALL W3SETO ( IMOD, MDSE, MDST )
!
IF ( IAPROC .GT. NAPROC ) THEN
IF ( PRESENT(DONE) ) DONE = .TRUE.
#ifdef W3_T
WRITE (MDST,9002)
#endif
RETURN
END IF
!
IF ( SUM(NBI2G(IMOD,:)) .EQ. 0 ) THEN
IF ( PRESENT(DONE) ) DONE = .TRUE.
#ifdef W3_T
WRITE (MDST,9003)
#endif
RETURN
END IF
!
CALL W3SETG ( IMOD, MDSE, MDST )
CALL W3SETW ( IMOD, MDSE, MDST )
CALL W3SETA ( IMOD, MDSE, MDST )
!
IF ( TBPIN(1) .NE. -1 ) THEN
IF ( DSEC21(TIME,TBPIN) .GT. 0. ) THEN
IF ( PRESENT(DONE) ) DONE = .TRUE.
#ifdef W3_T
WRITE (MDST,9004)
#endif
RETURN
END IF
END IF
!
! -------------------------------------------------------------------- /
! 1. Testing / gathering data in staging arrays
!
#ifdef W3_T
WRITE (MDST,9010)
#endif
!
! 1.a Shared memory version, test valid times. - - - - - - - - - - - - /
!
#ifdef W3_SHRD
DO J=1, NRGRD
#endif
!
#ifdef W3_SHRD
IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE
VTIME => BPSTGE(IMOD,J)%VTIME
#endif
!
#ifdef W3_SHRD
IF ( VTIME(1) .EQ. -1 ) THEN
IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1001)
CALL EXTCDE ( 1001 )
END IF
#endif
!
#ifdef W3_SHRD
DTTST = DSEC21 ( TIME, VTIME )
IF ( DTTST.LE.0. .AND. TBPIN(1).NE.-1 ) RETURN
#endif
!
#ifdef W3_SHRD
END DO
#endif
!
! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - /
!
#ifdef W3_MPIT
WRITE (MDST,9011) NBISTA(IMOD)
#endif
!
! 1.b.1 NBISTA = 0
! Check if staging arrays are initialized.
! Post the proper receives.
!
#ifdef W3_MPI
IF ( NBISTA(IMOD) .EQ. 0 ) THEN
#endif
!
#ifdef W3_MPI
NRQ => MDATAS(IMOD)%NRQBPG
NRQ = NRGRD + SUM(NBI2G(IMOD,:))
ALLOCATE ( MDATAS(IMOD)%IRQBPG(NRQ) )
IRQ => MDATAS(IMOD)%IRQBPG
IRQ = 0
NRQ = 0
#endif
!
#ifdef W3_MPI
DO J=1, NRGRD
IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE
#endif
!
! ..... Staging arrays
!
#ifdef W3_MPI
IF ( BPSTGE(IMOD,J)%INIT ) THEN
IF ( RESPEC(IMOD,J) ) THEN
DEALLOCATE ( BPSTGE(IMOD,J)%SBPI )
BPSTGE(IMOD,J)%INIT = .FALSE.
#endif
#ifdef W3_MPIT
WRITE (MDST,9012) J, 'RESET'
#endif
#ifdef W3_MPI
ELSE
IF ( SIZE(BPSTGE(IMOD,J)%SBPI(:,1)) .NE. &
SGRDS(J)%NSPEC .OR. &
SIZE(BPSTGE(IMOD,J)%SBPI(1,:)) .NE. &
NBI2G(IMOD,J) ) THEN
IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1003)
CALL EXTCDE (1003)
END IF
#endif
#ifdef W3_MPIT
WRITE (MDST,9012) J, 'TESTED'
#endif
#ifdef W3_MPI
END IF
END IF
#endif
!
#ifdef W3_MPI
IF ( .NOT. BPSTGE(IMOD,J)%INIT ) THEN
NSPEC => SGRDS(J)%NSPEC
ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J)))
NSPEC => SGRDS(IMOD)%NSPEC
BPSTGE(IMOD,J)%INIT = .TRUE.
#endif
#ifdef W3_MPIT
WRITE (MDST,9012) J, 'INITIALIZED'
#endif
#ifdef W3_MPI
END IF
#endif
!
! ..... Check valid time to determine staging.
!
#ifdef W3_MPI
VTIME => BPSTGE(IMOD,J)%VTIME
IF ( VTIME(1) .EQ. -1 ) THEN
DTTST = 0.
ELSE
DTTST = DSEC21 ( TIME, VTIME )
END IF
#endif
#ifdef W3_MPIT
WRITE (MDST,9013) VTIME, DTTST
#endif
!
! ..... Post receives for data gather
!
#ifdef W3_MPI
IF ( DTTST .LE. 0. ) THEN
#endif
#ifdef W3_MPIT
WRITE (MDST,9014) J
#endif
!
! ..... Time
!
#ifdef W3_MPI
ITAG = MTAG0 + J + (IMOD-1)*NRGRD
IFROM = MDATAS(J)%CROOT - 1
NRQ = NRQ + 1
CALL MPI_IRECV ( BPSTGE(IMOD,J)%VTIME, 2, &
MPI_INTEGER, IFROM, ITAG, &
MPI_COMM_MWAVE, IRQ(NRQ), &
IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9015) NRQ, IFROM+1, ITAG-MTAG0, &
IRQ(NRQ), IERR_MPI
#endif
!
! ..... Spectra
!
#ifdef W3_MPI
IF ( J .EQ. 1 ) THEN
IOFF = 0
ELSE
IOFF = SUM(NBI2G(IMOD,1:J-1))
END IF
#endif
!
#ifdef W3_MPI
IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:IMOD-1,:)) &
+ SUM(NBI2G(IMOD,1:J-1))
#endif
!
#ifdef W3_MPI
SBPI => BPSTGE(IMOD,J)%SBPI
#endif
!
#ifdef W3_MPI
NAPROC => OUTPTS(J)%NAPROC
NSPEC => SGRDS(J)%NSPEC
DO I=1, NBI2G(IMOD,J)
ISEA = NBI2S(IOFF+I,2)
CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC)
NRQ = NRQ + 1
ITAG = IT0 + I
CALL MPI_IRECV ( SBPI(1,I), NSPEC, &
MPI_REAL, ISPROC-1, &
ITAG, MPI_COMM_MWAVE, &
IRQ(NRQ), IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9016) NRQ, JSEA, ISPROC, &
ITAG-MTAG0, IRQ(NRQ), IERR_MPI
#endif
#ifdef W3_MPI
END DO
NSPEC => SGRDS(IMOD)%NSPEC
NAPROC => OUTPTS(IMOD)%NAPROC
#endif
!
! ..... End IF for posting receives 1.b.1
!
#ifdef W3_MPIT
WRITE (MDST,9017)
#endif
#ifdef W3_MPI
END IF
#endif
!
! ..... End grid loop J in 1.b.1
!
#ifdef W3_MPI
END DO
#endif
#ifdef W3_MPIT
WRITE (MDST,9018) NRQ
#endif
!
! ..... Reset status
! NOTE: if NBI.EQ.0 all times are already OK, skip to section 2
!
#ifdef W3_MPI
IF ( NBI .GT. 0 ) THEN
NBISTA(IMOD) = 1
#endif
#ifdef W3_MPIT
WRITE (MDST,9011) NBISTA(IMOD)
#endif
#ifdef W3_MPI
END IF
#endif
!
! ..... End IF in 1.b.1
!
#ifdef W3_MPI
END IF
#endif
!
! 1.b.2 NBISTA = 1
! Wait for communication to finish.
! If DONE defined, check if done, otherwise wait.
!
#ifdef W3_MPI
IF ( NBISTA(IMOD) .EQ. 1 ) THEN
#endif
!
#ifdef W3_MPI
NRQ => MDATAS(IMOD)%NRQBPG
IRQ => MDATAS(IMOD)%IRQBPG
ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) )
#endif
!
! ..... Test communication if DONE is present, wait otherwise
!
#ifdef W3_MPI
IF ( PRESENT(DONE) ) THEN
#endif
!
#ifdef W3_MPI
CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, &
IERR_MPI )
#endif
!
#ifdef W3_MPIT
ICOUNT = 0
DO I=1, NRQ
CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), &
IERR_MPI )
FLAGOK = FLAGOK .AND. FLAG
IF ( FLAG ) ICOUNT = ICOUNT + 1
END DO
WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ)
#endif
!
#ifdef W3_MPI
ELSE
#endif
!
#ifdef W3_MPI
CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI )
FLAGOK = .TRUE.
#endif
!
#ifdef W3_MPI
END IF
#endif
!
#ifdef W3_MPI
DEALLOCATE ( STATUS )
#endif
!
! ..... Go on based on FLAGOK
!
#ifdef W3_MPI
IF ( FLAGOK ) THEN
DEALLOCATE ( MDATAS(IMOD)%IRQBPG )
NRQ = 0
ELSE
RETURN
END IF
#endif
!
#ifdef W3_MPI
NBISTA(IMOD) = 2
#endif
#ifdef W3_MPIT
WRITE (MDST,9011) NBISTA(IMOD)
#endif
!
! 1.b.3 Convert spectra if needed
!
#ifdef W3_MPI
DO J=1, NRGRD
#endif
!
#ifdef W3_MPI
IF ( RESPEC(IMOD,J) .AND. NBI2G(IMOD,J).NE.0 ) THEN
#endif
!
#ifdef W3_MPIT
WRITE (MDST,9100) J
#endif
#ifdef W3_MPI
NSPEC => SGRDS(J)%NSPEC
ALLOCATE ( TSTORE(NSPEC,NBI2G(IMOD,J)))
NSPEC => SGRDS(IMOD)%NSPEC
TSTORE = BPSTGE(IMOD,J)%SBPI
DEALLOCATE ( BPSTGE(IMOD,J)%SBPI )
ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J)))
#endif
!
#ifdef W3_MPI
SBPI => BPSTGE(IMOD,J)%SBPI
CALL W3CSPC ( TSTORE, SGRDS(J)%NK, SGRDS(J)%NTH, &
SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), &
SBPI, NK, NTH, XFR, FR1, TH(1), &
NBI2G(IMOD,J), MDST, MDSE, SGRDS(IMOD)%FACHFE)
#endif
!
#ifdef W3_MPI
DEALLOCATE ( TSTORE )
#endif
!
#ifdef W3_MPI
END IF
#endif
!
#ifdef W3_MPI
END DO
#endif
!
#ifdef W3_MPI
NBISTA(IMOD) = 0
#endif
#ifdef W3_MPIT
WRITE (MDST,9011) NBISTA(IMOD)
#endif
!
#ifdef W3_MPI
END IF
#endif
!
! -------------------------------------------------------------------- /
! 2. Update arrays ABPI0/N and data times
!
#ifdef W3_T
WRITE (MDST,9020)
#endif
!
! 2.a Determine next valid time
!
TTEST = -1
DO J=1, NRGRD
IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE
VTIME => BPSTGE(IMOD,J)%VTIME
IF ( TTEST(1) .EQ. -1 ) THEN
TTEST = VTIME
ELSE
DTTST = DSEC21(VTIME,TTEST)
IF ( DTTST .GT. 0. ) TTEST = VTIME
END IF
END DO
!
#ifdef W3_T
WRITE (MDST,9021) TTEST
#endif
!
! 2.b Shift data
!
IF ( TBPIN(1) .EQ. -1 ) THEN
DTTST = DSEC21(TTEST,TIME)
IF ( DTTST .NE. 0. ) THEN
IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1002)
CALL EXTCDE(1002)
END IF
ABPI0 = 0.
ELSE
TBPI0 = TBPIN
ABPI0 = ABPIN
END IF
!
! 2.c Loop over grids for new spectra
!
DO J=1, NRGRD
!
IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE
VTIME => BPSTGE(IMOD,J)%VTIME
SBPI => BPSTGE(IMOD,J)%SBPI
!
IF ( J .EQ. 1 ) THEN
IOFF = 0
ELSE
IOFF = SUM(NBI2G(IMOD,1:J-1))
END IF
!
IF ( TBPIN(1) .EQ. -1 ) THEN
W1 = 0.
W2 = 1.
ELSE
DT1 = DSEC21(TBPI0,VTIME)
DT2 = DSEC21(TBPI0,TTEST)
W2 = DT2 / DT1
W1 = 1. - W2
END IF
#ifdef W3_T
WRITE (MDST,9022) NBI2G(IMOD,J), J, IOFF+1, W1, W2
#endif
!
ABPIN(:,IOFF+1:IOFF+NBI2G(IMOD,J)) = &
W1 * ABPI0(:,IOFF+1:IOFF+NBI2G(IMOD,J)) + &
W2 * SBPI(:,1:NBI2G(IMOD,J))
!
END DO
!
! 2.d New time
!
TBPIN = TTEST
!
! -------------------------------------------------------------------- /
! 3. Dump data to file if requested
!
IF ( IAPROC.EQ.NAPBPT .AND. BCDUMP(IMOD) ) THEN
#ifdef W3_T
WRITE (MDST,9030)
#endif
CALL W3IOBC ( 'DUMP', NDS(9), TBPIN, TBPIN, ITEST, IMOD )
END IF
!
! -------------------------------------------------------------------- /
! 4. Update arrays BBPI0/N
!
#ifdef W3_T
WRITE (MDST,9040)
#endif
!
CALL W3UBPT
!
! -------------------------------------------------------------------- /
! 5. Successful update
!
IF ( PRESENT(DONE) ) DONE = .TRUE.
#ifdef W3_DEBUGIOBC
WRITE(740+IAPROC,*) 'End of W3IOBG'
FLUSH(740+IAPROC)
#endif
!
RETURN
!
! Formats
!
#ifdef W3_SHRD
1001 FORMAT (/' *** ERROR WMIOBG : NO DATA IN STAGING ARRAY ***'/ &
' CALL WMIOBS FIRST '/)
#endif
1002 FORMAT (/' *** ERROR WMIOBG : INITIAL DATA NOT AT INITAL ', &
'MODEL TIME ***'/)
#ifdef W3_MPI
1003 FORMAT (/' *** ERROR WMIOBG : UNEXPECTED SIZE OF STAGING', &
' ARRAY ***')
#endif
!
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOBG : GATHERING DATA FOR GRID ',I3)
9001 FORMAT ( ' TEST WMIOBG : NR. OF SPECTRA PER SOURCE GRID : '/ &
' ',25I4)
9002 FORMAT ( ' TEST WMIOBG : NO DATA NEEDED ON PROCESSOR')
9003 FORMAT ( ' TEST WMIOBG : NO DATA TO BE GATHERED')
9004 FORMAT ( ' TEST WMIOBG : DATA UP TO DATE')
#endif
!
#ifdef W3_T
9010 FORMAT ( ' TEST WMIOBG : TEST DATA AVAILABILITY')
#endif
#ifdef W3_MPIT
9011 FORMAT ( ' MPIT WMIOBG : NBISTA =',I2)
9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A)
9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1)
9014 FORMAT (/' MPIT WMIOBG : RECEIVE FROM GRID',I4/ &
' +------+------+------+------+--------------+'/ &
' | IH | ID | FROM | TAG | handle err |'/ &
' +------+------+------+------+--------------+')
9015 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |')
9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |')
9017 FORMAT ( ' +------+------+------+------+--------------+'/)
9018 FORMAT ( ' MPIT WMIOBG : NRQHGH:',I10/)
9019 FORMAT ( ' MPIT WMIOBG : RECEIVES FINISHED :',F6.1,'%')
9100 FORMAT ( ' MPIT WMIOBG : CONVERTING SPECTRA FROM GRID',I3)
#endif
!
#ifdef W3_T
9020 FORMAT ( ' TEST WMIOBG : FILLING ABPI0/N AND TIMES')
9021 FORMAT ( ' TEST WMIOBG : NEXT VALID TIME FOR ABPIN:',I9.8,I7.6)
9022 FORMAT ( ' TEST WMIOBG : GETTING',I4,' SPECTRA FROM GRID ', &
I3,' STORING AT ',I3/ &
' WEIGHTS : ',2F6.3)
#endif
!
#ifdef W3_T
9030 FORMAT ( ' TEST WMIOBG : DUMP DATA TO FILE')
#endif
!
#ifdef W3_T
9040 FORMAT ( ' TEST WMIOBG : FILLING BBPI0/N')
#endif
!/
!/ End of WMIOBG ----------------------------------------------------- /
!/
END SUBROUTINE WMIOBG
!/ ------------------------------------------------------------------- /
!>
!> @brief Finalize staging of internal boundary data in the data
!> structure BPSTGE (MPI only).
!>
!> @details Post appropriate 'wait' functions to assure that the
!> communication has finished.
!>
!> @param[in] IMOD Model number of grid from which data has
!> been staged.
!>
!> @author H. L. Tolman @date 29-May-2006
!>
SUBROUTINE WMIOBF ( IMOD )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 29-May-2006 !
!/ +-----------------------------------+
!/
!/ 18-Oct-2005 : Origination. ( version 3.08 )
!/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 )
!/
! 1. Purpose :
!
! Finalize staging of internal boundary data in the data
! structure BPSTGE (MPI only).
!
! 2. Method :
!
! Post appropriate 'wait' functions to assure that the
! communication has finished.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data has
! been staged.
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! STRACE Subr. W3SERVMD Subroutine tracing.
!
! MPI_WAITALL
! Subr. mpif.h MPI routines.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMINIT Subr WMINITMD Multi-grid model initialization.
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! See source code.
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Test output.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE WMMDATMD
!
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J
#ifdef W3_MPI
INTEGER :: IERR_MPI
INTEGER, POINTER :: NRQ, IRQ(:)
INTEGER, ALLOCATABLE :: STATUS(:,:)
#endif
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOBF')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD
#endif
!
! -------------------------------------------------------------------- /
! 1. Loop over grids
!
DO J=1, NRGRD
!
#ifdef W3_MPI
NRQ => BPSTGE(J,IMOD)%NRQBPS
#endif
!
! 1.a Nothing to finalize
!
#ifdef W3_MPI
IF ( NRQ .EQ. 0 ) CYCLE
IRQ => BPSTGE(J,IMOD)%IRQBPS
#endif
!
! 1.b Wait for communication to end
!
#ifdef W3_MPI
ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) )
CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI )
DEALLOCATE ( STATUS )
#endif
!
! 1.c Reset arrays and counter
!
#ifdef W3_MPI
NRQ = 0
DEALLOCATE ( BPSTGE(J,IMOD)%IRQBPS , &
BPSTGE(J,IMOD)%TSTORE )
#endif
!
#ifdef W3_T
WRITE (MDST,9010) J
#endif
!
END DO
!
RETURN
!
! Formats
!
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOBF : FINALIZE STAGING DATA FROM GRID ',I3)
9010 FORMAT ( ' TEST WMIOBF : FINISHED WITH TARGET ',I3)
#endif
!/
!/ End of WMIOBF ----------------------------------------------------- /
!/
END SUBROUTINE WMIOBF
!/ ------------------------------------------------------------------- /
!>
!> @brief Stage internal high-to-low data in the data structure HGSTGE.
!>
!> @details Directly fill staging arrays in shared memory version, or post
!> the corresponding sends in distributed memory version.
!>
!> @param[in] IMOD Model number of grid from which data is to
!> be staged.
!>
!> @author H. L. Tolman @date 28-Sep-2016
!>
SUBROUTINE WMIOHS ( IMOD )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 28-Sep-2016 !
!/ +-----------------------------------+
!/
!/ 27-Jan-2006 : Origination. ( version 3.08 )
!/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 )
!/
! 1. Purpose :
!
! Stage internal high-to-low data in the data structure HGSTGE.
!
! 2. Method :
!
! Directly fill staging arrays in shared memory version, or post
! the corresponding sends in distributed memory version.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data is to
! be staged.
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
! Subr. WxxDATMD Manage data structures.
! STRACE Subr. W3SERVMD Subroutine tracing.
! EXTCDE Sur. Id. Program abort.
! DSEC21 Func. W3TIMEMD Difference between times.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! See FORMAT label 1001.
!
! 7. Remarks :
!
! 8. Structure :
!
! See source code.
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Enable test output
! !/MPIT
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE W3GDATMD
USE W3WDATMD
USE W3ADATMD
USE W3ODATMD
USE WMMDATMD
!
USE W3SERVMD, ONLY: EXTCDE
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
USE W3TIMEMD, ONLY: DSEC21
USE W3PARALL, ONLY: INIT_GET_ISEA
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J, NR, I, JSEA, ISEA, IS
#ifdef W3_MPI
INTEGER :: ITAG, IP, IT0, IERR_MPI
#endif
INTEGER :: I1, I2
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
#ifdef W3_MPI
INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:)
#endif
REAL :: DTOUTP
#ifdef W3_SHRD
REAL, POINTER :: SHGH(:,:,:)
#endif
#ifdef W3_MPI
REAL, POINTER :: SHGH(:,:)
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOHS')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD, FLGHG1
#endif
!
IF ( .NOT. FLGHG1 ) THEN
#ifdef W3_T
WRITE (MDST,9001) HGSTGE(:,IMOD)%NSND
#endif
IF ( SUM(HGSTGE(:,IMOD)%NSND) .EQ. 0 ) RETURN
ELSE
#ifdef W3_T
WRITE (MDST,9001) HGSTGE(:,IMOD)%NSN1
#endif
IF ( SUM(HGSTGE(:,IMOD)%NSN1) .EQ. 0 ) RETURN
END IF
!
CALL W3SETO ( IMOD, MDSE, MDST )
CALL W3SETG ( IMOD, MDSE, MDST )
CALL W3SETW ( IMOD, MDSE, MDST )
CALL W3SETA ( IMOD, MDSE, MDST )
!
! -------------------------------------------------------------------- /
! 1. Loop over grids
!
DO J=1, NRGRD
!
IF ( J .EQ. IMOD ) CYCLE
!
IF ( .NOT. FLGHG1 ) THEN
NR = HGSTGE(J,IMOD)%NSND
ELSE IF ( FLGHG2 ) THEN
NR = HGSTGE(J,IMOD)%NSN1
ELSE
IF ( TOUTP(1,J) .EQ. -1 ) THEN
DTOUTP = 1.
ELSE
DTOUTP = DSEC21(TIME,TOUTP(:,J))
END IF
IF ( DTOUTP .EQ. 0. ) THEN
NR = HGSTGE(J,IMOD)%NSND
ELSE
NR = HGSTGE(J,IMOD)%NSN1
END IF
END IF
!
#ifdef W3_T
IF ( NR .EQ. 0 ) THEN
WRITE (MDST,9010) J, NR
ELSE
WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)), DTOUTP
END IF
#endif
!
IF ( NR .EQ. 0 ) CYCLE
IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) CYCLE
!
! -------------------------------------------------------------------- /
! 2. Allocate arrays and/or point pointers
!
#ifdef W3_SHRD
SHGH => HGSTGE(J,IMOD)%SHGH
#endif
#ifdef W3_MPI
ALLOCATE ( HGSTGE(J,IMOD)%TSTORE(NSPEC,NR) )
SHGH => HGSTGE(J,IMOD)%TSTORE
#endif
!
#ifdef W3_MPI
ALLOCATE ( HGSTGE(J,IMOD)%IRQHGS(NR) )
ALLOCATE ( HGSTGE(J,IMOD)%OUTDAT(NR,3) )
#endif
!
#ifdef W3_MPI
NRQ => HGSTGE(J,IMOD)%NRQHGS
NRQOUT => HGSTGE(J,IMOD)%NRQOUT
IRQ => HGSTGE(J,IMOD)%IRQHGS
OUTDAT => HGSTGE(J,IMOD)%OUTDAT
NRQ = 0
NRQOUT = 0
IRQ = 0
#endif
!
! -------------------------------------------------------------------- /
! 3. Set the time
! !/SHRD only.
!
#ifdef W3_T
WRITE (MDST,9030) TIME
#endif
!
#ifdef W3_SHRD
HGSTGE(J,IMOD)%VTIME = TIME
#endif
!
! -------------------------------------------------------------------- /
! 4. Stage the spectral data
!
#ifdef W3_MPIT
WRITE (MDST,9080)
#endif
#ifdef W3_MPI
IT0 = MTAG1 + 1
#endif
!
DO I=1, NR
!
JSEA = HGSTGE(J,IMOD)%ISEND(I,1)
CALL INIT_GET_ISEA(ISEA, JSEA)
#ifdef W3_DIST
IP = HGSTGE(J,IMOD)%ISEND(I,2)
#endif
I1 = HGSTGE(J,IMOD)%ISEND(I,3)
I2 = HGSTGE(J,IMOD)%ISEND(I,4)
#ifdef W3_MPI
ITAG = HGSTGE(J,IMOD)%ISEND(I,5) + IT0
IF ( ITAG .GT. MTAG2 ) THEN
WRITE (MDSE,1001)
CALL EXTCDE (1001)
END IF
#endif
!
DO IS=1, NSPEC
#ifdef W3_SHRD
SHGH(IS,I2,I1) = VA(IS,JSEA) * SIG2(IS) &
/ CG(1+(IS-1)/NTH,ISEA)
#endif
#ifdef W3_MPI
SHGH( IS,I ) = VA(IS,JSEA) * SIG2(IS) &
/ CG(1+(IS-1)/NTH,ISEA)
#endif
END DO
!
#ifdef W3_MPI
IF ( IP .NE. IMPROC ) THEN
NRQ = NRQ + 1
CALL MPI_ISEND ( SHGH(1,I), NSPEC, MPI_REAL, IP-1, &
ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG1, &
IRQ(NRQ), IERR_MPI
#endif
#ifdef W3_MPI
ELSE
NRQOUT = NRQOUT + 1
OUTDAT(NRQOUT,1) = I
OUTDAT(NRQOUT,2) = I2
OUTDAT(NRQOUT,3) = I1
END IF
#endif
!
END DO
!
#ifdef W3_MPIT
WRITE (MDST,9083)
WRITE (MDST,9084) NRQ
#endif
!
END DO
!
RETURN
!
! Formats
!
#ifdef W3_MPI
1001 FORMAT (/' *** ERROR WMIOHS : REQUESTED MPI TAG EXCEEDS', &
' UPPER BOUND (MTAG2) ***')
#endif
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOHS : STAGING DATA FROM GRID ',I3, &
' FLGHG1 = ',L1)
9001 FORMAT ( ' TEST WMIOHS : NR. OF SPECTRA PER GRID : '/ &
' ',15I6)
#endif
!
#ifdef W3_T
9010 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, &
' NR = ',I6)
9011 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, &
' NR = ',I6,' TIME GAP = ',2F8.1)
#endif
!
#ifdef W3_T
9030 FORMAT ( ' TEST WMIOHS : TIME :',I10.8,I7.6)
#endif
!
#ifdef W3_MPIT
9080 FORMAT (/' MPIT WMIOHS: COMMUNICATION CALLS '/ &
' +------+------+------+------+--------------+'/ &
' | IH | ID | TARG | TAG | handle err |'/ &
' +------+------+------+------+--------------+')
9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |')
9083 FORMAT ( ' +------+------+------+------+--------------+')
9084 FORMAT ( ' MPIT WMIOHS: NRQHGS:',I10/)
#endif
!/
!/ End of WMIOHS ----------------------------------------------------- /
!/
END SUBROUTINE WMIOHS
!/ ------------------------------------------------------------------- /
!>
!> @brief Gather internal high-to-low data for a given model.
!>
!> @details For distributed memory version first receive all staged data.
!> After staged data is present, average, convert as necessary,
!> and store in basic spectral arrays.
!>
!> Using storage array HGSTAGE and time stamps.
!>
!> @param[in] IMOD Model number of grid from which data is to
!> be gathered.
!> @param[out] DONE Flag for completion of operation (opt).
!>
!> @author H. L. Tolman @date 20-Dec-2006
!>
SUBROUTINE WMIOHG ( IMOD, DONE )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 20-Dec-2006 !
!/ +-----------------------------------+
!/
!/ 27-Jan-2006 : Origination. ( version 3.08 )
!/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
!/
! 1. Purpose :
!
! Gather internal high-to-low data for a given model.
!
! 2. Method :
!
! For distributed memory version first receive all staged data.
! After staged data is present, average, convert as necessary,
! and store in basic spectral arrays.
!
! 2. Method :
!
! Using storage array HGSTAGE and time stamps.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data is to
! be gathered.
! DONE Log. O Flag for completion of operation (opt).
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SETG, W3SETW, W3SETA, W3SETO
! Subr. WxxDATMD Manage data structures.
! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
! STRACE Sur. W3SERVMD Subroutine tracing.
! DSEC21 Func. W3TIMEMD Difference between times.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! See FORMAT labels 1001-1002.
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Enable test output
! !/MPIT
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE W3GDATMD
USE W3WDATMD
USE W3ADATMD
USE W3ODATMD
USE WMMDATMD
!
USE W3CSPCMD, ONLY: W3CSPC
USE W3TIMEMD, ONLY: DSEC21
! USE W3SERVMD, ONLY: EXTCDE
#ifdef W3_PDLIB
use yowNodepool, only: npa
USE yowExchangeModule, only : PDLIB_exchange2Dreal
#endif
USE W3PARALL, ONLY : INIT_GET_ISEA
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
LOGICAL, INTENT(OUT), OPTIONAL :: DONE
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: NTOT, J, IS, NA, IA, JSEA, ISEA, I
#ifdef W3_MPI
INTEGER :: ITAG, IT0, IFROM, ILOC, NLOC, &
ISPROC, IERR_MPI, ICOUNT, &
I0, I1, I2
#endif
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
INTEGER, POINTER :: VTIME(:)
#ifdef W3_MPI
INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:)
#endif
REAL :: DTTST, WGTH
REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:)
#ifdef W3_MPI
REAL, POINTER :: SHGH(:,:,:)
#endif
LOGICAL :: FLGALL
#ifdef W3_MPI
LOGICAL :: FLAGOK
#endif
#ifdef W3_MPIT
LOGICAL :: FLAG
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOHG')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
IF ( TOUTP(1,IMOD) .EQ. -1 ) THEN
DTTST = 1.
ELSE
DTTST = DSEC21 ( WDATAS(IMOD)%TIME , TOUTP(:,IMOD) )
END IF
!
IF ( .NOT. FLGHG1 ) THEN
FLGALL = .TRUE.
ELSE IF ( FLGHG2 ) THEN
FLGALL = .FALSE.
ELSE IF ( DTTST .EQ. 0. ) THEN
FLGALL = .TRUE.
ELSE
FLGALL = .FALSE.
END IF
!
#ifdef W3_T
WRITE (MDST,9000) IMOD, DTTST, FLGALL
#endif
!
IF ( FLGALL ) THEN
#ifdef W3_T
WRITE (MDST,9001) HGSTGE(IMOD,:)%NREC
#endif
NTOT = SUM(HGSTGE(IMOD,:)%NREC)
ELSE
#ifdef W3_T
WRITE (MDST,9001) HGSTGE(IMOD,:)%NRC1
#endif
NTOT = SUM(HGSTGE(IMOD,:)%NRC1)
END IF
!
IF ( PRESENT(DONE) ) DONE = .FALSE.
!
IF ( NTOT .EQ. 0 ) THEN
IF ( PRESENT(DONE) ) DONE = .TRUE.
#ifdef W3_T
WRITE (MDST,9003)
#endif
RETURN
END IF
!
CALL W3SETO ( IMOD, MDSE, MDST )
CALL W3SETG ( IMOD, MDSE, MDST )
CALL W3SETW ( IMOD, MDSE, MDST )
CALL W3SETA ( IMOD, MDSE, MDST )
!
! -------------------------------------------------------------------- /
! 1. Testing / gathering data in staging arrays
!
#ifdef W3_T
WRITE (MDST,9010) TIME
#endif
!
! 1.a Shared memory version, test valid times. - - - - - - - - - - - - /
!
#ifdef W3_SHRD
DO J=1, NRGRD
#endif
!
#ifdef W3_SHRD
IF ( FLGALL ) THEN
NTOT = HGSTGE(IMOD,J)%NREC
ELSE
NTOT = HGSTGE(IMOD,J)%NRC1
END IF
IF ( NTOT .EQ. 0 ) CYCLE
#endif
!
#ifdef W3_SHRD
VTIME => HGSTGE(IMOD,J)%VTIME
IF ( VTIME(1) .EQ. -1 ) RETURN
DTTST = DSEC21 ( TIME, VTIME )
IF ( DTTST .NE. 0. ) RETURN
#endif
!
#ifdef W3_SHRD
END DO
#endif
!
! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - /
!
#ifdef W3_MPIT
WRITE (MDST,9011) HGHSTA(IMOD)
#endif
!
! 1.b.1 HGHSTA = 0
! Check if staging arrays are initialized.
! Post the proper receives.
!
#ifdef W3_MPI
IF ( HGHSTA(IMOD) .EQ. 0 ) THEN
#endif
!
#ifdef W3_MPI
NRQ => MDATAS(IMOD)%NRQHGG
NRQ = 0
DO J=1, NRGRD
IF ( FLGALL ) THEN
NRQ = NRQ + HGSTGE(IMOD,J)%NREC * &
HGSTGE(IMOD,J)%NSMX
ELSE
NRQ = NRQ + HGSTGE(IMOD,J)%NRC1 * &
HGSTGE(IMOD,J)%NSMX
END IF
END DO
NRQ = MAX(1,NRQ)
ALLOCATE ( IRQ(NRQ) )
IRQ = 0
NRQ = 0
#endif
!
#ifdef W3_MPI
DO J=1, NRGRD
IF ( HGSTGE(IMOD,J)%NTOT .EQ. 0 ) CYCLE
#endif
!
! ..... Check valid time to determine staging.
!
#ifdef W3_MPI
VTIME => HGSTGE(IMOD,J)%VTIME
IF ( VTIME(1) .EQ. -1 ) THEN
DTTST = 1.
ELSE
DTTST = DSEC21 ( TIME, VTIME )
END IF
#endif
#ifdef W3_MPIT
WRITE (MDST,9013) VTIME, DTTST
#endif
!
! ..... Post receives for data gather
!
#ifdef W3_MPI
IF ( DTTST .NE. 0. ) THEN
#endif
#ifdef W3_MPIT
WRITE (MDST,9014) J
#endif
!
! ..... Spectra
!
#ifdef W3_MPI
IT0 = MTAG1 + 1
SHGH => HGSTGE(IMOD,J)%SHGH
#endif
!
#ifdef W3_MPI
IF ( FLGALL ) THEN
NTOT = HGSTGE(IMOD,J)%NREC
ELSE
NTOT = HGSTGE(IMOD,J)%NRC1
END IF
#endif
!
#ifdef W3_MPI
DO I=1, NTOT
#endif
#ifdef W3_MPIT
JSEA = HGSTGE(IMOD,J)%LJSEA(I)
#endif
#ifdef W3_MPI
NLOC = HGSTGE(IMOD,J)%NRAVG(I)
DO ILOC=1, NLOC
ISPROC = HGSTGE(IMOD,J)%IMPSRC(I,ILOC)
ITAG = HGSTGE(IMOD,J)%ITAG(I,ILOC) + IT0
IF ( ISPROC .NE. IMPROC ) THEN
NRQ = NRQ + 1
CALL MPI_IRECV ( SHGH(1,ILOC,I), &
SGRDS(J)%NSPEC, MPI_REAL, &
ISPROC-1, ITAG, MPI_COMM_MWAVE, &
IRQ(NRQ), IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9016) NRQ, JSEA, ISPROC, &
ITAG-MTAG1, IRQ(NRQ), IERR_MPI
#endif
#ifdef W3_MPI
END IF
END DO
END DO
#endif
!
! ..... End IF for posting receives 1.b.1
!
#ifdef W3_MPIT
WRITE (MDST,9017)
#endif
#ifdef W3_MPI
END IF
#endif
!
! ..... End grid loop J in 1.b.1
!
#ifdef W3_MPI
END DO
#endif
#ifdef W3_MPIT
WRITE (MDST,9018) NRQ
#endif
!
#ifdef W3_MPI
ALLOCATE ( MDATAS(IMOD)%IRQHGG(NRQ) )
MDATAS(IMOD)%IRQHGG = IRQ(1:NRQ)
DEALLOCATE ( IRQ )
#endif
!
! ..... Reset status
!
#ifdef W3_MPI
IF ( NRQ .GT. 0 ) THEN
HGHSTA(IMOD) = 1
#endif
#ifdef W3_MPIT
WRITE (MDST,9011) HGHSTA(IMOD)
#endif
#ifdef W3_MPI
END IF
#endif
!
! ..... End IF in 1.b.1
!
#ifdef W3_MPI
END IF
#endif
!
! 1.b.2 HGHSTA = 1
! Wait for communication to finish.
! If DONE defined, check if done, otherwise wait.
!
#ifdef W3_MPI
IF ( HGHSTA(IMOD) .EQ. 1 ) THEN
#endif
!
#ifdef W3_MPI
NRQ => MDATAS(IMOD)%NRQHGG
IRQ => MDATAS(IMOD)%IRQHGG
ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) )
#endif
!
! ..... Test communication if DONE is present, wait otherwise
!
#ifdef W3_MPI
IF ( PRESENT(DONE) ) THEN
#endif
!
#ifdef W3_MPI
CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, &
IERR_MPI )
#endif
!
#ifdef W3_MPIT
ICOUNT = 0
DO I=1, NRQ
CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), &
IERR_MPI )
FLAGOK = FLAGOK .AND. FLAG
IF ( FLAG ) ICOUNT = ICOUNT + 1
END DO
WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ)
#endif
!
#ifdef W3_MPI
ELSE
#endif
!
#ifdef W3_MPI
CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI )
FLAGOK = .TRUE.
#endif
#ifdef W3_MPIT
WRITE (MDST,9019) 100.
#endif
!
#ifdef W3_MPI
END IF
#endif
!
#ifdef W3_MPI
DEALLOCATE ( STATUS )
#endif
!
! ..... Go on based on FLAGOK
!
#ifdef W3_MPI
IF ( FLAGOK ) THEN
NRQ = 0
DEALLOCATE ( MDATAS(IMOD)%IRQHGG )
ELSE
RETURN
END IF
#endif
!
#ifdef W3_MPI
HGHSTA(IMOD) = 0
#endif
#ifdef W3_MPIT
WRITE (MDST,9011) HGHSTA(IMOD)
#endif
!
#ifdef W3_MPI
END IF
#endif
!
! ..... process locally stored data
!
#ifdef W3_MPI
DO J=1, NRGRD
HGSTGE(IMOD,J)%VTIME = TIME
IF ( J .EQ. IMOD ) CYCLE
DO IS=1, HGSTGE(IMOD,J)%NRQOUT
I0 = HGSTGE(IMOD,J)%OUTDAT(IS,1)
I2 = HGSTGE(IMOD,J)%OUTDAT(IS,2)
I1 = HGSTGE(IMOD,J)%OUTDAT(IS,3)
HGSTGE(IMOD,J)%SHGH(:,I2,I1) = HGSTGE(IMOD,J)%TSTORE(:,I0)
END DO
END DO
#endif
!
! -------------------------------------------------------------------- /
! 2. Data available, process grid by grid
!
#ifdef W3_T
WRITE (MDST,9020)
#endif
!
! 2.a Loop over grids
!
DO J=1, NRGRD
!
IF ( FLGALL ) THEN
NTOT = HGSTGE(IMOD,J)%NREC
ELSE
NTOT = HGSTGE(IMOD,J)%NRC1
END IF
IF ( NTOT .EQ. 0 ) CYCLE
!
#ifdef W3_T
WRITE (MDST,9021) J, NTOT
#endif
!
! 2.b Set up temp data structures
!
IF ( RESPEC(IMOD,J) ) THEN
ALLOCATE ( SPEC1(SGRDS(J)%NSPEC,NTOT), SPEC2(NSPEC,NTOT) )
SPEC => SPEC1
ELSE
ALLOCATE ( SPEC2(NSPEC,NTOT) )
SPEC => SPEC2
END IF
!
! 2.c Average spectra to temp storage
!
#ifdef W3_T
WRITE (MDST,9022)
#endif
!
DO IS=1, NTOT
NA = HGSTGE(IMOD,J)%NRAVG(IS)
WGTH = HGSTGE(IMOD,J)%WGTH(IS,1)
SPEC(:,IS) = WGTH * HGSTGE(IMOD,J)%SHGH(:,1,IS)
DO IA=2, NA
WGTH = HGSTGE(IMOD,J)%WGTH(IS,IA)
SPEC(:,IS) = SPEC(:,IS) + WGTH*HGSTGE(IMOD,J)%SHGH(:,IA,IS)
END DO
END DO
!
! 2.d Convert spectral grid as needed
!
IF ( RESPEC(IMOD,J) ) THEN
!
#ifdef W3_T
WRITE (MDST,9023)
#endif
!
CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, &
SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), &
SPEC2 , NK, NTH, XFR, FR1, TH(1), &
NTOT, MDST, MDSE, FACHFE)
DEALLOCATE ( SPEC1 )
!
END IF
!
! 2.e Move spectra to model
!
#ifdef W3_T
WRITE (MDST,9024)
#endif
!
DO IS=1, NTOT
JSEA = HGSTGE(IMOD,J)%LJSEA(IS)
CALL INIT_GET_ISEA(ISEA, JSEA)
DO I=1, NSPEC
VA(I,JSEA) = SPEC2(I,IS) / SIG2(I) * CG(1+(I-1)/NTH,ISEA)
END DO
END DO
!
DEALLOCATE ( SPEC2 )
!
END DO
!
! -------------------------------------------------------------------- /
! 3. Set flag if reqeusted
!
IF ( PRESENT(DONE) ) DONE = .TRUE.
!
#ifdef W3_PDLIB
CALL PDLIB_exchange2Dreal(VA(:,1:NPA))
#endif
!
! Formats
!
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOHG : GATHERING DATA FOR GRID ',I3/ &
' DTOUTP, FLGALL :',F8.1,L4)
9001 FORMAT ( ' TEST WMIOHG : NR. OF SPECTRA PER SOURCE GRID : '/ &
' ',25I4)
9003 FORMAT ( ' TEST WMIOHG : NO DATA TO BE GATHERED')
#endif
!
#ifdef W3_T
9010 FORMAT ( ' TEST WMIOHG : TEST DATA AVAILABILITY FOR',I9.8,I7.6)
#endif
#ifdef W3_MPIT
9011 FORMAT ( ' MPIT WMIOHG : HGHSTA =',I2)
9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1)
9014 FORMAT (/' MPIT WMIOHG : RECEIVE FROM GRID',I4/ &
' +------+------+------+------+--------------+'/ &
' | IH | ID | FROM | TAG | handle err |'/ &
' +------+------+------+------+--------------+')
9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |')
9017 FORMAT ( ' +------+------+------+------+--------------+'/)
9018 FORMAT ( ' MPIT WMIOHG : NRQBPT:',I10/)
9019 FORMAT ( ' MPIT WMIOHG : RECEIVES FINISHED :',F6.1,'%')
#endif
!
#ifdef W3_T
9020 FORMAT ( ' TEST WMIOHG : PROCESSING DATA GRID BY GRID')
9021 FORMAT ( ' FROM GRID ',I3,' NR OF SPECTRA :',I6)
9022 FORMAT ( ' AVERAGE SPECTRA TO TEMP STORAGE')
9023 FORMAT ( ' CONVERT SPECTRAL GRID')
9024 FORMAT ( ' MOVE SPECTRA TO PERMANENT STORAGE')
#endif
!/
!/ End of WMIOHG ----------------------------------------------------- /
!/
END SUBROUTINE WMIOHG
!/ ------------------------------------------------------------------- /
!>
!> @brief Finalize staging of internal high-to-low data in the data
!> structure HGSTGE (MPI only).
!>
!> @details Post appropriate 'wait' functions to assure that the
!> communication has finished.
!>
!> @param[in] IMOD Model number of grid from which data has
!> been staged.
!>
!> @author H. L. Tolman @date 16-Jan-2006
!>
SUBROUTINE WMIOHF ( IMOD )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 16-Jan-2006 !
!/ +-----------------------------------+
!/
!/ 16-Jan-2006 : Origination. ( version 3.08 )
!/
! 1. Purpose :
!
! Finalize staging of internal high-to-low data in the data
! structure HGSTGE (MPI only).
!
! 2. Method :
!
! Post appropriate 'wait' functions to assure that the
! communication has finished.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data has
! been staged.
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! STRACE Subr. W3SERVMD Subroutine tracing.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! See source code.
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Test output.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE WMMDATMD
!
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J
#ifdef W3_MPI
INTEGER :: IERR_MPI
INTEGER, POINTER :: NRQ, IRQ(:)
INTEGER, ALLOCATABLE :: STATUS(:,:)
#endif
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOHF')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD
#endif
!
! -------------------------------------------------------------------- /
! 1. Loop over grids
!
DO J=1, NRGRD
!
#ifdef W3_MPI
NRQ => HGSTGE(J,IMOD)%NRQHGS
#endif
!
! 1.a Nothing to finalize
!
#ifdef W3_MPI
IF ( NRQ .EQ. 0 ) CYCLE
IRQ => HGSTGE(J,IMOD)%IRQHGS
#endif
!
! 1.b Wait for communication to end
!
#ifdef W3_MPI
ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) )
CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI )
DEALLOCATE ( STATUS )
#endif
!
! 1.c Reset arrays and counter
!
#ifdef W3_MPI
NRQ = 0
DEALLOCATE ( HGSTGE(J,IMOD)%IRQHGS, &
HGSTGE(J,IMOD)%TSTORE, &
HGSTGE(J,IMOD)%OUTDAT )
#endif
!
#ifdef W3_T
WRITE (MDST,9010) J
#endif
!
END DO
!
RETURN
!
! Formats
!
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOHF : FINALIZE STAGING DATA FROM GRID ',I3)
9010 FORMAT ( ' TEST WMIOHF : FINISHED WITH TARGET ',I3)
#endif
!/
!/ End of WMIOHF ----------------------------------------------------- /
!/
END SUBROUTINE WMIOHF
!/ ------------------------------------------------------------------- /
!>
!> @brief Stage internal same-rank data in the data structure EQSTGE.
!>
!> @details Directly fill staging arrays in shared memory version, or post
!> the corresponding sends in distributed memory version.
!>
!> @param[in] IMOD Model number of grid from which data is to
!> be staged.
!>
!> @author H. L. Tolman @date 28-Sep-2016
!>
SUBROUTINE WMIOES ( IMOD )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 28-Sep-2016 !
!/ +-----------------------------------+
!/
!/ 25-May-2006 : Origination. ( version 3.09 )
!/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
!/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 )
!/ 16-Dec-2020 : SMC grid use 1-1 spectral exchanges.( version 7.13 )
!/
! 1. Purpose :
!
! Stage internal same-rank data in the data structure EQSTGE.
!
! 2. Method :
!
! Directly fill staging arrays in shared memory version, or post
! the corresponding sends in distributed memory version.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data is to
! be staged.
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
! Subr. WxxDATMD Manage data structures.
! STRACE Subr. W3SERVMD Subroutine tracing.
! EXTCDE Sur. Id. Program abort.
! DSEC21 Func. W3TIMEMD Difference between times.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! See FORMAT label 1001.
!
! 7. Remarks :
!
! 8. Structure :
!
! See source code.
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Enable test output
! !/MPIT
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE W3GDATMD
USE W3WDATMD
USE W3ADATMD
USE W3ODATMD
USE WMMDATMD
!
USE W3SERVMD, ONLY: EXTCDE
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
USE W3TIMEMD, ONLY: DSEC21
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J, NR, I, ISEA, JSEA, IS, I1, I2
#ifdef W3_MPI
INTEGER :: IT0, ITAG, IP, IERR_MPI
#endif
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
#ifdef W3_MPI
INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:)
#endif
#ifdef W3_SHRD
REAL, POINTER :: SEQL(:,:,:)
#endif
#ifdef W3_MPI
REAL, POINTER :: SEQL(:,:)
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOES')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD
WRITE (MDST,9001) EQSTGE(:,IMOD)%NSND
#endif
!
CALL W3SETO ( IMOD, MDSE, MDST )
CALL W3SETG ( IMOD, MDSE, MDST )
CALL W3SETW ( IMOD, MDSE, MDST )
CALL W3SETA ( IMOD, MDSE, MDST )
!
! -------------------------------------------------------------------- /
! 1. Loop over grids
!
DO J=1, NRGRD
!
IF ( J .EQ. IMOD ) CYCLE
NR = EQSTGE(J,IMOD)%NSND
!
#ifdef W3_T
IF ( NR .EQ. 0 ) THEN
WRITE (MDST,9010) J, NR
ELSE
WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J))
END IF
#endif
!
IF ( NR .EQ. 0 ) CYCLE
IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) STOP
!
!!Li Report sending for test. JGLi22Dec2020
! WRITE (MDSE,*) ' ***WMIOES: Send to GRID', J, &
! ' from', IMOD, ' NS=', NR, ' on IP', IMPROC
! -------------------------------------------------------------------- /
! 2. Allocate arrays and/or point pointers
!
#ifdef W3_SHRD
SEQL => EQSTGE(J,IMOD)%SEQL
#endif
#ifdef W3_MPI
ALLOCATE ( EQSTGE(J,IMOD)%TSTORE(NSPEC,NR) )
SEQL => EQSTGE(J,IMOD)%TSTORE
#endif
!
#ifdef W3_MPI
ALLOCATE ( EQSTGE(J,IMOD)%IRQEQS(NR) , &
EQSTGE(J,IMOD)%OUTDAT(NR,3) )
#endif
!
#ifdef W3_MPI
NRQ => EQSTGE(J,IMOD)%NRQEQS
NRQOUT => EQSTGE(J,IMOD)%NRQOUT
IRQ => EQSTGE(J,IMOD)%IRQEQS
OUTDAT => EQSTGE(J,IMOD)%OUTDAT
NRQ = 0
NRQOUT = 0
IRQ = 0
#endif
!
! -------------------------------------------------------------------- /
! 3. Set the time
! Note that with MPI the send needs to be posted to the local
! processor too to make time management possible.
!
#ifdef W3_T
WRITE (MDST,9030) TIME
#endif
!
#ifdef W3_SHRD
EQSTGE(J,IMOD)%VTIME = TIME
#endif
!
! -------------------------------------------------------------------- /
! 4. Stage the spectral data
!
#ifdef W3_MPIT
WRITE (MDST,9080)
#endif
#ifdef W3_MPI
IT0 = MTAG2 + 1
#endif
!
DO I=1, NR
!
ISEA = EQSTGE(J,IMOD)%SIS(I)
JSEA = EQSTGE(J,IMOD)%SJS(I)
I1 = EQSTGE(J,IMOD)%SI1(I)
I2 = EQSTGE(J,IMOD)%SI2(I)
#ifdef W3_MPI
IP = EQSTGE(J,IMOD)%SIP(I)
ITAG = EQSTGE(J,IMOD)%STG(I) + IT0
IF ( ITAG .GT. MTAG_UB ) THEN
WRITE (MDSE,1001)
CALL EXTCDE (1001)
END IF
#endif
!
#ifdef W3_SMC
!! Equal ranked SMC grids simply pass the wave action. JGLi16Dec2020
#endif
#ifdef W3_MPI
#ifdef W3_SMC
IF( GTYPE .EQ. SMCTYPE ) THEN
SEQL(:, I) = VA(:, JSEA)
ELSE
#endif
#endif
DO IS=1, NSPEC
#ifdef W3_SHRD
SEQL(IS,I1,I2) = VA(IS,JSEA) * SIG2(IS) &
/ CG(1+(IS-1)/NTH,ISEA)
#endif
#ifdef W3_MPI
SEQL( IS,I ) = VA(IS,JSEA) * SIG2(IS) &
/ CG(1+(IS-1)/NTH,ISEA)
#endif
END DO
#ifdef W3_MPI
#ifdef W3_SMC
ENDIF
#endif
#endif
!
#ifdef W3_MPI
IF ( IP .NE. IMPROC ) THEN
NRQ = NRQ + 1
CALL MPI_ISEND ( SEQL(1,I), NSPEC, MPI_REAL, IP-1, &
ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG2, &
IRQ(NRQ), IERR_MPI
#endif
#ifdef W3_MPI
ELSE
NRQOUT = NRQOUT + 1
OUTDAT(NRQOUT,1) = I
OUTDAT(NRQOUT,2) = I1
OUTDAT(NRQOUT,3) = I2
END IF
#endif
!
END DO
!
#ifdef W3_MPIT
WRITE (MDST,9083)
WRITE (MDST,9084) NRQ
#endif
!
END DO
!
RETURN
!
! Formats
!
#ifdef W3_MPI
1001 FORMAT (/' *** ERROR WMIOES : REQUESTED MPI TAG EXCEEDS', &
' UPPER BOUND (MTAG_UB) ***')
#endif
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOES : STAGING DATA FROM GRID ',I3)
9001 FORMAT ( ' TEST WMIOES : NR. OF SPECTRA PER GRID : '/ &
' ',15I6)
#endif
!
#ifdef W3_T
9010 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, &
' NR = ',I6)
9011 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, &
' NR = ',I6,' TIME GAP = ',F8.1)
#endif
!
#ifdef W3_T
9030 FORMAT ( ' TEST WMIOES : TIME :',I10.8,I7.6)
#endif
!/
#ifdef W3_MPIT
9080 FORMAT (/' MPIT WMIOES: COMMUNICATION CALLS '/ &
' +------+------+------+------+--------------+'/ &
' | IH | ID | TARG | TAG | handle err |'/ &
' +------+------+------+------+--------------+')
9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |')
9083 FORMAT ( ' +------+------+------+------+--------------+')
9084 FORMAT ( ' MPIT WMIOES: NRQEQS:',I10/)
#endif
!/
!/ End of WMIOES ----------------------------------------------------- /
!/
END SUBROUTINE WMIOES
!/ ------------------------------------------------------------------- /
!>
!> @brief Gather internal same-rank data for a given model.
!>
!> @details For distributed memory version first receive all staged
!> data. After staged data is present, average, convert as necessary,
!> and store in basic spectral arrays.
!>
!> Using storage array EQSTGE and time stamps.
!>
!> @param[in] IMOD Model number of grid from which data is to
!> be gathered.
!> @param[out] DONE Flag for completion of operation (opt).
!>
!> @author H. L. Tolman @date 22-Jan-2007
!>
SUBROUTINE WMIOEG ( IMOD, DONE )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 22-Jan-2007 !
!/ +-----------------------------------+
!/
!/ 25-May-2006 : Origination. ( version 3.09 )
!/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
!/ 22-Jan-2007 : Adding NAVMAX. ( version 3.10 )
!/
! 1. Purpose :
!
! Gather internal same-rank data for a given model.
!
! 2. Method :
!
! For distributed memory version first receive all staged data.
! After staged data is present, average, convert as necessary,
! and store in basic spectral arrays.
!
! 2. Method :
!
! Using storage array EQSTGE and time stamps.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data is to
! be gathered.
! DONE Log. O Flag for completion of operation (opt).
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SETG, W3SETW, W3SETA, W3SETO
! Subr. WxxDATMD Manage data structures.
! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
! STRACE Sur. W3SERVMD Subroutine tracing.
! DSEC21 Func. W3TIMEMD Difference between times.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! See FORMAT labels 1001-1002.
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Enable test output
! !/MPIT
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE W3GDATMD
USE W3WDATMD
USE W3ADATMD
USE W3ODATMD
USE WMMDATMD
!
USE W3CSPCMD, ONLY: W3CSPC
USE W3TIMEMD, ONLY: DSEC21
USE W3SERVMD, ONLY: EXTCDE
#ifdef W3_PDLIB
use yowNodepool, only: npa
USE yowExchangeModule, only : PDLIB_exchange2Dreal
#endif
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
LOGICAL, INTENT(OUT), OPTIONAL :: DONE
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J, I, ISEA, JSEA, IA, IS
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
#ifdef W3_MPI
INTEGER :: IT0, ITAG, IFROM, IERR_MPI, &
NA, IP, I1, I2
#endif
#ifdef W3_MPIT
INTEGER :: ICOUNT
#endif
INTEGER, POINTER :: VTIME(:)
#ifdef W3_MPI
INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:)
#endif
REAL :: DTTST, WGHT
REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:)
#ifdef W3_MPI
REAL, POINTER :: SEQL(:,:,:)
LOGICAL :: FLAGOK
LOGICAL :: FLAG
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOEG')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD
WRITE (MDST,9001) 'NREC', EQSTGE(IMOD,:)%NREC
#endif
!
IF ( PRESENT(DONE) ) DONE = .FALSE.
!
IF ( EQSTGE(IMOD,IMOD)%NREC .EQ. 0 ) THEN
IF ( PRESENT(DONE) ) DONE = .TRUE.
#ifdef W3_T
WRITE (MDST,9002)
#endif
RETURN
END IF
!
CALL W3SETO ( IMOD, MDSE, MDST )
CALL W3SETG ( IMOD, MDSE, MDST )
CALL W3SETW ( IMOD, MDSE, MDST )
CALL W3SETA ( IMOD, MDSE, MDST )
!
! -------------------------------------------------------------------- /
! 1. Testing / gathering data in staging arrays
!
#ifdef W3_T
WRITE (MDST,9010) TIME
#endif
!
! 1.a Shared memory version, test valid times. - - - - - - - - - - - - /
!
#ifdef W3_SHRD
DO J=1, NRGRD
#endif
!
#ifdef W3_SHRD
IF ( IMOD .EQ. J ) CYCLE
IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE
#endif
!
#ifdef W3_SHRD
VTIME => EQSTGE(IMOD,J)%VTIME
IF ( VTIME(1) .EQ. -1 ) RETURN
DTTST = DSEC21 ( TIME, VTIME )
IF ( DTTST .NE. 0. ) RETURN
#endif
!
#ifdef W3_SHRD
END DO
#endif
!
! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - /
!
#ifdef W3_MPIT
WRITE (MDST,9011) EQLSTA(IMOD)
#endif
!
! 1.b.1 EQLSTA = 0
! Check if staging arrays are initialized.
! Post the proper receives.
!
#ifdef W3_MPI
IF ( EQLSTA(IMOD) .EQ. 0 ) THEN
#endif
!
#ifdef W3_MPI
NRQ => MDATAS(IMOD)%NRQEQG
NRQ = 0
DO J=1, NRGRD
IF ( J .EQ. IMOD ) CYCLE
NRQ = NRQ + EQSTGE(IMOD,J)%NREC * &
EQSTGE(IMOD,J)%NAVMAX
END DO
ALLOCATE ( IRQ(NRQ) )
IRQ = 0
NRQ = 0
#endif
!
#ifdef W3_MPI
DO J=1, NRGRD
IF ( IMOD .EQ. J ) CYCLE
IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE
#endif
!
! ..... Check valid time to determine staging.
!
#ifdef W3_MPI
VTIME => EQSTGE(IMOD,J)%VTIME
IF ( VTIME(1) .EQ. -1 ) THEN
DTTST = 1.
ELSE
DTTST = DSEC21 ( TIME, VTIME )
END IF
#endif
#ifdef W3_MPIT
WRITE (MDST,9013) VTIME, DTTST
#endif
!
! ..... Post receives for data gather
!
#ifdef W3_MPI
IF ( DTTST .NE. 0. ) THEN
#endif
#ifdef W3_MPIT
WRITE (MDST,9014) J
#endif
!
! ..... Spectra
!
#ifdef W3_MPI
IT0 = MTAG2 + 1
SEQL => EQSTGE(IMOD,J)%SEQL
#endif
!
#ifdef W3_MPI
DO I=1, EQSTGE(IMOD,J)%NREC
JSEA = EQSTGE(IMOD,J)%JSEA(I)
NA = EQSTGE(IMOD,J)%NAVG(I)
DO IA=1, NA
IP = EQSTGE(IMOD,J)%RIP(I,IA)
ITAG = EQSTGE(IMOD,J)%RTG(I,IA) + IT0
IF ( IP .NE. IMPROC ) THEN
NRQ = NRQ + 1
CALL MPI_IRECV ( SEQL(1,I,IA), &
SGRDS(J)%NSPEC, MPI_REAL, &
IP-1, ITAG, MPI_COMM_MWAVE, &
IRQ(NRQ), IERR_MPI )
#endif
#ifdef W3_MPIT
WRITE (MDST,9016) NRQ, JSEA, IP, &
ITAG-MTAG2, IRQ(NRQ), IERR_MPI
#endif
#ifdef W3_MPI
END IF
END DO
END DO
#endif
!
! ..... End IF for posting receives 1.b.1
!
#ifdef W3_MPIT
WRITE (MDST,9017)
#endif
#ifdef W3_MPI
END IF
#endif
!
! ..... End grid loop J in 1.b.1
!
#ifdef W3_MPI
END DO
#endif
#ifdef W3_MPIT
WRITE (MDST,9018) NRQ
#endif
!
#ifdef W3_MPI
IF ( NRQ .NE. 0 ) THEN
ALLOCATE ( MDATAS(IMOD)%IRQEQG(NRQ) )
MDATAS(IMOD)%IRQEQG = IRQ(1:NRQ)
END IF
#endif
!
#ifdef W3_MPI
DEALLOCATE ( IRQ )
#endif
!
! ..... Reset status
!
#ifdef W3_MPI
IF ( NRQ .GT. 0 ) THEN
EQLSTA(IMOD) = 1
#endif
#ifdef W3_MPIT
WRITE (MDST,9011) EQLSTA(IMOD)
#endif
#ifdef W3_MPI
END IF
#endif
!
! ..... End IF in 1.b.1
!
#ifdef W3_MPI
END IF
#endif
!
! 1.b.2 EQLSTA = 1
! Wait for communication to finish.
! If DONE defined, check if done, otherwise wait.
!
#ifdef W3_MPI
IF ( EQLSTA(IMOD) .EQ. 1 ) THEN
#endif
!
#ifdef W3_MPI
NRQ => MDATAS(IMOD)%NRQEQG
IRQ => MDATAS(IMOD)%IRQEQG
ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) )
#endif
!
! ..... Test communication if DONE is present, wait otherwise
!
#ifdef W3_MPI
IF ( PRESENT(DONE) ) THEN
#endif
!
#ifdef W3_MPI
CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, &
IERR_MPI )
#endif
!
#ifdef W3_MPIT
ICOUNT = 0
DO I=1, NRQ
CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), &
IERR_MPI )
FLAGOK = FLAGOK .AND. FLAG
IF ( FLAG ) ICOUNT = ICOUNT + 1
END DO
WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ)
#endif
!
#ifdef W3_MPI
ELSE
#endif
!
#ifdef W3_MPI
CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI )
FLAGOK = .TRUE.
#endif
#ifdef W3_MPIT
WRITE (MDST,9019) 100.
#endif
!
#ifdef W3_MPI
END IF
#endif
!
#ifdef W3_MPI
DEALLOCATE ( STATUS )
#endif
!
! ..... Go on based on FLAGOK
!
#ifdef W3_MPI
IF ( FLAGOK ) THEN
IF ( NRQ.NE.0 ) DEALLOCATE ( MDATAS(IMOD)%IRQEQG )
NRQ = 0
ELSE
RETURN
END IF
#endif
!
#ifdef W3_MPI
EQLSTA(IMOD) = 0
#endif
#ifdef W3_MPIT
WRITE (MDST,9011) EQLSTA(IMOD)
#endif
!
#ifdef W3_MPI
END IF
#endif
!
! ..... process locally stored data
!
#ifdef W3_MPI
DO J=1, NRGRD
EQSTGE(IMOD,J)%VTIME = TIME
IF ( J .EQ. IMOD ) CYCLE
DO IS=1, EQSTGE(IMOD,J)%NRQOUT
I = EQSTGE(IMOD,J)%OUTDAT(IS,1)
I1 = EQSTGE(IMOD,J)%OUTDAT(IS,2)
I2 = EQSTGE(IMOD,J)%OUTDAT(IS,3)
EQSTGE(IMOD,J)%SEQL(:,I1,I2) = EQSTGE(IMOD,J)%TSTORE(:,I)
END DO
END DO
#endif
!
! -------------------------------------------------------------------- /
! 2. Data available, process grid by grid
!
#ifdef W3_T
WRITE (MDST,9020)
#endif
!
! 2.a Do 'native' grid IMOD
!
#ifdef W3_T
WRITE (MDST,9021) IMOD, EQSTGE(IMOD,IMOD)%NREC
#endif
!
DO I=1, EQSTGE(IMOD,IMOD)%NREC
JSEA = EQSTGE(IMOD,IMOD)%JSEA(I)
WGHT = EQSTGE(IMOD,IMOD)%WGHT(I)
VA(:,JSEA) = WGHT * VA(:,JSEA)
END DO
!
! 2.b Loop over other grids
!
DO J=1, NRGRD
IF ( IMOD.EQ.J .OR. EQSTGE(IMOD,J)%NREC.EQ.0 ) CYCLE
!
#ifdef W3_T
WRITE (MDST,9022) J, EQSTGE(IMOD,J)%NREC
#endif
!
#ifdef W3_SMC
!! Use 1-1 full boundary spectra without modification. JGLi16Dec2020
IF( GTYPE .EQ. SMCTYPE ) THEN
DO I=1, EQSTGE(IMOD,J)%NREC
JSEA = EQSTGE(IMOD,J)%JSEA(I)
VA(:,JSEA) = EQSTGE(IMOD,J)%SEQL(:,I,1)
END DO
ELSE
!! Other grid boundary spectra may need conversion. JGLi12Apr2021
#endif
!
! 2.c Average spectra
!
#ifdef W3_T
WRITE (MDST,9023)
#endif
ALLOCATE ( SPEC1(SGRDS(J)%NSPEC,EQSTGE(IMOD,J)%NREC) )
SPEC1 = 0.
!
DO I=1, EQSTGE(IMOD,J)%NREC
DO IA=1, EQSTGE(IMOD,J)%NAVG(I)
SPEC1(:,I) = SPEC1(:,I) + EQSTGE(IMOD,J)%SEQL(:,I,IA) * &
EQSTGE(IMOD,J)%WAVG(I,IA)
END DO
END DO
!
! 2.d Convert spectra
!
IF ( RESPEC(IMOD,J) ) THEN
#ifdef W3_T
WRITE (MDST,9024)
#endif
ALLOCATE ( SPEC2(NSPEC,EQSTGE(IMOD,J)%NREC) )
!
CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, &
SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), &
SPEC2 , NK, NTH, XFR, FR1, TH(1), &
EQSTGE(IMOD,J)%NREC, MDST, MDSE, FACHFE)
!
SPEC => SPEC2
ELSE
SPEC => SPEC1
END IF
!
! 2.e Apply to native grid
!
DO I=1, EQSTGE(IMOD,J)%NREC
ISEA = EQSTGE(IMOD,J)%ISEA(I)
JSEA = EQSTGE(IMOD,J)%JSEA(I)
WGHT = EQSTGE(IMOD,J)%WGHT(I)
#ifdef W3_SMC
!! Regular grid in same ranked SMC group uses 1-1 mapping. JGLi12Apr2021
IF( NGRPSMC .GT. 0 ) THEN
VA(:,JSEA) = SPEC(:,I)
ELSE
#endif
DO IS=1, NSPEC
VA(IS,JSEA) = VA(IS,JSEA) + WGHT * &
SPEC(IS,I) / SIG2(IS) * CG(1+(IS-1)/NTH,ISEA)
END DO
#ifdef W3_SMC
ENDIF !! NGRPSMC .GT. 0
#endif
END DO
!
! 2.f Final clean up
!
DEALLOCATE ( SPEC1 )
IF ( RESPEC(IMOD,J) ) DEALLOCATE ( SPEC2 )
#ifdef W3_SMC
!! End GTYPE .EQ. SMCTYPE
ENDIF
#endif
!! End 2.b J grid loop.
END DO
!
! -------------------------------------------------------------------- /
! 3. Set flag if requested
!
IF ( PRESENT(DONE) ) DONE = .TRUE.
!
#ifdef W3_PDLIB
CALL PDLIB_exchange2Dreal(VA(:,1:NPA))
#endif
!
! Formats
!
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOEG : GATHERING DATA FOR GRID ',I4)
9001 FORMAT ( ' TEST WMIOEG : ',A,' PER SOURCE GRID : '/13X,20I5)
9002 FORMAT ( ' TEST WMIOEG : NO DATA TO BE GATHERED')
#endif
!
#ifdef W3_T
9010 FORMAT ( ' TEST WMIOEG : TEST DATA AVAILABILITY FOR',I9.8,I7.6)
#endif
#ifdef W3_MPIT
9011 FORMAT ( ' MPIT WMIOEG : EQLSTA =',I2)
9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A)
9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1)
9014 FORMAT (/' MPIT WMIOEG : RECEIVE FROM GRID',I4/ &
' +------+------+------+------+--------------+'/ &
' | IH | ID | FROM | TAG | handle err |'/ &
' +------+------+------+------+--------------+')
9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |')
9017 FORMAT ( ' +------+------+------+------+--------------+'/)
9018 FORMAT ( ' MPIT WMIOEG : NRQBPT:',I10/)
9019 FORMAT ( ' MPIT WMIOEG : RECEIVES FINISHED :',F6.1,'%')
#endif
!
#ifdef W3_T
9020 FORMAT ( ' TEST WMIOEG : PROCESSING DATA GRID BY GRID')
9021 FORMAT ( ' NATIVE GRID ',I3,' DATA :',I6)
9022 FORMAT ( ' RECEIVING GRID ',I3,' DATA :',I6)
9023 FORMAT ( ' AVERAGE SPECTRA')
9024 FORMAT ( ' CONVERTING SPECTRA')
#endif
!/
!/ End of WMIOEG ----------------------------------------------------- /
!/
END SUBROUTINE WMIOEG
!/ ------------------------------------------------------------------- /
!>
!> @brief Finalize staging of internal same-rank data in the data
!> structure EQSTGE (MPI only).
!>
!> @details Post appropriate 'wait' functions to assure that the
!> communication has finished.
!>
!> @param[in] IMOD Model number of grid from which data has
!> been staged.
!>
!> @author H. L. Tolman @date 25-May-2006
!>
SUBROUTINE WMIOEF ( IMOD )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 25-May-2006 !
!/ +-----------------------------------+
!/
!/ 25-May-2006 : Origination. ( version 3.09 )
!/
! 1. Purpose :
!
! Finalize staging of internal same-rank data in the data
! structure EQSTGE (MPI only).
!
! 2. Method :
!
! Post appropriate 'wait' functions to assure that the
! communication has finished.
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! IMOD Int. I Model number of grid from which data has
! been staged.
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! STRACE Subr. W3SERVMD Subroutine tracing.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMWAVE Subr WMWAVEMD Multi-grid wave model.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! See source code.
!
! 9. Switches :
!
! !/SHRD Shared/distributed memory models.
! !/DIST
! !/MPI
!
! !/S Enable subroutine tracing.
! !/T Test output.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!
USE WMMDATMD
!
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!
IMPLICIT NONE
!
#ifdef W3_MPI
INCLUDE "mpif.h"
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: J
#ifdef W3_MPI
INTEGER :: IERR_MPI
INTEGER, POINTER :: NRQ, IRQ(:)
INTEGER, ALLOCATABLE :: STATUS(:,:)
#endif
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
!/
#ifdef W3_S
CALL STRACE (IENT, 'WMIOEF')
#endif
!
! -------------------------------------------------------------------- /
! 0. Initializations
!
#ifdef W3_T
WRITE (MDST,9000) IMOD
#endif
!
! -------------------------------------------------------------------- /
! 1. Loop over grids
!
DO J=1, NRGRD
!
#ifdef W3_MPI
NRQ => EQSTGE(J,IMOD)%NRQEQS
#endif
!
! 1.a Nothing to finalize
!
#ifdef W3_MPI
IF ( NRQ .EQ. 0 ) CYCLE
IRQ => EQSTGE(J,IMOD)%IRQEQS
#endif
!
! 1.b Wait for communication to end
!
#ifdef W3_MPI
ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) )
CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI )
DEALLOCATE ( STATUS )
#endif
!
! 1.c Reset arrays and counter
!
#ifdef W3_MPI
DEALLOCATE ( EQSTGE(J,IMOD)%IRQEQS, &
EQSTGE(J,IMOD)%TSTORE, &
EQSTGE(J,IMOD)%OUTDAT )
NRQ = 0
#endif
!
#ifdef W3_T
WRITE (MDST,9010) J
#endif
!
END DO
!
RETURN
!
! Formats
!
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOEF : FINALIZE STAGING DATA FROM GRID ',I3)
9010 FORMAT ( ' TEST WMIOEF : FINISHED WITH TARGET ',I3)
#endif
!/
!/ End of WMIOEF ----------------------------------------------------- /
!/
END SUBROUTINE WMIOEF
!/
!/ End of module WMINIOMD -------------------------------------------- /
!/
END MODULE WMINIOMD