wmiopomd.F90

Go to the documentation of this file.

 
 
#include "w3macros.h"
!/ ------------------------------------------------------------------- /
MODULE wmiopomd
  !/
  !/                  +-----------------------------------+
  !/                  | WAVEWATCH III           NOAA/NCEP |
  !/                  |           H. L. Tolman            |
  !/                  |                        FORTRAN 90 |
  !/                  | Last update :         06-Jun-2012 |
  !/                  +-----------------------------------+
  !/
  !/    09-Aug-2006 : Origination.                        ( version 3.10 )
  !/    01-May-2007 : Addd diagnostic output O7a/b.       ( version 3.11 )
  !/    21-Jun-2007 : Dedicated output processes.         ( version 3.11 )
  !/    29-May-2009 : Preparing distribution version.     ( version 3.14 )
  !/    30-Oct-2009 : Implement run-time grid selection.  ( version 3.14 )
  !/                  (W. E. Rogers & T. J. Campbell, NRL)
  !/    06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to
  !/                  specify index closure for a grid.   ( version 3.14 )
  !/                  (T. J. Campbell, NRL)
  !/    06-Mar-2012 : Using MPI_COMM_NULL in checks.      ( version 4.07 )
  !/    06-Jun-2012 : Porting bugfixes from 3.14 to 4.07  ( version 4.07 )
  !/
  !/    Copyright 2009-2012 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 :
  !
  !     Module for generating a single point output file for a multi-
  !     grid model implementation.
  !
  !  2. Variables and types :
  !
  !  3. Subroutines and functions :
  !
  !      Name      Type  Scope    Description
  !     ----------------------------------------------------------------
  !      WMIOPP    Subr  Public   Initialization routine.
  !      WMIOPO    Subr  Public   Gather and write routine.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines and functions used :
  !
  !      Name      Type  Module   Description
  !     ----------------------------------------------------------------
  !      W3SETG    Subr  W3GDATMD Point to model grid.
  !      W3SETW    Subr  W3WDATMD Point to model grid.
  !      W3SETA    Subr  W3ADATMD Point to model grid.
  !      W3SETO    Subr  W3ODATMD Point to model grid.
  !      W3DMO2    Subr     Id.   Dimention model grids output 2.
  !      WMSETM    Subr  WMMDATMD Point to model grid.
  !      W3MPIP    Subr  W3INITMD Model intiailization.
  !      W3IOPP    Sunr  W3IOPOMD Prepare point output for single model.
  !      W3IOPO    Sunr     Id.   Point output for single model.
  !      W3CSPC    Subr. W3CSPCMD Spectral grid conversion.
  !      STRACE    Subr  W3SERVMD Subroutine tracing.
  !      EXTCDE    Subr     Id.   Program abort.
  !      MPI_SEND, MPI_RECV
  !                Subr.  mpif.h  Standard MPI library routines.
  !     ----------------------------------------------------------------
  !
  !  5. Remarks :
  !
  !  6. Switches :
  !
  !       !/SHRD Distributed memory model.
  !       !/MPI
  !
  !       !O7a   Disgnostic output to NMPSCR.
  !       !O7b
  !
  !       !/S    Enable subroutine tracing.
  !       !/T    Enable test output
  !       !/MPIT
  !
  !  7. Source code :
  !
  !/ ------------------------------------------------------------------- /
  PUBLIC
  !/
CONTAINS
  !/ ------------------------------------------------------------------- /
  SUBROUTINE wmiopp ( NPT, XPT, YPT, PNAMES )
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         01-Sep-2012 !
    !/                  +-----------------------------------+
    !/
    !/    09-Aug-2006 : Origination.                        ( version 3.10 )
    !/    01-May-2007 : Addd diagnostic output O7a,b        ( version 3.11 )
    !/    30-Oct-2009 : Implement run-time grid selection.  ( version 3.14 )
    !/                  (W. E. Rogers & T. J. Campbell, NRL)
    !/    06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to
    !/                  specify index closure for a grid.   ( version 3.14 )
    !/                  (T. J. Campbell, NRL)
    !/    16-Mar-2012 : Using MPI_COMM_NULL in checks.      ( version 4.07 )
    !/    06-Jun-2012 : Porting bugfixes from 3.14 to 4.07  ( version 4.07 )
    !/    01-Sep-2012 : Added tests for unstructured grid   ( version 4.07 )
    !/                  (M. Dutour Sikiric, IRB & Aron Roland, Z&P)
    !/
    !  1. Purpose :
    !
    !     Initialization for unified point output.
    !
    !  2. Method :
    !
    !     Find highest resolution grid for each point.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       NPT     Int.   I   Number of output points in input.
    !       XPT     R.A.   I   X (longitude) coordinates of output points.
    !       YPT     R.A.   I   Id. Y.
    !       PNAMES  C*40   I   Names of output points.
    !     ----------------------------------------------------------------
    !       Note: all are optional, and should be given on the first call
    !             only, will be taken from storage after that.
    !             NPT needs to be ginve always, but can be dummy after
    !             first call.
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      W3SETG    Subr  W3GDATMD Point to model grid.
    !      W3SETW    Subr  W3WDATMD Point to model grid.
    !      W3SETA    Subr  W3ADATMD Point to model grid.
    !      W3SETO    Subr  W3ODATMD Point to model grid.
    !      W3DMO2    Subr     Id.   Dimension model grids output 2.
    !      WMSETM    Subr  WMMDATMD Point to model grid.
    !      W3MPIP    Subr  W3INITMD Model intiailization.
    !      W3IOPP    Sunr  W3IOPOMD Point output for single model.
    !      STRACE    Subr  W3SERVMD Subroutine tracing.
    !      EXTCDE    Subr     Id.   Program abort.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMINIT    Subr. WMINITMD Wave model initialization routine.
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !  7. Remarks :
    !
    !     - The algorithm used to decide if the pont is in the grid needs
    !       to be strictly consistent with W3IOPP.
    !     - MPI communication is set up separately from W3MPIO to assure
    !       that data are gathered in a single processor even if this
    !       procesor is not part of the communicator of the individual
    !       model.
    !     - In section 2.b the soring of the grids by rand is utilized.
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       !/SHRD Distributed memory model.
    !       !/MPI
    !
    !       !O7a   Disgnostic output to NMPSCR.
    !       !O7b
    !
    !       !/S    Enable subroutine tracing.
    !       !/T    Enable test output
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !
    USE w3gsrumd
    USE w3gdatmd, ONLY: w3setg
    USE w3adatmd, ONLY: w3seta
    USE w3wdatmd, ONLY: w3setw
    USE w3odatmd, ONLY: w3seto, w3dmo2
    USE wmmdatmd, ONLY: wmsetm
#ifdef W3_MPI
    USE w3initmd, ONLY: w3mpip
#endif
    USE w3iopomd, ONLY: w3iopp
    USE w3servmd, ONLY: extcde
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    !
    USE w3gdatmd, ONLY: nx, ny, x0, y0, sx, mapsta, grids,            &
         flagll, iclose, iclose_none, gtype, ungtype,  &
         clgtype, gsu
    USE w3gdatmd, ONLY: trigp, maxx, maxy, dxymax  ! unstructured grids
    USE w3odatmd, ONLY: o2init, nopts, ptloc, ptnme, grdid, outpts
#ifdef W3_MPI
    USE w3odatmd, ONLY: o2irqi
#endif
    USE wmmdatmd, ONLY: mdse, mdst, nrgrd, mdatas, improc, nmpscr,  &
         nmperr, mdss
    USE w3triamd
#ifdef W3_MPI
    USE wmmdatmd, ONLY: mpi_comm_grd, mpi_comm_mwave
#endif
    !
    IMPLICIT NONE
    !
#ifdef W3_MPI
    include "mpif.h"
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)                    :: NPT
    REAL, INTENT(IN), OPTIONAL             :: XPT(NPT), YPT(NPT)
    CHARACTER(LEN=40),INTENT(IN), OPTIONAL :: PNAMES(NPT)
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: IPT, J, II
    INTEGER                 :: IX(4), IY(4)         ! created by w3grmp
    REAL                    :: RD(4)                ! created by w3grmp
    INTEGER                 :: itout, I1, I2, I3    ! unstructured grids
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    INTEGER                 :: IERR_MPI
    REAL                    :: RX, RY, RDX, RDY
    REAL, PARAMETER         :: ACC = 0.05
    REAL, ALLOCATABLE       :: XP(:), YP(:)
    REAL                    :: FACTOR
    LOGICAL, ALLOCATABLE    :: INGRID(:,:)
    LOGICAL, SAVE           :: SETUP = .false., flgo7a = .false.
    CHARACTER(LEN=40), ALLOCATABLE :: PN(:)
    !/
#ifdef W3_S
    CALL strace (ient, 'WMIOPP')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 0.  Initializations
    !
    CALL w3seto ( 0, mdse, mdst )
    !
#ifdef W3_T
    WRITE (mdst,9000) o2init, npt, PRESENT(xpt),                 &
         PRESENT(ypt), PRESENT(pnames)
#endif
#ifdef W3_O7a
    flgo7a = .true.
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Initialize if necessary and possible
    !
    IF ( .NOT. o2init ) THEN
      !
#ifdef W3_T
      WRITE (mdst,9010)
#endif
      !
      IF ( .NOT.PRESENT(xpt) .OR. .NOT.PRESENT(ypt) .OR.          &
           .NOT.PRESENT(pnames) ) THEN
        WRITE (mdse,1000)
        CALL extcde (1)
      END IF
      !
      CALL w3dmo2 ( 0, mdse, mdst, npt )
      !
      nopts      = npt
      ptloc(1,:) = xpt
      ptloc(2,:) = ypt
      ptnme      = pnames
      grdid      = 'none'
      !
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Locate points in grids
    ! 2.a Check all points for all grids
    !
#ifdef W3_T
    WRITE (mdst,9020)
#endif
    !
    IF ( flagll ) THEN
      factor = 1.
    ELSE
      factor = 1.e-3
    END IF
    !
    ALLOCATE ( ingrid(nrgrd,nopts), xp(nopts), yp(nopts) )
    !
    ingrid = .false.
    xp     = ptloc(1,:)
    yp     = ptloc(2,:)
    !
    DO j=1, nrgrd
      !
      CALL w3setg ( j, mdse, mdst )
      !
      ! Loop over output points
      !
      ! notes.....Here, we have pulled coding for UNGTYPE and CLGTYPE from w3iopomd.ftn
      ! ..........in w3iopomd.ftn, it is "DO IPT=1, NPT" but otherwise very similar
      DO ipt=1, nopts
        !
        !     Check if point within grid
        !
        IF (gtype .NE. ungtype) THEN
          ingrid(j,ipt) = w3grmp( gsu, xpt(ipt), ypt(ipt), ix, iy, rd )
          IF ( .NOT.ingrid(j,ipt) ) THEN
            cycle
          END IF
        ELSE
          CALL is_in_ungrid(j, dble(xpt(ipt)), dble(ypt(ipt)), itout, ix, iy, rd )
          IF (itout.eq.0) THEN
            ingrid(j,ipt)=.false.
          END IF
        END IF
        !
        !     Check if point not on land
        !
        IF ( mapsta(iy(1),ix(1)) .EQ. 0 .AND. &
             mapsta(iy(2),ix(2)) .EQ. 0 .AND. &
             mapsta(iy(3),ix(3)) .EQ. 0 .AND. &
             mapsta(iy(4),ix(4)) .EQ. 0 ) THEN
          ingrid(j,ipt) = .false.
          cycle
        END IF
 
        !.........If we've gotten to this point, then we are satisfied that
        !................the point is in this grid.
 
      END DO !        DO IPT=1, NOPTS
      !
    END DO !      DO J=1, NRGRD
    !
    DEALLOCATE ( xp, yp )
    !
    ! 2.b Select a grid for each point
    !     start from last, which is supposedly higher resolution
    !
    mdatas(:)%NRUPTS = 0
    !
    DO ipt=1, nopts
      grdid(ipt) = '...none...'
      DO j= nrgrd, 1, -1
        IF ( ingrid(j,ipt) ) THEN
          grdid(ipt) = grids(j)%FILEXT
          mdatas(j)%NRUPTS = mdatas(j)%NRUPTS + 1
          EXIT
        END IF
      END DO
    END DO
    !
    ! 2.c Diagnostic output
    !
#ifdef W3_O7b
    IF ( improc .EQ. nmpscr ) THEN
      WRITE (mdss,920)
      DO ipt=1, nopts
        DO j=1, nrgrd
          IF ( grids(j)%FILEXT .EQ. grdid(ipt) ) EXIT
        END DO
        IF ( j .GT. nrgrd ) THEN
          WRITE (mdss,921) ptnme(ipt), ptloc(:,ipt)*factor
        ELSE
          WRITE (mdss,922) ptnme(ipt), ptloc(:,ipt)*factor, &
               grids(j)%FILEXT
        END IF
      END DO
      WRITE (mdss,929)
    END IF
#endif
    !
    ! 2.d Test output
    !
#ifdef W3_T
    DO ipt=1, nopts
      WRITE (mdst,9021) ipt, ptnme(ipt), grdid(ipt)
    END DO
#endif
    !
#ifdef W3_T
    ipt      = nopts
    WRITE (mdst,9022)
    DO j=1, nrgrd
      WRITE (mdst,9023) j, mdatas(j)%NRUPTS, grids(j)%FILEXT
      ipt      = ipt - mdatas(j)%NRUPTS
    END DO
    WRITE (mdst,9024) ipt
#endif
    !
    DEALLOCATE ( ingrid )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Initialize individual grids
    ! 3.a Loop over grids
    !
    DO j=1, nrgrd
      !
#ifdef W3_T
      WRITE (mdst,9030) j
#endif
      !
      ! 3.b (De)allocate map arrays
      !
      ipt      = max( 1 , mdatas(j)%NRUPTS )
      IF ( setup ) DEALLOCATE ( mdatas(j)%UPTMAP )
      ALLOCATE ( mdatas(j)%UPTMAP(ipt) )
      !
      IF ( mdatas(j)%NRUPTS .EQ. 0 ) cycle
      !
      ALLOCATE ( xp(ipt), yp(ipt), pn(ipt) )
      !
      ! 3.c Set up mapping and point arrays
      !
      ipt      = 0
      DO ii=1, nopts
        IF ( grdid(ii) .NE. grids(j)%FILEXT ) cycle
        ipt      = ipt + 1
        mdatas(j)%UPTMAP(ipt) = ii
        xp(ipt)  = ptloc(1,ii)
        yp(ipt)  = ptloc(2,ii)
        pn(ipt)  = ptnme(ii)
      END DO
      !
#ifdef W3_T
      DO ipt=1, mdatas(j)%NRUPTS
        WRITE (mdst,9031) ipt, mdatas(j)%UPTMAP(ipt),xp(ipt),yp(ipt),pn(ipt)
      END DO
#endif
      !
#ifdef W3_MPI
      IF ( flgo7a ) CALL mpi_barrier ( mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_O7a
      IF ( improc.EQ.nmpscr ) WRITE (mdss,930)               &
           j, grids(j)%FILEXT, ipt
#endif
      !
      ! 3.d Preprocessing for output
      !
#ifdef W3_T
      WRITE (mdst,9032)
#endif
      !
      ! 3.d.1 Shared memory version
      !
#ifdef W3_SHRD
      CALL w3seto ( j, mdse, mdst )
      CALL w3setg ( j, mdse, mdst )
#endif
      !
#ifdef W3_SHRD
      IF ( o2init ) THEN
        DEALLOCATE ( outpts(j)%OUT2%IPTINT,               &
             outpts(j)%OUT2%IL   , outpts(j)%OUT2%IW    ,  &
             outpts(j)%OUT2%II   , outpts(j)%OUT2%PTIFAC,  &
             outpts(j)%OUT2%PTNME, outpts(j)%OUT2%GRDID ,  &
             outpts(j)%OUT2%DPO  , outpts(j)%OUT2%WAO   ,  &
             outpts(j)%OUT2%WDO  , outpts(j)%OUT2%ASO   ,  &
             outpts(j)%OUT2%CAO  , outpts(j)%OUT2%CDO   ,  &
             outpts(j)%OUT2%SPCO , outpts(j)%OUT2%PTLOC )
        o2init = .false.
      END IF
#endif
      !
#ifdef W3_SHRD
      CALL w3iopp ( mdatas(j)%NRUPTS, xp, yp, pn, j )
#endif
      !
      ! 3.d.2 Distributed memory version
      !
#ifdef W3_MPI
      CALL wmsetm ( j, mdse, mdst )
#endif
      !
#ifdef W3_MPI
      IF ( mpi_comm_grd .NE. mpi_comm_null ) THEN
#endif
        !
#ifdef W3_MPI
        CALL w3seto ( j, mdse, mdst )
        CALL w3setg ( j, mdse, mdst )
        CALL w3seta ( j, mdse, mdst )
        CALL w3setw ( j, mdse, mdst )
#endif
        !
#ifdef W3_MPI
        IF ( o2init ) THEN
          DEALLOCATE ( outpts(j)%OUT2%IPTINT,               &
               outpts(j)%OUT2%IL   , outpts(j)%OUT2%IW    ,  &
               outpts(j)%OUT2%II   , outpts(j)%OUT2%PTIFAC,  &
               outpts(j)%OUT2%PTNME, outpts(j)%OUT2%GRDID ,  &
               outpts(j)%OUT2%DPO  , outpts(j)%OUT2%WAO   ,  &
               outpts(j)%OUT2%WDO  , outpts(j)%OUT2%ASO   ,  &
               outpts(j)%OUT2%CAO  , outpts(j)%OUT2%CDO   ,  &
               outpts(j)%OUT2%SPCO , outpts(j)%OUT2%PTLOC )
          o2init = .false.
        END IF
#endif
        !
#ifdef W3_MPI
        CALL w3iopp ( mdatas(j)%NRUPTS, xp, yp, pn, j )
#endif
        !
#ifdef W3_MPI
        IF ( o2irqi ) THEN
          DEALLOCATE (outpts(j)%OUT2%IRQPO1,                &
               outpts(j)%OUT2%IRQPO2 )
          o2irqi = .false.
        END IF
#endif
        !
#ifdef W3_MPI
        CALL w3mpip ( j )
#endif
        !
#ifdef W3_MPI
      END IF
#endif
      !
      ! This barrier is needed to straighten out output.
      !
#ifdef W3_O7a
      IF ( improc.EQ.nmpscr ) WRITE (mdss,939)
#endif
      !
      ! 3.e Reset pointers and clean up
      !
      CALL w3seto ( 0, mdse, mdst )
      DEALLOCATE ( xp, yp, pn )
      !
    END DO
    !
#ifdef W3_MPI
    IF ( flgo7a ) CALL mpi_barrier ( mpi_comm_mwave, ierr_mpi )
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 4.  Finalize
    !
    setup  = .true.
    !
    RETURN
    !
    ! Formats
    !
#ifdef W3_O7b
920 FORMAT (/'       Diagnostic test output for output points :'/ &
         '       -------------------------------------------------')
921 FORMAT ( '          ',a,' (',2f8.2,') NO GRID FOUND')
922 FORMAT ( '          ',a,' (',2f8.2,') grid ',a)
929 FORMAT ( ' ')
#endif
    !
#ifdef W3_O7a
930 FORMAT (/'       Grid ',i3,' [',a,']',i4,' points :'/    &
         '       -------------------------------------------------')
939 FORMAT ( ' ')
#endif
    !
1000 FORMAT (/' *** ERROR WMIOPP : INITALIZATION DATA NOT',          &
         ' AVAILABLE *** '/)
    !
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOPP : O2INIT   :',l2/                     &
         '               PAR LIST :',i4,3l2)
#endif
    !
#ifdef W3_T
9010 FORMAT ( ' TEST WMIOPP : INITIALIZING DATA GRID 0')
#endif
    !
#ifdef W3_T
9020 FORMAT ( ' TEST WMIOPP : FINDING POINTS IN GRID')
9021 FORMAT ( '               ',i4,2x,a,2x,a)
9022 FORMAT ( ' TEST WMIOPP : OUTPUT POINTS PER GRID')
9023 FORMAT ( '                  GRID',i3,' HAS',i4,' OUTPUT ',   &
         'POINTS, NAME = ',a)
9024 FORMAT ( '                  UNALLOCATED POINTS :',i4)
#endif
    !
#ifdef W3_T
9030 FORMAT ( ' TEST WMIOPP : PREPPING GRID',i3)
9031 FORMAT ( '             ',2i5,2e12.3,2x,a)
9032 FORMAT ( ' TEST WMIOPP : RUNNING W3IOPP / W3MPIP')
#endif
    !/
    !/ End of WMIOPP ----------------------------------------------------- /
    !/
  END SUBROUTINE wmiopp
  !/ ------------------------------------------------------------------- /
  SUBROUTINE wmiopo ( TOUT )
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         16-Mar-2012 !
    !/                  +-----------------------------------+
    !/
    !/    09-Aug-2006 : Origination.                        ( version 3.10 )
    !/    21-Jun-2007 : Dedicated output processes.         ( version 3.11 )
    !/    16-Mar-2012 : Using MPI_COMM_NULL in checks.      ( version 3.14 )
    !/
    !  1. Purpose :
    !
    !     Gather and write unified point output.
    !
    !  2. Method :
    !
    !     Per-grid point output is already gathered. All data are gathered
    !     in the porper storage, and writen using the standard W3IOPO
    !     routint from grid number 0.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       TOUT    I.A.   I   Time for output file.
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      W3SETG    Subr. W3GDATMD Point to model grid.
    !      W3SETW    Subr. W3WDATMD Point to model grid.
    !      W3SETO    Subr. W3ODATMD Point to model grid.
    !      WMSETM    Subr. WMMDATMD Point to model grid.
    !      W3CSPC    Subr. W3CSPCMD Spectral grid conversion.
    !      W3IOPO    Subr. W3IOPOMD Point output for single model.
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !      MPI_SEND, MPI_RECV
    !                Subr.  mpif.h  Standard MPI library routines.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMWAVE    Prog. WMWAVEMD Multi-grid wave model routine.
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !  7. Remarks :
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       !/MPI  Distributed memory model.
    !
    !       !/S    Enable subroutine tracing.
    !       !/T    Enable test output
    !       !/MPIT
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !     USE CONSTANTS
    !
    USE w3gdatmd, ONLY: w3setg
    USE w3wdatmd, ONLY: w3setw
    USE w3odatmd, ONLY: w3seto
    USE wmmdatmd, ONLY: wmsetm
    USE w3cspcmd, ONLY: w3cspc
    USE w3iopomd
    USE w3gdatmd, ONLY: nk, nth, nspec, xfr, fr1, th, sgrds
    USE w3wdatmd, ONLY: time
    USE w3odatmd, ONLY: iaproc, naproc, nappnt, nopts, spco, dpo,   &
         wao, wdo, aso, cao, cdo, outpts,            &
         iceo,iceho,icefo
    USE wmmdatmd, ONLY: mdst, mdse, improc, nmproc, nmpupt, nrgrd,  &
         respec, uptmap, mdsup
#ifdef W3_ASCII
    USE wmmdatmd, ONLY: mdsupa
#endif
#ifdef W3_MPI
    USE wmmdatmd, ONLY: mpi_comm_mwave, mpi_comm_grd, allprc,  &
         mtag0
#endif
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    !
    IMPLICIT NONE
    !
#ifdef W3_MPI
    include "mpif.h"
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)     :: TOUT(2)
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: J, I, II, IT0, IT, ITARG, IFROM
#ifdef W3_SHRD
    INTEGER                 :: MPI_COMM_GRD = 1, croot = 1
    INTEGER, PARAMETER      :: MPI_COMM_NULL = -1
#endif
#ifdef W3_MPI
    INTEGER                 :: IERR_MPI, NMPPNT
    INTEGER, ALLOCATABLE    :: STATUS(:,:)
#endif
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    REAL, POINTER           :: SPEC(:,:)
#ifdef W3_MPI
    REAL, POINTER           :: SPCR(:,:), DPR(:), WAR(:),      &
         WDR(:), ASR(:), CAR(:), CDR(:)
    REAL, POINTER           :: ICRO(:), ICRFO(:), ICRHO(:)
#endif
    !/
#ifdef W3_S
    CALL strace (ient, 'WMIOPO')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 0.  Initializations
    !
#ifdef W3_T
    WRITE (mdst,9000) nmpupt, improc
#endif
    !
    IF ( improc .EQ. nmpupt ) THEN
      outpts(0)%OUT2%SPCO  = 0.
      outpts(0)%OUT2%DPO   = 1.
      outpts(0)%OUT2%WAO   = 0.
      outpts(0)%OUT2%WDO   = 0.
      outpts(0)%OUT2%ASO   = 0.
      outpts(0)%OUT2%CAO   = 0.
      outpts(0)%OUT2%CDO   = 0.
      outpts(0)%OUT2%ICEO  = 0.
      outpts(0)%OUT2%ICEFO = 0.
      outpts(0)%OUT2%ICEHO = 0.
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Loop over grids for processing local data
    !
    DO j=1, nrgrd
      !
      ! 1.a Set up loop
      !
      CALL w3seto ( j, mdse, mdst )
      CALL w3setg ( j, mdse, mdst )
      CALL wmsetm ( j, mdse, mdst )
      !
#ifdef W3_T
      WRITE (mdst,9010) j, nopts, iaproc, nappnt
#endif
      !
      ! 1.b Determine if action
      !
      IF ( mpi_comm_grd .EQ. mpi_comm_null ) THEN
#ifdef W3_T
        WRITE (mdst,9011)
#endif
        cycle
      END IF
      !
      IF ( nopts .EQ. 0 ) THEN
#ifdef W3_T
        WRITE (mdst,9012)
#endif
        cycle
      END IF
      !
      IF ( iaproc .NE. nappnt ) THEN
#ifdef W3_T
        WRITE (mdst,9014)
#endif
        cycle
      END IF
      !
      ! 1.c Data here, and to remain on present processor.
      !
      IF ( improc .EQ. nmpupt ) THEN
#ifdef W3_T
        WRITE (mdst,9015)
#endif
        !
        ! 1.c.1 Spectral conversion if needed
        !
        IF ( respec(0,j) ) THEN
#ifdef W3_T
          WRITE (mdst,9016) 'YES'
#endif
          ALLOCATE ( spec(sgrds(0)%NSPEC,nopts) )
          CALL w3cspc ( spco, nk, nth, xfr, fr1, th(1), spec,   &
               sgrds(0)%NK, sgrds(0)%NTH, sgrds(0)%XFR,         &
               sgrds(0)%FR1, sgrds(0)%TH(1), nopts, mdst, mdse, &
               sgrds(0)%FACHFE )
          !
          ! 1.c.2 Spectral conversion not needed
          !
        ELSE
#ifdef W3_T
          WRITE (mdst,9016) 'NO'
#endif
          spec   => spco
        END IF
        !
        ! 1.d Store data at grid 0
        !
#ifdef W3_T
        WRITE (mdst,9017) j
#endif
        !
        DO i=1, nopts
          ii     = uptmap(i)
          outpts(0)%OUT2%SPCO(:,ii)  = spec(:,i)
          outpts(0)%OUT2%DPO(ii)     = dpo(i)
          outpts(0)%OUT2%WAO(ii)     = wao(i)
          outpts(0)%OUT2%WDO(ii)     = wdo(i)
          outpts(0)%OUT2%ASO(ii)     = aso(i)
          outpts(0)%OUT2%CAO(ii)     = cao(i)
          outpts(0)%OUT2%CDO(ii)     = cdo(i)
          outpts(0)%OUT2%ICEO(ii)    = iceo(i)
          outpts(0)%OUT2%ICEFO(ii)   = icefo(i)
          outpts(0)%OUT2%ICEHO(ii)   = iceho(i)
        END DO
        !
        IF ( respec(0,j) ) DEALLOCATE ( spec )
        !
        ! 1.e Data here, and to be sent to other processor.
        !
#ifdef W3_MPI
      ELSE
#endif
        !
#ifdef W3_MPIT
        WRITE (mdst,9018) j, improc, nmpupt
#endif
        !
#ifdef W3_MPI
        it0    = mtag0 - 7*nrgrd - 1
        it     = it0 + (j-1)*7
        itarg  = nmpupt - 1
#endif
        !
#ifdef W3_MPI
        it     = it + 1
        CALL mpi_send ( spco(1,1), nspec*nopts, mpi_real,    &
             itarg, it, mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_MPIT
        WRITE (mdst,9019) it-it0, 'SPECTRA'
#endif
#ifdef W3_MPI
        it     = it + 1
        CALL mpi_send ( dpo(1), nopts, mpi_real, itarg, it,  &
             mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_MPIT
        WRITE (mdst,9019) it-it0, 'WATER DEPTHS'
#endif
#ifdef W3_MPI
        it     = it + 1
        CALL mpi_send ( wao(1), nopts, mpi_real, itarg, it,  &
             mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_MPIT
        WRITE (mdst,9019) it-it0, 'WIND SPEED'
#endif
#ifdef W3_MPI
        it     = it + 1
        CALL mpi_send ( wdo(1), nopts, mpi_real, itarg, it,  &
             mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_MPIT
        WRITE (mdst,9019) it-it0, 'WIND DIRECTION'
#endif
#ifdef W3_MPI
        it     = it + 1
        CALL mpi_send ( aso(1), nopts, mpi_real, itarg, it,  &
             mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_MPIT
        WRITE (mdst,9019) it-it0, 'AIR_SEA TEMP DIFF'
#endif
#ifdef W3_MPI
        it     = it + 1
        CALL mpi_send ( cao(1), nopts, mpi_real, itarg, it,  &
             mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_MPIT
        WRITE (mdst,9019) it-it0, 'CURRENT VELOCITY'
#endif
#ifdef W3_MPI
        it     = it + 1
        CALL mpi_send ( cdo(1), nopts, mpi_real, itarg, it,  &
             mpi_comm_mwave, ierr_mpi )
#endif
#ifdef W3_MPIT
        WRITE (mdst,9019) it-it0, 'CURRENT DIRECTION'
#endif
        !JDM: The below should be added for points using partitioned processors
        ! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so
        ! this is being left here commented out for now.
        ! There is a corresponding section to this below
        !!/MPI            IT     = IT + 1
        !!/MPI            CALL MPI_SEND ( ICEO(1), NOPTS, MPI_REAL, ITARG, IT,  &
        !!/MPI                            MPI_COMM_MWAVE, IERR_MPI )
        !!/MPIT            WRITE (MDST,9019) IT-IT0, 'ICEO'
        !!/MPI            IT     = IT + 1
        !!/MPI            CALL MPI_SEND ( ICEFO(1), NOPTS, MPI_REAL, ITARG, IT,  &
        !!/MPI                            MPI_COMM_MWAVE, IERR_MPI )
        !!/MPIT            WRITE (MDST,9019) IT-IT0, 'ICEFO'
        !!/MPI            IT     = IT + 1
        !!/MPI            CALL MPI_SEND ( ICEHO(1), NOPTS, MPI_REAL, ITARG, IT,  &
        !!/MPI                            MPI_COMM_MWAVE, IERR_MPI )
        !!/MPIT            WRITE (MDST,9019) IT-IT0, 'ICEHO'
        !
      END IF
      !
    END DO
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Check if this is output processor, otherwise exit
    !
    IF ( improc .NE. nmpupt ) THEN
#ifdef W3_T
      WRITE (mdst,9020)
#endif
      RETURN
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Loop over grids for processing remote data
    !
#ifdef W3_MPIT
    WRITE (mdst,9030)
#endif
    !
    ! 3.a Loop setup
    !
#ifdef W3_MPI
    DO j=1, nrgrd
#endif
      !
#ifdef W3_MPI
      CALL w3seto ( j, mdse, mdst )
      CALL w3setg ( j, mdse, mdst )
      CALL wmsetm ( j, mdse, mdst )
#endif
      !
#ifdef W3_MPI
      DO nmppnt= nmproc, 1, -1
        IF ( allprc(nmppnt,j) .EQ. nappnt ) EXIT
      END DO
#endif
      !
#ifdef W3_MPIT
      WRITE (mdst,9031) j, nopts, nmppnt
#endif
#ifdef W3_MPI
      IF ( nmppnt.EQ.nmpupt .OR. nopts.EQ.0 ) THEN
#endif
#ifdef W3_MPIT
        WRITE (mdst,9032)
#endif
#ifdef W3_MPI
        cycle
      END IF
#endif
      !
      ! 3.b Receive data
      !
#ifdef W3_MPI
      it0    = mtag0 - 7*nrgrd - 1
      it     = it0 + (j-1)*7
      ifrom  = nmppnt - 1
      ALLOCATE ( spcr(nspec,nopts), status(mpi_status_size,1),  &
           dpr(nopts), war(nopts), wdr(nopts), asr(nopts),&
           car(nopts), cdr(nopts), icro(nopts),           &
           icrfo(nopts), icrho(nopts) )
#endif
      !
#ifdef W3_MPI
      it     = it + 1
      CALL mpi_recv ( spcr(1,1), nspec*nopts, mpi_real, ifrom,  &
           it, mpi_comm_mwave, status, ierr_mpi )
#endif
#ifdef W3_MPIT
      WRITE (mdst,9019) it-it0, 'SPECTRA'
#endif
#ifdef W3_MPI
      it     = it + 1
      CALL mpi_recv ( dpr(1), nspec*nopts, mpi_real, ifrom,     &
           it, mpi_comm_mwave, status, ierr_mpi )
#endif
#ifdef W3_MPIT
      WRITE (mdst,9019) it-it0, 'WATER DEPTHS'
#endif
#ifdef W3_MPI
      it     = it + 1
      CALL mpi_recv ( war(1), nspec*nopts, mpi_real, ifrom,     &
           it, mpi_comm_mwave, status, ierr_mpi )
#endif
#ifdef W3_MPIT
      WRITE (mdst,9019) it-it0, 'WIND SPEED'
#endif
#ifdef W3_MPI
      it     = it + 1
      CALL mpi_recv ( wdr(1), nspec*nopts, mpi_real, ifrom,     &
           it, mpi_comm_mwave, status, ierr_mpi )
#endif
#ifdef W3_MPIT
      WRITE (mdst,9019) it-it0, 'WIND DIRECTION'
#endif
#ifdef W3_MPI
      it     = it + 1
      CALL mpi_recv ( asr(1), nspec*nopts, mpi_real, ifrom,     &
           it, mpi_comm_mwave, status, ierr_mpi )
#endif
#ifdef W3_MPIT
      WRITE (mdst,9019) it-it0, 'AIR_SEA TEMP DIFF'
#endif
#ifdef W3_MPI
      it     = it + 1
      CALL mpi_recv ( car(1), nspec*nopts, mpi_real, ifrom,     &
           it, mpi_comm_mwave, status, ierr_mpi )
#endif
#ifdef W3_MPIT
      WRITE (mdst,9019) it-it0, 'CURRENT VELOCITY'
#endif
#ifdef W3_MPI
      it     = it + 1
      CALL mpi_recv ( cdr(1), nspec*nopts, mpi_real, ifrom,     &
           it, mpi_comm_mwave, status, ierr_mpi )
#endif
#ifdef W3_MPIT
      WRITE (mdst,9019) it-it0, 'CURRENT DIRECTION'
#endif
      !JDM: The below should be added for points using partitioned processors
      ! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so
      ! this is being left here commented out for now.
      ! There is a corresponding section to this above
      !!/MPI         IT     = IT + 1
      !!/MPI         CALL MPI_RECV ( ICRO(1), NSPEC*NOPTS, MPI_REAL, IFROM,   &
      !!/MPI                        IT, MPI_COMM_MWAVE, STATUS, IERR_MPI )
      !!/MPIT         WRITE (MDST,9019) IT-IT0, 'ICEO'
      !!/MPI         IT     = IT + 1
      !!/MPI         CALL MPI_RECV (ICRFO(1), NSPEC*NOPTS, MPI_REAL, IFROM,   &
      !!/MPI                        IT, MPI_COMM_MWAVE, STATUS, IERR_MPI )
      !!/MPIT         WRITE (MDST,9019) IT-IT0, 'ICEFO'
      !!/MPI         IT     = IT + 1
      !!/MPI         CALL MPI_SEND (ICRHO(1), NSPEC*NOPTS, MPI_REAL, IFROM,   &
      !!/MPI                        IT, MPI_COMM_MWAVE, STATUS, IERR_MPI )
      !!/MPIT            WRITE (MDST,9019) IT-IT0, 'ICEHO'
      !
      ! 3.c Convert if necessary
      !
#ifdef W3_MPI
      IF ( respec(0,j) ) THEN
#endif
#ifdef W3_MPIT
        WRITE (mdst,9016) 'YES'
#endif
#ifdef W3_MPI
        ALLOCATE ( spec(sgrds(0)%NSPEC,nopts) )
        CALL w3cspc ( spcr, nk, nth, xfr, fr1, th(1), spec,   &
             sgrds(0)%NK, sgrds(0)%NTH, sgrds(0)%XFR,         &
             sgrds(0)%FR1, sgrds(0)%TH(1), nopts, mdst, mdse, &
             sgrds(0)%FACHFE )
      ELSE
#endif
#ifdef W3_MPIT
        WRITE (mdst,9016) 'NO'
#endif
#ifdef W3_MPI
        spec   => spcr
      END IF
#endif
      !
      ! 3.d Store data at grid 0
      !
#ifdef W3_MPIT
      WRITE (mdst,9117) j
#endif
      !
#ifdef W3_MPI
      DO i=1, nopts
        ii     = uptmap(i)
        outpts(0)%OUT2%SPCO(:,ii)  = spec(:,i)
        outpts(0)%OUT2%DPO(ii)     = dpr(i)
        outpts(0)%OUT2%WAO(ii)     = war(i)
        outpts(0)%OUT2%WDO(ii)     = wdr(i)
        outpts(0)%OUT2%ASO(ii)     = asr(i)
        outpts(0)%OUT2%CAO(ii)     = car(i)
        outpts(0)%OUT2%CDO(ii)     = cdr(i)
        outpts(0)%OUT2%ICEO(ii)    = iceo(i)
        outpts(0)%OUT2%ICEFO(ii)    = icefo(i)
        outpts(0)%OUT2%ICEHO(ii)    = iceho(i)
      END DO
#endif
      !
#ifdef W3_MPI
      IF ( respec(0,j) ) DEALLOCATE ( spec )
      DEALLOCATE ( spcr, dpr, war, wdr, asr, car, cdr, status )
#endif
      !        !JDM add deallocates here and check the itag stuff.. really not
      !        sure aabout that
#ifdef W3_MPI
      DEALLOCATE (icro, icrfo, icrho)
    END DO
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 4.  Output data
    !
#ifdef W3_T
    WRITE (mdst,9040)
#endif
    !
    CALL w3seto ( 0, mdse, mdst )
    CALL w3setg ( 0, mdse, mdst )
    CALL w3setw ( 0, mdse, mdst )
    !
    time   = tout
    !
#ifdef W3_BIN2NC
    CALL w3iopon ( 'WRITE', mdsup, ii, 0)
#else
    CALL w3iopo ( 'WRITE', mdsup, ii, 0 &
#ifdef W3_ASCII
            ,mdsupa                     &
#endif
            )
#endif 
    !
    RETURN
    !
    ! Formats
    !
#ifdef W3_T
9000 FORMAT ( ' TEST WMIOPO : OUTPUT/ACTUAL PROCESS    : ',2i6)
9010 FORMAT ( ' TEST WMIOPO : PROCESSING GRID          : ',i6/    &
         '               OUTPUT POINTS            : ',i6/    &
         '               ACTUAL/OUTPUT PROCESS    : ',2i6)
9011 FORMAT ( '       CYCLE : GRID NOT ON PROCESS')
9012 FORMAT ( '       CYCLE : GRID WITHOUT OUTPUT POINTS')
9014 FORMAT ( '       CYCLE : DATA NOT ON PRESENT PROCESS')
9015 FORMAT ( ' TEST WMIOPO : PROCESSING DATA LOCALLY')
9016 FORMAT ( ' TEST WMIOPO : NEED FOR SPECTRAL CONVERSION : ',a)
9017 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',i4,         &
         ' IN GRID 0')
#endif
#ifdef W3_MPIT
9117 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',i4,      &
         ' IN GRID 0')
9018 FORMAT ( ' TEST WMIOPO : GRID',i4,' SEND FROM',i4,' TO',i4)
9019 FORMAT ( '                 IT = ',i4,'  PAR = ',a)
#endif
    !
#ifdef W3_T
9020 FORMAT ( ' TEST WMIOPO : DONE AT THIS PROCESSOR')
#endif
    !
#ifdef W3_MPIT
9030 FORMAT ( ' TEST WMIOPO : LOOP OVER GRIDS FOR REMOTE DATA')
9031 FORMAT ( ' TEST WMIOPO : GRID',i4,',',i4,' POINTS FROM',i4)
9032 FORMAT ( '               NOTHING TO RECEIVE')
#endif
    !
9040 FORMAT ( ' TEST WMIOPO : PERFORM OUTPUT')
    !/
    !/ End of WMIOPO ----------------------------------------------------- /
    !/
  END SUBROUTINE wmiopo
  !/
  !/ End of module WMIOPOMD -------------------------------------------- /
  !/
END MODULE wmiopomd