!> @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 ! ! -------------------------------------------------------------------- / ! 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. ! 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_zero #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_zero(VA) #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_zero #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_zero(VA) #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