wmupdtmd Module Reference

Update model input at the driver level of the multi-grid version of WAVEWATCH III. More...

Functions/Subroutines
subroutine	wmupdt (IMOD, TDATA)
	Update inputs for selected wave model grid. More...
subroutine	wmupd1 (IMOD, IDSTR, J, IERR)
	Update selected input using native input files. More...
subroutine	wmupd2 (IMOD, J, JMOD, IERR)
	Update selected input using input grids. More...
subroutine	wmupdv (IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP)
	Interpolate vector field from input grid to model grid. More...
subroutine	wmupds (IMOD, FD, JMOD, FDI, UNDEF)
	Interpolate scalar field from input grid to model grid. More...
integer function	xycurvisearch (LENGTH, ARRAY, VALUE, DELTA)
	Search the location of a point(XC,YC) in a regular grid. More...
real function	interpolate (X_LEN, XARRAY, Y_LEN, YARRAY, FUNC, X, Y, DELTA)
	Perform interpolation from regular to curvilinear grid for a scalar field. More...
subroutine	interpolate2d (X_LEN, XARRAY, Y_LEN, YARRAY, FUNC1, FUNC2, X, Y, DELTA, VAL1, VAL2)
	Perform interpolation from regular to curvilinear grid for a vector field. More...
real function	averaging (X_LEN, XARRAY, Y_LEN, YARRAY, FUNC, X, Y, NPX, NPY)
	This function uses averaging to estimate the value of a function f at point (x,y). More...

Variables
integer, parameter	swpmax = 5
	SWPMAX. More...

Detailed Description

Update model input at the driver level of the multi-grid version of WAVEWATCH III.

Author

H. L. Tolman

Date

22-Mar-2021

Function/Subroutine Documentation

averaging()

real function wmupdtmd::averaging	(	integer	X_LEN,
		real, dimension(x_len)	XARRAY,
		integer	Y_LEN,
		real, dimension(y_len)	YARRAY,
		real, dimension(x_len, y_len)	FUNC,
		real	X,
		real	Y,
		integer	NPX,
		integer	NPY
	)

This function uses averaging to estimate the value of a function f at point (x,y).

f is assumed to be on a regular grid, with the grid x values specified by xarray with dimension x_len and the grid y values specified by yarray with dimension y_len, the number of point to be taken into account in x and y.

Parameters

X_LEN
XARRAY
Y_LEN
YARRAY
FUNC
X
Y
NPX
NPY

Returns

AVERAGING

Author

H. L. Tolman

Date

25-Jul-2019

Definition at line 3028 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        25-July-2019 |
    !/                  +-----------------------------------+
    !/
    !/                     (R. Padilla-Hernandez, EMC/NOAA)
    !/
    !/    29-July-2019 :                        ( version 7.13 )
    !/
 
    ! THIS FUNCTION USES AVERAGING TO ESTIMATE THE VALUE
    ! OF A FUNCTION F AT POINT (X,Y)
    ! F IS ASSUMED TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED
    ! BY XARRAY WITH DIMENSION X_LEN
    ! AND THE GRID Y VALUES SPECIFIED BY YARRAY WITH DIMENSION Y_LEN
    ! ININI AND INEND, THE NUMBER OF POINT TO BE TAKEN INTO ACCOUNT
    ! IN X AND Y
 
    !IMPLICIT NONE
    INTEGER  X_LEN, Y_LEN, INXEND, INYEND, NPX,NPY
    REAL, DIMENSION(X_LEN) :: XARRAY
    REAL, DIMENSION(Y_LEN)  :: YARRAY
    REAL, DIMENSION(X_LEN, Y_LEN) :: FUNC
    REAL :: X,Y
 
    REAL :: X1, X2, Y1, Y2, SUM
    INTEGER :: INX,INY, INITIALX, INITIALY
    INTEGER :: INFINX, INFINY,ICOUNT,I,J
 
    inx = xycurvisearch(x_len, xarray, x)
    iny = xycurvisearch(y_len, yarray, y)
 
    x1 = xarray(inx)
    !X2 = XARRAY(INX+1)
 
    y1 = yarray(iny)
    !Y2 = YARRAY(INY+1)
 
    inxend=npx+1
    inyend=npy+1
    ! LETS FIX THE INITIAL INDEX =1 NEGATIVE INDEXES IN LONG
    IF (inx-npx .LT. 1) THEN
      initialx=1
    ELSE
      initialx=inx-npx
    END IF
    ! LETS FIX THE FINAL INDEX =NX IF LOOKING FOR INDEXES > NX
    IF (inx+inxend .GT. x_len) THEN
      infinx=x_len
    ELSE
      infinx=inx+inxend
    END IF
    ! LETS FIX THE INITIAL INDEX =1 FOR NEGATIVE INDEXES FOR LAT
    IF (iny-npy .LT. 1) THEN
      initialy=1
    ELSE
      initialy=iny-npy
    END IF
    ! LETS FIX THE FINAL INDEX =NX IF LOOKING FOR INDEXES > NX
    IF (iny+inyend .GT. y_len) THEN
      infiny=y_len
    ELSE
      infiny=iny+inyend
    END IF
 
 
    sum=0.0
    icount=0
    DO j=initialy,infiny
      DO i=initialx,infinx
        icount=icount+1
        sum=sum+func(i,j)
      END DO
    END DO
    averaging=sum/real(icount)
 

References xycurvisearch().

interpolate()

real function wmupdtmd::interpolate	(	integer, intent(in)	X_LEN,
		real, dimension(x_len), intent(in)	XARRAY,
		integer, intent(in)	Y_LEN,
		real, dimension(y_len), intent(in)	YARRAY,
		real, dimension(x_len, y_len), intent(in)	FUNC,
		real, intent(in)	X,
		real, intent(in)	Y,
		real, intent(in), optional	DELTA
	)

Perform interpolation from regular to curvilinear grid for a scalar field.

This function uses bilinear interpolation to estimate the value of a function f at point (x,y). f is assumed to be on a regular grid, with the grid x values specified by xarray with dimension x_len and the grid y values specified by yarray with dimension y_len.

Parameters

X_LEN	Dimension in X
XARRAY	1D array for Longitudes
Y_LEN	Dimension in Y
YARRAY	1D array for Latitudes
FUNC	1D Field
X	Long for point in the curv grid
Y	Lat for point in the curv grid
DELTA	Threshold to determine if two values are equal

Returns

INTERPOLATE

Author

H. L. Tolman

Date

25-Jul-2019

Definition at line 2744 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        25-July-2019 |
    !/                  +-----------------------------------+
    !/
    !/                     (R. Padilla-Hernandez, EMC/NOAA)
    !/
    !/    29-July-2019 :                        ( version 7.13 )
    !/
    !  1. Purpose :
    !
    !     Perform interpolation from regular to curvilinear grid for a
    !     scalar field. THIS FUNCTION USES BILINEAR INTERPOLATION TO
    !     ESTIMATE THE VALUE OF A FUNCTION F AT POINT (X,Y) F IS ASSUMED
    !     TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED BY
    !     XARRAY WITH DIMENSION X_LEN AND THE GRID Y VALUES SPECIFIED BY
    !     YARRAY WITH DIMENSION Y_LEN
    !
    !  2. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       X_LEN    Int.  Dimension in X
    !       XARRAY   Int.  1D array for Longitudes
    !       Y_LEN    Int.  Dimension in Y
    !       YARRAY   Int.  1D array for Latitudes
    !       FUNC     Int.  1D Field
    !       X,Y      Real  Long-Lat for point in the curv grid
    !       DELTA    Real  Threshold to determine if two values are equal
    !     ----------------------------------------------------------------
    !
    !     Internal parameters
    !     ----------------------------------------------------------------
    !       INX     Int.  Index in X on the rectiliniear grid that is
    !                     closest to, but less than, the given value for a
    !                     point in the curvilinear grid.
    !       JNX     Int.  Idem INX for for Y.
    !       X1,Y1   Real  (Long, Lat) left-bottom corner for the square in
    !                     regular grid, where the given value for the point
    !                     in the curvilinear grid lies
    !       X2,Y2   Real  (Long, Lat) right-upper corner for the square in
    !                     regular grid, where the given value for the point
    !                     in the curvilinear grid lies
    !     ----------------------------------------------------------------
    !
    !  3. Subroutines used :
    !
    !      Name          Type   Module   Description
    !     ----------------------------------------------------------------
    !     XYCURVISEARCH   Func. wmupdtmd Look for indexes in 1D array.
    !     ----------------------------------------------------------------
    !
    !  4. Called by :
    !
    !     Main program in which it is contained.
    !
    !  5. Error messages :
    !
    !       None.
    !
    !  6. Remarks :
    !
    !     -
    !
    !  7. Structure :
    !
    !     See source code.
    !
    !  8. Switches :
    !
    !       -
    !
    !  9. Source code :
    ! THIS FUNCTION USES BILINEAR INTERPOLATION TO ESTIMATE THE VALUE
    ! OF A FUNCTION F AT POINT (X,Y)
    ! F IS ASSUMED TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED
    ! BY XARRAY WITH DIMENSION X_LEN
    ! AND THE GRID Y VALUES SPECIFIED BY YARRAY WITH DIMENSION Y_LEN
    !
    INTEGER, INTENT(IN) :: X_LEN, Y_LEN
    REAL, DIMENSION(X_LEN), INTENT(IN) :: XARRAY
    REAL, DIMENSION(Y_LEN), INTENT(IN) :: YARRAY
    REAL, DIMENSION(X_LEN, Y_LEN), INTENT(IN) :: FUNC
    REAL, INTENT(IN) :: X,Y
    REAL, INTENT(IN), OPTIONAL :: DELTA
    REAL :: DENOM, X1, X2, Y1, Y2
    INTEGER :: INX,JNX
 
    inx = xycurvisearch(x_len, xarray, x, delta)
    jnx = xycurvisearch(y_len, yarray, y, delta)
    !
    IF (inx .GE. x_len) THEN
      inx=inx-1
    END IF
    IF (jnx .GE. y_len) THEN
      jnx=jnx-1
    END IF
    !
    x1 = xarray(inx)
    x2 = xarray(inx+1)
    y1 = yarray(jnx)
    y2 = yarray(jnx+1)
    !
    denom = (x2 - x1)*(y2 - y1)
    !
    interpolate = (func(inx,jnx)*(x2-x)*(y2-y) +           &
         func(inx+1,jnx)*(x-x1)*(y2-y) +         &
         func(inx,jnx+1)*(x2-x)*(y-y1)+          &
         func(inx+1, jnx+1)*(x-x1)*(y-y1))/denom
    !

References xycurvisearch().

Referenced by wmupds().

interpolate2d()

subroutine wmupdtmd::interpolate2d	(	integer, intent(in)	X_LEN,
		real, dimension(x_len), intent(in)	XARRAY,
		integer, intent(in)	Y_LEN,
		real, dimension(y_len), intent(in)	YARRAY,
		real, dimension(x_len, y_len), intent(in)	FUNC1,
		real, dimension(x_len, y_len), intent(in)	FUNC2,
		real, intent(in)	X,
		real, intent(in)	Y,
		real, intent(in), optional	DELTA,
		real, intent(out)	VAL1,
		real, intent(out)	VAL2
	)

Perform interpolation from regular to curvilinear grid for a vector field.

This function uses bilinear interpolation to estimate the value of a function f at point (x,y). f is assumed to be on a regular grid, with the grid x values specified by xarray with dimension x_len and the grid y values specified by yarray with dimension y_len.

Parameters

[in]	X_LEN	Dimension in X
[in]	XARRAY	1D array for Longitudes
[in]	Y_LEN	Dimension in Y
[in]	YARRAY	1D array for Latitudes
[in]	FUNC1	First component of the 2D array
[in]	FUNC2	Second component of the 2D array
[in]	X	Long for point the curv grid
[in]	Y	Lat for point the curv grid
[in]	DELTA	Threshold to determine if two values are equal
[out]	VAL1	Interpolated value at a point in curv grid
[out]	VAL2	Interpolated value at a point in curv grid

Author

H. L. Tolman

Date

25-Jul-2019

Definition at line 2886 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        25-July-2019 |
    !/                  +-----------------------------------+
    !/
    !/                     (R. Padilla-Hernandez, EMC/NOAA)
    !/
    !/    29-July-2019 :                        ( version 7.13 )
    !/
    !  1. Purpose :
    !
    !     Perform interpolation from regular to curvilinear grid for a
    !     Vector field. THIS FUNCTION USES BILINEAR INTERPOLATION TO
    !     ESTIMATE THE VALUE OF A FUNCTION F AT POINT (X,Y) F IS ASSUMED
    !     TO BE ON A REGULAR GRID, WITH THE GRID X VALUES SPECIFIED BY
    !     XARRAY WITH DIMENSION X_LEN AND THE GRID Y VALUES SPECIFIED BY
    !     YARRAY WITH DIMENSION Y_LEN
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       X_LEN     Int.  Dimension in X
    !       XARRAY    Int.  1D array for Longitudes
    !       Y_LEN     Int.  Dimension in Y
    !       YARRAY    Int.  1D array for Latitudes
    !       FUNC1     Int.  First componen of the 2D array
    !       FUNC2     Int.  Second component of the 2D array
    !       X,Y       Real  Long-Lat for point in the curv grid
    !       DELTA     Real  Threshold to determine if two values are equal
    !       VAL1,VAL2 Real  Interpolated values at a point in curvi grid
    !     ----------------------------------------------------------------
    !
    !     Internal parameters
    !     ----------------------------------------------------------------
    !       INX     Int.  Index in X on the rectiliniear grid that is
    !                     closest to, but less than, the given value for a
    !                     point in the curvilinear grid.
    !       JNX     Int.  Idem INX for for Y.
    !       X1,Y1   Real  (Long, Lat) left-bottom corner for the square in
    !                     regular grid, where the given value for the point
    !                     in the curvilinear grid lies
    !       X2,Y2   Real  (Long, Lat) right-upper corner for the square in
    !                     regular grid, where the given value for the point
    !                     in the curvilinear grid lies
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name          Type   Module   Description
    !     ----------------------------------------------------------------
    !     XYCURVISEARCH   Func. wmupdtmd Look for indexes in 1D array.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !     Main program in which it is contained.
    !
    !  6. Error messages :
    !
    !       None.
    !
    !  7. Remarks :
    !
    !     -
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       -
    !
    ! 10. Source code :
    !
    INTEGER, INTENT(IN) :: X_LEN, Y_LEN
    REAL, DIMENSION(X_LEN), INTENT(IN) :: XARRAY
    REAL, DIMENSION(Y_LEN), INTENT(IN) :: YARRAY
    REAL, DIMENSION(X_LEN, Y_LEN), INTENT(IN) :: FUNC1, FUNC2
    REAL, INTENT(IN) :: X,Y
    REAL, INTENT(IN), OPTIONAL :: DELTA
    REAL, INTENT(OUT) :: VAL1,VAL2
 
    REAL :: DENOM, X1, X2, Y1, Y2,C1,C2,C3,C4
    INTEGER :: INX,JNX
 
    inx = xycurvisearch(x_len, xarray, x, delta)
    jnx = xycurvisearch(y_len, yarray, y, delta)
    !
    IF (inx .GE. x_len) THEN
      inx=inx-1
    END IF
    IF (jnx .GE. y_len) THEN
      jnx=jnx-1
    END IF
    !
    x1 = xarray(inx)
    x2 = xarray(inx+1)
    y1 = yarray(jnx)
    y2 = yarray(jnx+1)
    !
    denom = (x2 - x1)*(y2 - y1)
    c1=(x2-x)*(y2-y)
    c2=(x-x1)*(y2-y)
    c3=(x2-x)*(y-y1)
    c4=(x-x1)*(y-y1)
    val1 = (func1(inx,jnx)  *c1 + func1(inx+1,jnx)  *c2 +  &
         func1(inx,jnx+1)*c3 + func1(inx+1,jnx+1)*c4)/denom
 
    val2 = (func2(inx,jnx)  *c1 + func2(inx+1,jnx)  *c2 +  &
         func2(inx,jnx+1)*c3 + func2(inx+1,jnx+1)*c4)/denom
    !

References xycurvisearch().

Referenced by wmupdv().

wmupd1()

subroutine wmupdtmd::wmupd1	(	integer, intent(in)	IMOD,
		character(len=3), intent(in)	IDSTR,
		integer, intent(in)	J,
		integer, intent(out)	IERR
	)

Update selected input using native input files.

Reading from native grid files.

Parameters

[in]	IMOD	Model number.
[in]	IDSTR	ID string corresponding to J.
[in]	J	Input type.
[out]	IERR	Error indicator.

Author

H. L. Tolman

Date

22-Mar-2021

Definition at line 516 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         22-Mar-2021 |
    !/                  +-----------------------------------+
    !/
    !/    07-Oct-2006 : Origination.                        ( version 3.10 )
    !/    22-Mar-2021 : Add momentum and air density input  ( version 7.13 )
    !/
    !  1. Purpose :
    !
    !     Update selected input using native input files.
    !
    !  2. Method :
    !
    !     Reading from native grid files.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       IMOD    Int.   I   Model number,
    !       IDSTR   C*3    I   ID string corresponding to J.
    !       J       Int.   I   Input type.
    !       IERR    Int.   O   Error indicator.
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMDIMD    Subr. WMMDATMD Set dimension of data grids.
    !      W3FLDG    Subr. W3FLDSMD Get input field.
    !      W3FLDD    Subr.   Id.    Get input data.
    !      W3FLDM    Subr.   Id.    Get grid speed data.
    !      STRACE    Subr. W3ERVMD  Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMUPDT    Subr. WMUPDTMD Master inpu update routine.
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !  7. Remarks :
    !
    !     - Pointers set in calling routine.
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       !/S     Enable subroutine tracing.
    !       !/T     Enable test output
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !/
    USE wmmdatmd, ONLY: wmdimd
    USE w3fldsmd, ONLY: w3fldg, w3fldd, w3fldm
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    !/
    USE w3gdatmd, ONLY: nx, ny
#ifdef W3_SMC
    USE w3gdatmd, ONLY: fswnd, nsea
#endif
    USE w3wdatmd, ONLY: time
    USE w3idatmd, ONLY: tln, wlev, tc0, tcn, cx0, cxn, cy0, cyn,    &
         tw0, twn, tu0, tun, tr0, trn, wx0, wxn,     &
         wy0, wyn, dt0, dtn, tin, trn, icei, ux0,    &
         uxn, uy0, uyn, rh0, rhn, t0n, t1n, t2n,     &
         tdn, inflags1, tg0, tgn, ga0, gd0, gan,     &
         gdn, bergi, ttn, mudt, tvn, mudv, tzn,      &
         mudd, ti1, ti2, ti3, ti4, ti5, icep1,       &
         icep2, icep3, icep4, icep5
    USE wmmdatmd, ONLY: improc, nmperr, mdst, mdse, mdsf, etime,    &
         fllstl, fllsti, fllstr, rcld, ndt, data0,   &
         data1, data2, nmv, nmvmax, tmv, amv, dmv
    !/
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)          :: IMOD, J
    INTEGER, INTENT(OUT)         :: IERR
    CHARACTER(LEN=3), INTENT(IN) :: IDSTR
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: MDSEN, DTIME(2), NDTNEW
    REAL                    :: XXX(NY,NX)
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    ! 0.  Initialization
    ! 0.a Subroutine tracing and echo of input
    !
#ifdef W3_S
    CALL strace (ient, 'WMUPD1')
#endif
#ifdef W3_T
    WRITE (mdst,9000) imod, j
#endif
    !
    IF ( improc .EQ. nmperr ) THEN
      mdsen  = mdse
    ELSE
      mdsen  = -1
    END IF
    !
    ! 0.b Start case selection
    !
    SELECT CASE (j)
      !
      ! -7.  Ice parameter 1 ---------------------------------------------- /
      !
    CASE (-7)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, ti1, xxx, xxx, icep1, ierr)
      !
      ! -6.  Ice parameter 2 ---------------------------------------------- /
      !
    CASE (-6)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, ti2, xxx, xxx, icep2, ierr)
      !
      ! -5.  Ice parameter 3 ---------------------------------------------- /
      !
    CASE (-5)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, ti3, xxx, xxx, icep3, ierr)
      !
      ! -4.  Ice parameter 4 ---------------------------------------------- /
      !
    CASE (-4)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, ti4, xxx, xxx, icep4, ierr)
      !
      ! -3.  Ice parameter 5 ---------------------------------------------- /
      !
    CASE (-3)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, ti5, xxx, xxx, icep5, ierr)
      !
      ! -2.  Mud Density -------------------------------------------------- /
      !
    CASE (-2)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, tzn, xxx, xxx, mudd, ierr)
      !
      ! -1.  Mud Thickness -------------------------------------------------- /
      !
    CASE (-1)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, ttn, xxx, xxx, mudt, ierr)
      !
      ! 0.  Mud Viscosity -------------------------------------------------- /
      !
    CASE (0)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, tvn, xxx, xxx, mudv, ierr)
      !
      ! 1.  Water levels --------------------------------------------------- /
      !
    CASE (1)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, tln, xxx, xxx, wlev, ierr)
      IF ( ierr .LT. 0 ) fllstl = .true.
      !
      ! 2.  Currents ------------------------------------------------------- /
      !
    CASE (2)
#ifdef W3_SMC
      !!Li  For sea point current option FSWND.   JGLi08Feb2021
      IF( fswnd ) THEN
        CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
             nsea, 1, nsea, 1, time, etime, tc0,            &
             cx0, cy0, xxx, tcn, cxn, cyn, xxx, ierr)
      ELSE
#endif
        CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
             nx, ny, nx, ny, time, etime, tc0,              &
             cx0, cy0, xxx, tcn, cxn, cyn, xxx, ierr)
#ifdef W3_SMC
      END IF
#endif
      !
      ! 3.  Winds ---------------------------------------------------------- /
      !
    CASE (3)
#ifdef W3_SMC
      !!Li  For sea point wind option FSWND.   JGLi08Feb2021
      IF( fswnd ) THEN
        CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
             nsea, 1, nsea, 1, time, etime, tw0,            &
             wx0, wy0, dt0, twn, wxn, wyn, dtn, ierr)
      ELSE
#endif
        CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
             nx, ny, nx, ny, time, etime, tw0,              &
             wx0, wy0, dt0, twn, wxn, wyn, dtn, ierr)
#ifdef W3_SMC
      END IF
#endif
      !
      ! 4.  Ice ------------------------------------------------------------ /
      !
    CASE (4)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, dtime,            &
           xxx, xxx, xxx, tin, xxx , bergi, icei, ierr)
      IF ( ierr .LT. 0 ) fllsti = .true.
      !
      ! 5.  Momentum ------------------------------------------------------- /
      !
    CASE (5)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, tu0,              &
           ux0, uy0, xxx, tun, uxn, uyn, xxx, ierr)
      !
      ! 6.  Air density ---------------------------------------------------- /
      !
    CASE (6)
      CALL w3fldg ('READ', idstr, mdsf(imod,j), mdst, mdsen,      &
           nx, ny, nx, ny, time, etime, tr0,              &
           xxx, xxx, rh0, trn, xxx, xxx, rhn, ierr)
      IF ( ierr .LT. 0 ) fllstr = .true.
      !
      ! 7.  Data type 0 ---------------------------------------------------- /
      !
    CASE (7)
      CALL w3fldd ('SIZE', idstr, mdsf(imod,j), mdst, mdsen,      &
           time, t0n, rcld(1), ndt(1), ndtnew,           &
           data0, ierr )
      IF ( ierr .LT. 0 ) THEN
        inflags1(j) = .false.
        rcld(1)  = 1
        ndt(1)   = 1
        CALL wmdimd ( imod, mdse, mdst, 1 )
      ELSE
        ndt(j) = ndtnew
        CALL wmdimd ( imod, mdse, mdst, 1 )
        CALL w3fldd ('SIZE', idstr, mdsf(imod,j), mdst,         &
             mdsen, time, t0n, rcld(1), ndt(1),        &
             ndtnew, data0, ierr )
      END IF
      !
      ! 8.  Data type 1 ---------------------------------------------------- /
      !
    CASE ( 8 )
      CALL w3fldd ('SIZE', idstr, mdsf(imod,j), mdst, mdsen,      &
           time, t1n, rcld(2), ndt(2), ndtnew,           &
           data1, ierr )
      IF ( ierr .LT. 0 ) THEN
        inflags1(j) = .false.
        rcld(2)  = 1
        ndt(2)   = 1
        CALL wmdimd ( imod, mdse, mdst, 2 )
      ELSE
        ndt(j) = ndtnew
        CALL wmdimd ( imod, mdse, mdst, 2 )
        CALL w3fldd ('SIZE', idstr, mdsf(imod,j), mdst,         &
             mdsen, time, t1n, rcld(2), ndt(2),         &
             ndtnew, data1, ierr )
      END IF
      !
      ! 9.  Data type 2 ---------------------------------------------------- /
      !
    CASE ( 9 )
      CALL w3fldd ('SIZE', idstr, mdsf(imod,j), mdst, mdsen,      &
           time, t2n, rcld(3), ndt(3), ndtnew,           &
           data2, ierr )
      IF ( ierr .LT. 0 ) THEN
        inflags1(j) = .false.
        rcld(3)  = 1
        ndt(3)   = 1
        CALL wmdimd ( imod, mdse, mdst, 3 )
      ELSE
        ndt(j) = ndtnew
        CALL wmdimd ( imod, mdse, mdst, 3 )
        CALL w3fldd ('SIZE', idstr, mdsf(imod,j), mdst,         &
             mdsen, time, t2n, rcld(3), ndt(3),         &
             ndtnew, data2, ierr )
      END IF
      !
      ! 10. Moving grid data ---------------------------------------------- /
      !
    CASE ( 10 )
      ! notes:
      ! SUBROUTINE W3FLDM in w3fldsmd.ftn :
      !       INTEGER, INTENT(INOUT)  :: NH, THO(2,6,NHM), TF0(2), TFN(2)
      !       INTEGER, INTENT(INOUT)  :: NH, THO(2,-7:6,NHM), TF0(2), TFN(2)
      !       REAL, INTENT(INOUT)     :: HA(NHM,6), HD(NHM,6), A0, AN, D0, DN
      !       REAL, INTENT(INOUT)     :: HA(NHM,-7:6), HD(NHM,-7:6), A0, AN, D0, DN
      ! Arguments #
      !   THO     8
      !   HA      9
      !   HD     10
      ! Here, that is TMV AMV DMV
      CALL w3fldm ( 4, mdst, mdsen, time, etime, nmv, nmvmax, tmv,&
           amv, dmv, tg0, ga0, gd0, tgn, gan, gdn, ierr )
      !
    END SELECT
    !
    ! 9. End of routine -------------------------------------------------- /
    !
    RETURN
    !
    ! Formats
    !
#ifdef W3_T
9000 FORMAT ( ' TEST WMUPD1 : INPUT : ',2i4)
#endif
    !/
    !/ End of WMUPD1 ----------------------------------------------------- /
    !/

References wmmdatmd::amv, wmmdatmd::data0, wmmdatmd::data1, wmmdatmd::data2, wmmdatmd::dmv, w3idatmd::dt0, w3idatmd::dtn, wmmdatmd::etime, wmmdatmd::fllsti, wmmdatmd::fllstl, wmmdatmd::fllstr, w3gdatmd::fswnd, w3idatmd::ga0, w3idatmd::gan, w3idatmd::gd0, w3idatmd::gdn, wmmdatmd::improc, w3idatmd::inflags1, wmmdatmd::mdse, wmmdatmd::mdsf, wmmdatmd::mdst, wmmdatmd::ndt, wmmdatmd::nmperr, wmmdatmd::nmv, wmmdatmd::nmvmax, w3gdatmd::nsea, w3gdatmd::nx, w3gdatmd::ny, wmmdatmd::rcld, w3servmd::strace(), w3idatmd::t0n, w3idatmd::t1n, w3idatmd::t2n, w3idatmd::tc0, w3idatmd::tcn, w3idatmd::tdn, w3idatmd::tg0, w3idatmd::tgn, w3idatmd::ti1, w3idatmd::ti2, w3idatmd::ti3, w3idatmd::ti4, w3idatmd::ti5, w3wdatmd::time, w3idatmd::tin, w3idatmd::tln, wmmdatmd::tmv, w3idatmd::tr0, w3idatmd::trn, w3idatmd::ttn, w3idatmd::tu0, w3idatmd::tun, w3idatmd::tvn, w3idatmd::tw0, w3idatmd::twn, w3idatmd::tzn, w3fldsmd::w3fldd(), w3fldsmd::w3fldg(), w3fldsmd::w3fldm(), wmmdatmd::wmdimd(), w3idatmd::wx0, w3idatmd::wxn, w3idatmd::wy0, and w3idatmd::wyn.

Referenced by wmupdt().

wmupd2()

subroutine wmupdtmd::wmupd2	(	integer, intent(in)	IMOD,
		integer, intent(in)	J,
		integer, intent(in)	JMOD,
		integer, intent(out)	IERR
	)

Update selected input using input grids.

Managing data, interpolation done in other routines.

Parameters

[in]	IMOD	Model number.
[in]	J	Input type.
[in]	JMOD	Model number source grid.
[out]	IERR	Error indicator.

Author

H. L. Tolman

Date

22-Mar-2021

Definition at line 870 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         22-Mar-2021 |
    !/                  +-----------------------------------+
    !/
    !/    14-Oct-2006 : Origination.                        ( version 3.10 )
    !/    10-Dec-2006 : Bug fix WMUPD2 initial fields.      ( version 3.10 )
    !/    22-Mar-2021 : Add momentum and air density input  ( version 7.13 )
    !/
    !  1. Purpose :
    !
    !     Update selected input using input grids.
    !
    !  2. Method :
    !
    !     Managing data, interpolation done inother routines.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       IMOD    Int.   I   Model number,
    !       J       Int.   I   Input type.
    !       JMOD    Int.   I   Model number source grid.
    !       IERR    Int.   O   Error indicator.
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3ERVMD  Subroutine tracing.
    !      EXTCDE    Subr.   Id.    Program abort.
    !      WMUPDV    Subr.  local   Interpolation of vector fields.
    !      WMUPDS    Subr.  local   Interpolation of scalar fields.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMUPDT    Subr. WMUPDTMD Master input update routine.
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !  7. Remarks :
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       !/CRX0   Current vector component conservation.
    !       !/CRX1   Current speed conservation.
    !       !/CRX2   Current exenrgy conservation.
    !
    !       !/WNX0   Wind vector component conservation.
    !       !/WNX1   Wind speed conservation.
    !       !/WNX2   Wind exenrgy conservation.
    !
    !       !/S     Enable subroutine tracing.
    !       !/T     Enable test output
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !/
    USE w3servmd,  ONLY: extcde
#ifdef W3_S
    USE w3servmd,  ONLY: strace
#endif
    !/
    USE w3wdatmd,  ONLY: time
    USE w3idatmd,  ONLY: inputs
    USE wmmdatmd,  ONLY: improc, nmperr, nmpscr, mdst, mdse, mdss,  &
         mdso, etime, idinp
    USE constants, ONLY: dair
    !/
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)     :: IMOD, J, JMOD
    INTEGER, INTENT(OUT)    :: IERR
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: ICONSC, ICONSW, ICONSU
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    ! 0.  Initialization
    ! 0.a Subroutine tracing and echo of input
    !
#ifdef W3_S
    CALL strace (ient, 'WMUPD2')
#endif
    !
#ifdef W3_T
    WRITE (mdst,9000) imod, j, jmod
    WRITE (mdst,9001) inputs(imod)%TFN(:,j),                     &
         inputs(jmod)%TFN(:,j), etime
#endif
    !
    ierr = 0
#ifdef W3_CRX0
    iconsc = 0
#endif
#ifdef W3_CRX1
    iconsc = 1
#endif
#ifdef W3_CRX2
    iconsc = 2
#endif
#ifdef W3_WNX0
    iconsw = 0
#endif
#ifdef W3_WNX1
    iconsw = 1
#endif
#ifdef W3_WNX2
    iconsw = 2
#endif
#ifdef W3_WNX0
    iconsu = 0
#endif
#ifdef W3_WNX1
    iconsu = 1
#endif
#ifdef W3_WNX2
    iconsu = 2
#endif
    !
    ! 1. Shift fields ( currents and winds only ) ------------------------ /
    !
    SELECT CASE (j)
      !
      ! 1.a Currents
      !
    CASE (2)
      IF ( inputs(imod)%TFN(1,j) .GT. 0 ) THEN
        inputs(imod)%TC0(:) = inputs(imod)%TFN(:,j)
        inputs(imod)%CX0    = inputs(imod)%CXN
        inputs(imod)%CY0    = inputs(imod)%CYN
#ifdef W3_T
        WRITE (mdst,9010) j, inputs(imod)%TFN(:,j)
      ELSE
        WRITE (mdst,9011) j
#endif
      END IF
      !
      ! 1.b Winds
      !
    CASE (3)
      IF ( inputs(imod)%TFN(1,j) .GT. 0 ) THEN
        inputs(imod)%TW0(:) = inputs(imod)%TFN(:,j)
        inputs(imod)%WX0    = inputs(imod)%WXN
        inputs(imod)%WY0    = inputs(imod)%WYN
        inputs(imod)%DT0    = inputs(imod)%DTN
#ifdef W3_T
        WRITE (mdst,9010) j, inputs(imod)%TFN(:,j)
      ELSE
        WRITE (mdst,9011) j
#endif
      END IF
      !
      ! 1.c Momentum
      !
    CASE (5)
      IF ( inputs(imod)%TFN(1,j) .GT. 0 ) THEN
        inputs(imod)%TU0(:) = inputs(imod)%TFN(:,j)
        inputs(imod)%UX0    = inputs(imod)%UXN
        inputs(imod)%UY0    = inputs(imod)%UYN
#ifdef W3_T
        WRITE (mdst,9010) j, inputs(imod)%TFN(:,j)
      ELSE
        WRITE (mdst,9011) j
#endif
      END IF
      !
    END SELECT
    !
    ! 2. Process fields at ending time ----------------------------------- /
    !
#ifdef W3_T
    WRITE (mdst,9020) j, inputs(jmod)%TFN(:,j)
#endif
    inputs(imod)%TFN(:,j) = inputs(jmod)%TFN(:,j)
    !
    SELECT CASE (j)
      !
      ! 2.a-3 Ice parameter 1
      !
    CASE (-7)
      CALL wmupds ( imod, inputs(imod)%ICEP1,                      &
           jmod, inputs(jmod)%ICEP1, 0. )
      !
      ! 2.a-3 Ice parameter 2
      !
    CASE (-6)
      CALL wmupds ( imod, inputs(imod)%ICEP2,                      &
           jmod, inputs(jmod)%ICEP2, 0. )
      !
      ! 2.a-3 Ice parameter 3
      !
    CASE (-5)
      CALL wmupds ( imod, inputs(imod)%ICEP3,                      &
           jmod, inputs(jmod)%ICEP3, 0. )
      !
      ! 2.a-3 Ice parameter 4
      !
    CASE (-4)
      CALL wmupds ( imod, inputs(imod)%ICEP4,                      &
           jmod, inputs(jmod)%ICEP4, 0. )
      !
      ! 2.a-3 Ice parameter 5
      !
    CASE (-3)
 
      CALL wmupds ( imod, inputs(imod)%ICEP5,                      &
           jmod, inputs(jmod)%ICEP5, 0. )
      !
      ! 2.a-2 Mud densities
      !
    CASE (-2)
      CALL wmupds ( imod, inputs(imod)%MUDD,                      &
           jmod, inputs(jmod)%MUDD, 0. )
      !
      ! 2.a-1 Mud viscosities
      !
    CASE (-1)
      CALL wmupds ( imod, inputs(imod)%MUDT,                      &
           jmod, inputs(jmod)%MUDT, 0. )
      !
      ! 2.a-0 Mud thicknesses
      !
    CASE (0)
      CALL wmupds ( imod, inputs(imod)%MUDV,                      &
           jmod, inputs(jmod)%MUDV, 0. )
      !
      ! 2.a Water levels
      !
    CASE (1)
      CALL wmupds ( imod, inputs(imod)%WLEV,                      &
           jmod, inputs(jmod)%WLEV, 0. )
      !
      ! 2.b Curents
      !
    CASE (2)
      CALL wmupdv ( imod, inputs(imod)%CXN, inputs(imod)%CYN,     &
           jmod, inputs(jmod)%CXN, inputs(jmod)%CYN,     &
           0., iconsc )
      !
      ! 2.c Wind speeds
      !
    CASE (3)
      CALL wmupdv ( imod, inputs(imod)%WXN, inputs(imod)%WYN,     &
           jmod, inputs(jmod)%WXN, inputs(jmod)%WYN,     &
           0., iconsw )
      !
      IF ( idinp(imod,j) .EQ. 'WNS' ) CALL wmupds                 &
           ( imod, inputs(imod)%DTN,                       &
           jmod, inputs(jmod)%DTN, 0. )
      !
      ! 2.d Ice concentrations
      !
    CASE (4)
      CALL wmupds ( imod, inputs(imod)%ICEI,                      &
           jmod, inputs(jmod)%ICEI, 0. )
      IF ( idinp(imod,j) .EQ. 'ISI' ) CALL wmupds                 &
           ( imod, inputs(imod)%BERGI,                     &
           jmod, inputs(jmod)%BERGI, 0. )
      !
      ! 2.e Momentum
      !
    CASE (5)
      CALL wmupdv ( imod, inputs(imod)%UXN, inputs(imod)%UYN,     &
           jmod, inputs(jmod)%UXN, inputs(jmod)%UYN,     &
           0., iconsu )
      !
      ! 2.f Air density
      !
    CASE (6)
      CALL wmupds ( imod, inputs(imod)%RHN,                       &
           jmod, inputs(jmod)%RHN, dair )
      !
      ! 2.g Assimilation data 0
      !
    CASE (7)
      GOTO 2999
      !
      ! 2.h Assimilation data 1
      !
    CASE (8)
      GOTO 2999
      !
      ! 2.i Assimilation data 2
      !
    CASE (9)
      GOTO 2999
      !
    END SELECT
    !
    ! 3. Check and update first fields ( currents and winds only ) ------- /
    !
    SELECT CASE (j)
      !
      ! 3.a Currents
      !
    CASE (2)
      IF ( inputs(imod)%TC0(1) .LT. 0 ) THEN
        inputs(imod)%TC0(:) = inputs(jmod)%TC0(:)
#ifdef W3_T
        WRITE (mdst,9030) j, inputs(imod)%TC0(:)
#endif
#ifdef W3_CRX0
        iconsc = 0
#endif
#ifdef W3_CRX1
        iconsc = 1
#endif
#ifdef W3_CRX2
        iconsc = 2
#endif
        CALL wmupdv ( imod, inputs(imod)%CX0, inputs(imod)%CY0, &
             jmod, inputs(jmod)%CX0, inputs(jmod)%CY0, &
             0., iconsc )
      END IF
      !
      ! 3.b Winds
      !
    CASE (3)
      IF ( inputs(imod)%TW0(1) .LT. 0 ) THEN
        inputs(imod)%TW0(:) = inputs(jmod)%TW0(:)
#ifdef W3_T
        WRITE (mdst,9030) j, inputs(imod)%TW0(:)
#endif
#ifdef W3_WNX0
        iconsw = 0
#endif
#ifdef W3_WNX1
        iconsw = 1
#endif
#ifdef W3_WNX2
        iconsw = 2
#endif
        CALL wmupdv ( imod, inputs(imod)%WX0, inputs(imod)%WY0, &
             jmod, inputs(jmod)%WX0, inputs(jmod)%WY0, &
             0., iconsw )
        IF ( idinp(imod,j) .EQ. 'WNS' ) CALL wmupds             &
             ( imod, inputs(imod)%DT0,                   &
             jmod, inputs(jmod)%DT0, 0. )
      END IF
      !
      ! 3.c Momentum
      !
    CASE (5)
      IF ( inputs(imod)%TU0(1) .LT. 0 ) THEN
        inputs(imod)%TU0(:) = inputs(jmod)%TU0(:)
#ifdef W3_T
        WRITE (mdst,9030) j, inputs(imod)%TU0(:)
#endif
#ifdef W3_WNX0
        iconsu = 0
#endif
#ifdef W3_WNX1
        iconsu = 1
#endif
#ifdef W3_WNX2
        iconsu = 2
#endif
        CALL wmupdv ( imod, inputs(imod)%UX0, inputs(imod)%UY0, &
             jmod, inputs(jmod)%UX0, inputs(jmod)%UY0, &
             0., iconsu )
      END IF
      !
    END SELECT
    !
    ! 4. End of routine -------------------------------------------------- /
    !
    RETURN
    !
    ! Error escape locations
    !
2999 CONTINUE
    IF ( mdss.NE.mdso .AND. nmpscr.EQ.improc ) WRITE (mdse,1999)
    CALL extcde ( 2999 )
    RETURN
    !
    ! Formats
    !
1999 FORMAT (/' *** ERROR WMUPD2: OPTION NOT YET IMPLEMENTED ***'/)
    !
#ifdef W3_T
9000 FORMAT ( ' TEST WMUPD2 : INPUT : ',3i4)
9001 FORMAT ( ' TEST WMUPD2 : TIME OF IMOD : ',i9.8,1x,i6.6/      &
         '               TIME OF JMOD : ',i9.8,1x,i6.6/      &
         '               ENDING TIME  : ',i9.8,1x,i6.6)
9010 FORMAT ( ' TEST WMUPD2 : SHIFTING ',i1,' TIME = ',i8.8,i7.6)
9011 FORMAT ( ' TEST WMUPD2 : NO DATA FOR ',i1,' TO SHIFT')
9020 FORMAT ( ' TEST WMUPD2 : PROCESSING ',i1,' TIME = ',i8.8,i7.6)
9030 FORMAT ( ' TEST WMUPD2 : INITIAL FIELD FOR ',i1,             &
         ' TIME = ',i8.8,i7.6)
#endif
    !/
    !/ End of WMUPD2 ----------------------------------------------------- /
    !/

References constants::dair, wmmdatmd::etime, w3servmd::extcde(), wmmdatmd::idinp, wmmdatmd::improc, w3idatmd::inputs, wmmdatmd::mdse, wmmdatmd::mdso, wmmdatmd::mdss, wmmdatmd::mdst, wmmdatmd::nmperr, wmmdatmd::nmpscr, w3servmd::strace(), w3wdatmd::time, wmupds(), and wmupdv().

Referenced by wmupdt().

wmupds()

subroutine wmupdtmd::wmupds	(	integer, intent(in)	IMOD,
		real, dimension(nx,ny), intent(out)	FD,
		integer, intent(in)	JMOD,
		real, dimension(grids(jmod)%nx,grids(jmod)%ny), intent(in)	FDI,
		real, intent(in)	UNDEF
	)

Interpolate scalar field from input grid to model grid.

Interpolating or averaging from input grid.

Parameters

[in]	IMOD	Output model number
[out]	FD	Output scalar field
[in]	JMOD	Input model number
[in]	FDI	Input scalar field
[in]	UNDEF	Value for mapped out point and points not covered.

Author

H. L. Tolman

Date

06-Dec-2010

Definition at line 1986 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         06-Dec-2010 |
    !/                  +-----------------------------------+
    !/
    !/    14-Oct-2006 : Origination.                        ( version 3.10 )
    !/    12-Jan-2007 : General clean-up and bug fixes.     ( version 3.10 )
    !/    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)
    !/    11-May-2015 : Updates to 2-ways nestings for UG   ( version 5.08 )
    !/    01-Jul-2019 : Generalize output to curv grids     ( version 7.13 )
    !/                  (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA)
    !/
    !  1. Purpose :
    !
    !     Interpolate scalar field from input grid to model grid.
    !
    !  2. Method :
    !
    !     Interpolating or averaging from input grid.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       IMOD    Int.   I   Output model number,
    !       FD      Int.   O   Output scaler field.
    !       JMOD    Int.   I   Input model number,
    !       FDI     Int.   I   Input scaler field.
    !       UNDEF   Int.   I   Value for mapped out point and points not
    !                          covered.
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3ERVMD  Subroutine tracing.
    !      EXTCDE    Subr.   Id.    Program abort.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMUPD2    Subr. WMUPDTMD Input update routine.
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !  7. Remarks :
    !
    !     - Grid pointers for output grid need to be set externally.
    !     - If input grid does not cover point of target grid, target grid
    !       values are set to UNDEF.
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       !/S     Enable subroutine tracing.
    !       !/T     Enable test output
    !       !/T1    Test output interpolation data.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !/
    USE w3servmd, ONLY: extcde
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    !/
    USE w3gdatmd, ONLY: nx, ny, x0, y0, sx, sy, grids, flagll,      &
         gtype, rlgtype, clgtype, ungtype,           &
         iclose_none, iclose_smpl, iclose_trpl,      &
         hpfac, hqfac, xgrd, ygrd
    USE wmmdatmd, ONLY: improc, nmperr, nmpscr, mdst, mdse, mdso,   &
         mdss
    !/
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)     :: IMOD, JMOD
    REAL, INTENT(OUT)       :: FD(NX,NY)
    REAL, INTENT(IN)        :: FDI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY),  &
         UNDEF
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: IXO, IYO, IX, IY, IXF0, IXFN, IYF0,  &
         IYFN, IXS0, IXSN, IYS0, IYSN, IXS,   &
         MXA, MYA, J, J1, J2, IXC, IYC, JJ,   &
         JX, JY
 
    INTEGER                 :: NPOIX, NPOIY, I, CURVI               !RP
 
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    INTEGER, ALLOCATABLE    :: NXA(:,:), NYA(:,:)
    REAL                    :: XR, YR, R1, R2, RT, XFL, XFR, XSL,   &
         XSR, YFL, YFR, YSL, YSR
    REAL                    :: FDL, WTOT, WL
 
    REAL                    :: LONC, LATC,  SXYC,                   &
         XDI, DTOLER, VALUEINTER
 
    REAL, ALLOCATABLE       :: RXA(:,:), RYA(:,:)
 
 
    LOGICAL                 :: MAP1(NX,NY), MAP2(NX,NY),            &
         MAP3(NX,NY), FLAGUP
    !
    INTEGER, POINTER        :: NXI, NYI, MAP(:,:), MAPI(:,:)
 
    DOUBLE PRECISION, POINTER :: XGRDI(:,:), YGRDI(:,:), XGRDC(:,:), YGRDC(:,:)
    REAL, POINTER             :: HPFACI(:,:), HQFACI(:,:)  !RP
 
    REAL, POINTER           :: X0I, Y0I, SXI, SYI !RPXXX , HPFACI, HQFACI
    INTEGER, POINTER        :: ICLOSE
#ifdef W3_T1
    CHARACTER(LEN=17)       :: FORMAT1
#endif
    !/
    !/ ------------------------------------------------------------------- /
    ! 0.  Initialization
    ! 0.a Subroutine tracing and test output
    !
#ifdef W3_S
    CALL strace (ient, 'WMUPDS')
#endif
    !
    nxi    => grids(jmod)%NX
    nyi    => grids(jmod)%NY
    x0i    => grids(jmod)%X0
    y0i    => grids(jmod)%Y0
    sxi    => grids(jmod)%SX
    syi    => grids(jmod)%SY
    hpfaci => grids(jmod)%HPFAC
    hqfaci => grids(jmod)%HQFAC
    map    => grids(imod)%MAPSTA
    mapi   => grids(jmod)%MAPSTA
    iclose => grids(jmod)%ICLOSE
    !
    IF ( iclose .EQ. iclose_trpl ) THEN
      IF ( improc.EQ.nmperr ) WRITE(mdse,*)'SUBROUTINE WMUPDS IS'// &
           ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.'
      CALL extcde ( 1 )
    END IF
    !
#ifdef W3_T
    WRITE (mdst,9000) imod, nx, ny, x0, y0, sx, sy,              &
         jmod, nxi, nyi, x0i, y0i, sxi, syi, undef
#endif
    !
    ! 0.b Initialize fields
    !
    fd     = undef
    !
    curvi=0
    IF ( grids(imod)%GTYPE .EQ. clgtype .OR. &
         grids(jmod)%GTYPE .EQ. clgtype ) THEN
      curvi=1
    END IF
 
    ! 1. Case of identical resolution and coinciding grids --------------- /
    !
    IF(curvi .EQ. 0) THEN
      IF ( abs(sx/sxi-1.) .LT. 1.e-3                         .AND.    &
           abs(sy/syi-1.) .LT. 1.e-3                         .AND.    &
           abs(mod((abs(x0-x0i))/sx+0.5,1.)-0.5) .LT. 1.e-2  .AND.    &
           abs(mod((abs(y0-y0i))/sy+0.5,1.)-0.5) .LT. 1.e-2 ) THEN
        !
        ! 1.a Offsets
        !
        ixo    = nint((x0-x0i)/sx)
        !
        IF ( flagll ) THEN
          ixf0   = 1
          ixfn   = nx
          ixs0   = -999
          ixsn   = -999
        ELSE
          ixf0   = max(  1  , 1-ixo )
          ixfn   = min( nx  , nxi-ixo )
          ixs0   = max(  1  , 1+ixo )
          ixsn   = ixs0 + ixfn - ixf0
        END IF
        !
        iyo    = nint((y0-y0i)/sy)
        !
        iyf0   = max(  1  , 1-iyo )
        iyfn   = min( ny  , nyi-iyo )
        iys0   = max(  1  , 1+iyo )
        iysn   = iys0 + iyfn - iyf0
        !
#ifdef W3_T
        WRITE (mdst,9010) ixo, iyo, ixf0, ixfn, iyf0, iyfn,      &
             ixs0, ixsn, iys0, iysn
#endif
        !
        ! 1.b Fill arrays for sea points only
        !
        IF ( flagll ) THEN
          DO ix=ixf0, ixfn
            ixs    = 1 + nint( mod(                             &
                 1080.+x0+(real(ix)-0.5)*sx-x0i , 360. ) / sx - 0.5 )
            IF ( ixs .GT. nxi ) cycle
            fd(ix,iyf0:iyfn) = fdi(ixs,iys0:iysn)
          END DO
        ELSE
          DO ix=ixf0, ixfn
            ixs    = ix + ixo
            fd(ix,iyf0:iyfn) = fdi(ixs,iys0:iysn)
          END DO
        END IF
        !
        ! 1.c Return to calling routine
        !
        RETURN
        !
      END IF
    END IF !CURVI
    !
    ! 2.  General case --------------------------------------------------- /
    !
    !
    ! 2.a Curvilinear grids
    !
    IF ( grids(imod)%GTYPE .EQ. clgtype .OR. &
         grids(jmod)%GTYPE .EQ. clgtype ) THEN
 
      ! 2.a.1    Getting the info for reg and curvi grids
      xgrdi => grids(jmod)%XGRD !LONS FOR INPUT FIELD
      ygrdi => grids(jmod)%YGRD !LATS FOR INPUT FIELD
 
      !       GETTING THE INFO FOR THE CURVILINEAR GRID
      xgrdc => grids(imod)%XGRD     !LONS FOR CURVI GRID
      ygrdc => grids(imod)%YGRD     !LATS FOR CURVI GRID
      !HPFAC => GRIDS(IMOD)%HPFAC   !DELTAYGRDC(:,:)YGRDC(:,:)YGRDC(:,:)YGRDC(:,:)S IN LON FOR CURVI GRID
      !HQFAC => GRIDS(IMOD)%HQFAC   !DELTAS IN LAT FOR CURVI  GRID
 
      !  FOR NOW ONLY INTERPOLATION NOT AVERAGING THEN MXA=2
      mxa=2
      mya=2
      ALLOCATE ( nxa(nx,0:mxa) , rxa(nx,mxa) )
      nxa    = 0
      rxa    = 0.
      ALLOCATE ( nya(ny,0:mya) , rya(ny,mya) )
      nya    = 0
      rya    = 0.
      !
      !IS THE TOLERANCE USED TO DETERMINE IF TWO VALUES ARE EQUAL IN LOCATION
      dtoler = 1e-5
      ! 2.a.2  running over the curvilinear grid
      DO j=1,ny
        DO i=1,nx
          lonc=real(xgrdc(j,i))   !LON FOR EVERY CURVL GRID POINT
          latc=real(ygrdc(j,i))   !LAT FOR EVERY CURVL GRID POINT
          !SXC  =HPFAC(J,I)  !DELTA IN LON FOR CURVI GRID
          !SYC  =HQFAC(J,I)  !DELTA IN LAT FOR CURVI GRID
 
          valueinter=interpolate(nxi,real(xgrdi(1,:)),nyi,real(ygrdi(:,1)),  &
               fdi,lonc,latc,dtoler)
          fd(i,j)=valueinter
        END DO  !END I
      END DO  !END J
 
    ELSE
      !
      ! 2.b Rectilinear grids
      !
      ! 2.b.1 Interpolation / averaging data for X axis
      !
      IF ( sx/sxi .LT. 1.0001 ) THEN
        mxa    = 2
      ELSE
        mxa    = 2 + int(sx/sxi)
      END IF
      !
#ifdef W3_T
      WRITE (mdst,9020) 'X'
#endif
#ifdef W3_T1
      format1 = '(10X,  I5,  F6.2)'
      WRITE (format1,'(A,I2,A,I2,A)') "'(10X,",mxa+1,'I5,',mxa+1,"F6.2)'"
      WRITE (mdst,9021) nx, mxa
#endif
      !
      ALLOCATE ( nxa(nx,0:mxa) , rxa(nx,mxa) )
      nxa    = 0
      rxa    = 0.
      !
      !
      IF ( mxa .EQ. 2 ) THEN
        !
        DO ix=1, nx
          IF ( flagll ) THEN
            xr     = 1. + mod       &
                 ( 1080.+x0+real(ix-1)*sx-x0i , 360. ) / sxi
          ELSE
            xr     = 1. + ( x0+real(ix-1)*sx - x0i ) / sxi
          END IF
          IF ( xr.GT.0. ) THEN
            j1     = int(xr)
            j2     = j1 + 1
            r2     = max( 0. , xr-real(j1) )
            r1     = 1. - r2
            IF ( flagll .AND. iclose.NE.iclose_none ) THEN
              j1 = 1 + mod(j1-1,nxi)
              j2 = 1 + mod(j2-1,nxi)
            END IF
            IF ( j1.GE.1 .AND. j1.LE.nxi .AND. r1.GT.0.05 ) THEN
              nxa(ix,0) = nxa(ix,0) + 1
              nxa(ix,nxa(ix,0)) = j1
              rxa(ix,nxa(ix,0)) = r1
            END IF
            IF ( j2.GE.1 .AND. j2.LE.nxi .AND. r2.GT.0.05 ) THEN
              nxa(ix,0) = nxa(ix,0) + 1
              nxa(ix,nxa(ix,0)) = j2
              rxa(ix,nxa(ix,0)) = r2
            END IF
            IF ( nxa(ix,0)  .GT. 0 ) THEN
              rt     = sum( rxa(ix,:) )
              IF ( rt .LT. 0.7 ) THEN
                nxa(ix,:) = 0
                rxa(ix,:) = 0.
              END IF
            END IF
          END IF
        END DO
        !
      ELSE
        !
        DO ix=1, nx
          !
          xfl    = x0 + real(ix-1)*sx - 0.5*sx
          xfr    = x0 + real(ix-1)*sx + 0.5*sx
          IF ( flagll ) THEN
            ixc    = 1 + nint( mod(                             &
                 1080.+x0+real(ix-1)*sx-x0i , 360. ) / sxi )
            ixs0   = ixc - 1 - mxa/2
            ixsn   = ixc + 1 + mxa/2
          ELSE
            ixc    = nint( 1. + ( x0+real(ix-1)*sx - x0i ) / sxi )
            ixs0   = max(  1  , ixc - 1 - mxa/2 )
            ixsn   = min( nxi , ixc + 1 + mxa/2 )
          END IF
          DO j=ixs0, ixsn
            IF ( flagll ) THEN
              IF ( iclose.NE.iclose_none ) jj = 1 + mod(j-1+nxi,nxi)
              IF ( jj.LT.1 .OR. jj.GT. nxi ) cycle
              ixc   = nint((0.5*(xfl+xfr)-x0i-real(jj-1)*sxi)/360.)
              IF ( ixc .NE. 0 ) THEN
                xfl    = xfl - real(ixc) * 360.
                xfr    = xfr - real(ixc) * 360.
              END IF
            ELSE
              jj     = j
            END IF
            xsl    = max( xfl , x0i + real(jj-1)*sxi - 0.5*sxi )
            xsr    = min( xfr , x0i + real(jj-1)*sxi + 0.5*sxi )
            r1     = max( 0. , xsr - xsl ) / sx
            IF ( r1 .GT. 0 ) THEN
              nxa(ix,0) = nxa(ix,0) + 1
              nxa(ix,nxa(ix,0)) = jj
              rxa(ix,nxa(ix,0)) = r1
            END IF
          END DO
          IF ( nxa(ix,0)  .GT. 0 ) THEN
            rt     = sum( rxa(ix,:) )
            IF ( rt .LT. 0.7 ) THEN
              nxa(ix,:) = 0
              rxa(ix,:) = 0.
            END IF
          END IF
        END DO
        !
      END IF
      !
#ifdef W3_T1
      DO, ix=1, nx
        IF ( nxa(ix,0) .GT. 0 ) WRITE (mdst,format1)                &
             ix, nxa(ix,1:mxa), rxa(ix,1:mxa), sum(rxa(ix,1:mxa))
      END DO
#endif
      !
      ! 2.b.2 Interpolation / averaging data for Y axis
      !
      IF ( sy/syi .LT. 1.0001 ) THEN
        mya    = 2
      ELSE
        mya    = 2 + int(sy/syi)
      END IF
      !
#ifdef W3_T
      WRITE (mdst,9020) 'Y'
#endif
#ifdef W3_T1
      WRITE (format1,'(A,I2,A,I2,A)') "'(10X,",mya+1,'I5,',mya+1,"F6.2)'"
      WRITE (mdst,9021) ny, mya
#endif
      !
      ALLOCATE ( nya(ny,0:mya) , rya(ny,mya) )
      nya    = 0
      rya    = 0.
      !
      !
      IF ( mya .EQ. 2 ) THEN
        !
        DO iy=1, ny
          yr     = 1. + ( y0+real(iy-1)*sy - y0i ) / syi
          IF ( yr.GT.0. ) THEN
            j1     = int(yr)
            j2     = j1 + 1
            r2     = max( 0. , yr-real(j1) )
            r1     = 1. - r2
            IF ( j1.GE.1 .AND. j1.LE.nyi .AND. r1.GT.0.05 ) THEN
              nya(iy,0) = nya(iy,0) + 1
              nya(iy,nya(iy,0)) = j1
              rya(iy,nya(iy,0)) = r1
            END IF
            IF ( j2.GE.1 .AND. j2.LE.nyi .AND. r2.GT.0.05 ) THEN
              nya(iy,0) = nya(iy,0) + 1
              nya(iy,nya(iy,0)) = j2
              rya(iy,nya(iy,0)) = r2
            END IF
            IF ( nya(iy,0)  .GT. 0 ) THEN
              rt     = sum( rya(iy,:) )
              IF ( rt .LT. 0.7 ) THEN
                nya(iy,:) = 0
                rya(iy,:) = 0.
              END IF
            END IF
          END IF
        END DO
        !
      ELSE
        !
        DO iy=1, ny
          yfl    = y0 + real(iy-1)*sy - 0.5*sy
          yfr    = y0 + real(iy-1)*sy + 0.5*sy
          iyc    = nint( 1. + ( y0+real(iy-1)*sy - y0i ) / syi )
          iys0   = max(  1  , iyc - 1 - mya/2 )
          iysn   = min( nyi , iyc + 1 + mya/2 )
          DO j=iys0, iysn
            ysl    = max( yfl , y0i + real(j-1)*syi - 0.5*syi )
            ysr    = min( yfr , y0i + real(j-1)*syi + 0.5*syi )
            r1     = max( 0. , ysr - ysl ) / sy
            IF ( r1 .GT. 0 ) THEN
              nya(iy,0) = nya(iy,0) + 1
              nya(iy,nya(iy,0)) = j
              rya(iy,nya(iy,0)) = r1
            END IF
          END DO
          IF ( nya(iy,0)  .GT. 0 ) THEN
            rt     = sum( rya(iy,:) )
            IF ( rt .LT. 0.7 ) THEN
              nya(iy,:) = 0
              rya(iy,:) = 0.
            END IF
          END IF
        END DO
        !
      END IF
      !
    END IF
    !
#ifdef W3_T1
    DO, iy=1, ny
      IF ( nya(iy,0) .GT. 0 ) WRITE (mdst,format1)                &
           iy, nya(iy,1:mya), rya(iy,1:mya), sum(rya(iy,1:mya))
    END DO
#endif
    !
    ! 2.c Process grid
    !
    map1   = .false.
    map2   = .false.
    !
    DO ix=1, nx
      IF ( nxa(ix,0) .EQ. 0 ) cycle
      DO iy=1, ny
        IF ( nya(iy,0) .EQ. 0 ) cycle
        IF ( map(iy,ix).NE.0 ) THEN
          fdl    = 0.
          wtot   = 0.
          DO j1=1, nxa(ix,0)
            jx     = nxa(ix,j1)
            DO j2=1, nya(iy,0)
              jy     = nya(iy,j2)
              IF ( mapi(jy,jx) .NE. 0 ) THEN
                wl     = rxa(ix,j1) * rya(iy,j2)
                wtot   = wtot + wl
                fdl    = fdl + wl * fdi(jx,jy)
              END IF
            END DO
          END DO
          IF ( wtot .LT. 0.05 ) THEN
            map1(ix,iy) = .true.
          ELSE
            map2(ix,iy) = .true.
            fdl    = fdl / wtot
            fd(ix,iy) = fdl
          END IF
        END IF
      END DO
    END DO
    !
    ! 2.d Reconcile mask differences
    !
#ifdef W3_T
    WRITE (mdst,9022)
#endif
    !
    jj     = 0
    iclose => grids(imod)%ICLOSE
    !
    DO
      IF ( jj .GT. swpmax ) EXIT
      flagup = .false.
      map3   = .false.
      jj     = jj + 1
#ifdef W3_T
      WRITE (mdst,9023) jj
#endif
      DO ix=1, nx
        DO iy=1, ny
          IF ( map1(ix,iy) ) THEN
            fdl    = 0.
            j1     = 0
            IF ( flagll ) THEN
              DO j2=ix-1, ix+1
                IF ( (j2.GT.1 .AND. j2.LE.nx) .OR. iclose.NE.iclose_none ) THEN
                  jx     = 1 + mod(nx+j2-1,nx)
                  DO jy=iy-1, iy+1
                    IF ( jy.GT.1 .AND. jy.LE.ny ) THEN
                      IF ( map2(jx,jy) ) THEN
                        fdl     = fdl + fd(jx,jy)
                        j1      = j1 + 1
                      END IF
                    END IF
                  END DO
                END IF
              END DO
            ELSE
              DO jx=ix-1, ix+1
                IF ( jx.GT.1 .AND. jx.LE.nx ) THEN
                  DO jy=iy-1, iy+1
                    IF ( jy.GT.1 .AND. jy.LE.ny ) THEN
                      IF ( map2(jx,jy) ) THEN
                        fdl     = fdl + fd(jx,jy)
                        j1      = j1 + 1
                      END IF
                    END IF
                  END DO
                END IF
              END DO
            END IF !FLAGLL
            IF ( j1 .GT. 0 ) THEN
              fd(ix,iy) = fdl / real(j1)
              map1(ix,iy) = .false.
              map3(ix,iy) = .true.
              flagup = .true.
            END IF
          END IF
        END DO
      END DO
      IF ( flagup ) THEN
        map2   = map2 .OR. map3
      ELSE
        EXIT
      END IF
    END DO
    !
    ! 3. End of routine -------------------------------------------------- /
    !
    DEALLOCATE ( nxa, nya, rxa, rya )
    !
    RETURN
    !
    ! Formats
    !
#ifdef W3_T
9000 FORMAT ( ' TEST WMUPDS : GRID INFORMATION : '/               &
         '             ',3i5,4e11.3/                         &
         '             ',3i5,4e11.3/                         &
         '               UNDEFINED = ',e10.3)
9010 FORMAT ( ' TEST WMUPDS : COINCIDING GRIDS, OFFSETS :',2i6/   &
         '               TARGET GRID RANGES        :',4i6/   &
         '               SOURCE GRID RANGES        :',4i6)
9020 FORMAT ( ' TEST WMUPDS : WEIGHTS FOR ',a,' INTERPOATION')
#endif
#ifdef W3_T1
9021 FORMAT ( ' TEST WMUPDS : ARAY DIMENSIONED AS : ',2i6)
#endif
#ifdef W3_T
9022 FORMAT ( ' TEST WMUPDS : RECONCILING MASKS')
9023 FORMAT ( '               SWEEP NR ',i4)
#endif
    !/
    !/ End of WMUPDS ----------------------------------------------------- /
    !/

References w3gdatmd::clgtype, w3servmd::extcde(), w3gdatmd::flagll, w3gdatmd::grids, w3gdatmd::gtype, w3gdatmd::hpfac, w3gdatmd::hqfac, w3gdatmd::iclose_none, w3gdatmd::iclose_smpl, w3gdatmd::iclose_trpl, wmmdatmd::improc, interpolate(), wmmdatmd::mdse, wmmdatmd::mdso, wmmdatmd::mdss, wmmdatmd::mdst, wmmdatmd::nmperr, wmmdatmd::nmpscr, w3gdatmd::nx, w3gdatmd::ny, w3gdatmd::rlgtype, w3servmd::strace(), swpmax, w3gdatmd::sx, w3gdatmd::sy, w3gdatmd::ungtype, w3gdatmd::x0, w3gdatmd::xgrd, w3gdatmd::y0, and w3gdatmd::ygrd.

Referenced by wmupd2().

wmupdt()

subroutine wmupdtmd::wmupdt	(	integer, intent(in)	IMOD,
		integer, dimension(2), intent(inout)	TDATA
	)

Update inputs for selected wave model grid.

Reading from native grid files if update is needed based on time of data.

Parameters

[in]	IMOD	Model number
[in,out]	TDATA	Time for which all is data available.

Author

H. L. Tolman

Date

22-Mar-2021

Definition at line 103 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         22-Mar-2021 |
    !/                  +-----------------------------------+
    !/
    !/    22-Feb-2005 : Origination.                        ( version 3.07 )
    !/    14-Oct-2006 : Adding separate input grids.        ( version 3.10 )
    !/    12-Jan-2007 : General clean-up and bug fixes.     ( version 3.10 )
    !/    20-Jan-2017 : Enable using input from coupler     ( version 6.02 )
    !/                  (T. J. Campbell, NRL)
    !/    22-Mar-2021 : Add momentum and air density input  ( version 7.13 )
    !/
    !  1. Purpose :
    !
    !     Update inputs for seleceted wave model grid.
    !
    !  2. Method :
    !
    !     Reading from native grid files if update is needed based on
    !     time of data.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       IMOD    Int.   I   Model number,
    !       TDATA   I.A.   I   Time for which all is data available.
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      W3SETG    Subr. W3GDATMD Point to grid/model.
    !      W3SETW    Subr. W3WDATMD Point to grid/model.
    !      W3SETI    Subr. W3IDATMD Point to grid/model.
    !      WMSETM    Subr. WMMDATMD Point to grid/model.
    !      STRACE    Subr. W3ERVMD  Subroutine tracing.
    !      EXTCDE    Subr.   Id.    Program abort.
    !      DSEC21    Func. W3TIMEMD Time difference.
    !      STME21    Subr.   Id.    Write time string.
    !      TICK21    Subr.   Id.    Advancing time.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMWAVE    Subr. WMWAVEMD Multi-grid model main routine.
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !  7. Remarks :
    !
    !     - IDFLDS dimensioning is hardwired as IDFLDS(-7:9) where
    !       lowest possible value of JFIRST is JFIRST=-7
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       !/S     Enable subroutine tracing.
    !       !/T     Enable test output
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !/
    USE w3gdatmd, ONLY: w3setg
    USE w3wdatmd, ONLY: w3setw
    USE w3idatmd, ONLY: w3seti
    USE wmmdatmd, ONLY: wmsetm
    USE w3servmd, ONLY: extcde
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    USE w3timemd, ONLY: dsec21, stme21, tick21
    !/
    USE w3gdatmd, ONLY: nx, ny, filext
    USE w3wdatmd, ONLY: time
 
    USE w3idatmd, ONLY: inflags1, tln, tc0, tcn, tw0, twn, tu0,     &
         tun, tr0, trn, tin, t0n, t1n, t2n, tg0,     &
         tgn, tfn, tdn, ttn, tvn, tzn, ti1, ti2,     &
         ti3, ti4, ti5, jfirst
 
    USE wmmdatmd, ONLY: improc, mdso, mdss, mdst, mdse, nmpscr,     &
         nmperr, etime, fllstl, fllstr, fllsti,      &
         inpmap, idinp, iflsti, iflstl, iflstr
    !/
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)     :: IMOD
    INTEGER, INTENT(INOUT)  :: TDATA(2)
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: MDSEN, J, DTIME(2), IERR, NDTNEW, JJ
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    REAL                    :: DTTST
    LOGICAL                 :: FIRST
    CHARACTER(LEN=13)       :: IDFLDS(-7:10)
    CHARACTER(LEN=23)       :: DTME21
    !
    DATA idflds / 'ice param. 1 ' , 'ice param. 2 ' ,               &
         'ice param. 3 ' , 'ice param. 4 ' ,               &
         'ice param. 5 ' ,                                 &
         'mud density  ' , 'mud thkness  ' ,               &
         'mud viscos.  ' ,                                 &
         'water levels ' , 'currents     ' ,               &
         'winds        ' , 'ice fields   ' ,               &
         'momentum     ' , 'air density  ' ,               &
         'mean param.  ' , '1D spectra   ' ,               &
         '2D spectra   ' , 'grid speed   ' /
    !/
    !/ ------------------------------------------------------------------- /
    ! 0.  Initialization
    ! 0.a Subroutine tracing and echo of input
    !
#ifdef W3_S
    CALL strace (ient, 'WMUPDT')
#endif
#ifdef W3_T
    WRITE (mdst,9000) imod, tdata
#endif
    !
    IF ( improc .EQ. nmperr ) THEN
      mdsen  = mdse
    ELSE
      mdsen  = -1
    END IF
    !
    ! 0.b Point to proper grids and initialize
    !
    CALL w3setg ( imod, mdse, mdst )
    CALL w3setw ( imod, mdse, mdst )
    CALL w3seti ( imod, mdse, mdst )
    CALL wmsetm ( imod, mdse, mdst )
    !
    fllstl = .false.
    fllsti = .false.
    fllstr = .false.
    ierr   = 0
    !
    ! 0.c Output
    !
    IF ( mdss.NE.mdso .AND. nmpscr.EQ.improc ) THEN
      CALL stme21 ( time , dtme21 )
      WRITE (mdss,900) imod, dtme21
    END IF
    !
#ifdef W3_T
    WRITE (mdst,9001) ' J', '0-N', time, etime
    IF (lbound(idinp,2).LE.-7) WRITE (mdst,9002) -7, idinp(imod,-7), inflags1(-7), ti1
    IF (lbound(idinp,2).LE.-6) WRITE (mdst,9002) -6, idinp(imod,-6), inflags1(-6), ti2
    IF (lbound(idinp,2).LE.-5) WRITE (mdst,9002) -5, idinp(imod,-5), inflags1(-5), ti3
    IF (lbound(idinp,2).LE.-4) WRITE (mdst,9002) -4, idinp(imod,-4), inflags1(-4), ti4
    IF (lbound(idinp,2).LE.-3) WRITE (mdst,9002) -3, idinp(imod,-3), inflags1(-3), ti5
    IF (lbound(idinp,2).LE.-2) WRITE (mdst,9002) -2, idinp(imod,-2), inflags1(-2), tzn
    IF (lbound(idinp,2).LE.-1) WRITE (mdst,9002) -1, idinp(imod,-1), inflags1(-1), ttn
    IF (lbound(idinp,2).LE. 0) WRITE (mdst,9002)  0, idinp(imod, 0), inflags1( 0), tvn
    WRITE (mdst,9002) 1, idinp(imod,1), inflags1(1), tln
    WRITE (mdst,9003) 2, idinp(imod,2), inflags1(2), tc0, tcn
    WRITE (mdst,9003) 3, idinp(imod,3), inflags1(3), tw0, twn
    WRITE (mdst,9002) 4, idinp(imod,4), inflags1(4), tin
    WRITE (mdst,9003) 5, idinp(imod,5), inflags1(5), tu0, tun
    WRITE (mdst,9003) 6, idinp(imod,6), inflags1(6), tr0, trn
    WRITE (mdst,9002) 7, idinp(imod,7), inflags1(7), t0n
    WRITE (mdst,9002) 8, idinp(imod,8), inflags1(8), t1n
    WRITE (mdst,9002) 9, idinp(imod,9), inflags1(9), t2n
    WRITE (mdst,9003) 10, 'MOV'        , inflags1(10), tg0, tgn
    WRITE (mdst,9004)    'GRD', nx, ny
#endif
    !
    ! 1.  Loop over input types ------------------------------------------ /
    !
    DO j=jfirst, 10
      !
      ! 1.a Check if update needed
      !
      IF ( .NOT. inflags1(j) ) cycle
      !
#ifdef W3_T
      WRITE (mdst,9010) j, inflags1(j), inpmap(imod,j)
#endif
      !
      ! 1.b Test time
      !
      IF ( tfn(1,j) .EQ. -1 ) THEN
        first  = .true.
        dttst  = 0.
      ELSE
        first  = .false.
        dttst  = dsec21( time , tfn(:,j) )
      END IF
      !
#ifdef W3_T
      WRITE (mdst,9011) idinp(imod,j), dttst, tfn(:,j)
#endif
      !
      IF ( dttst .GT. 0. ) cycle
      IF ( mdss.NE.mdso .AND. nmpscr.EQ.improc )                    &
           WRITE (mdss,901) idflds(j)
      !
      ! 2.  Forcing input from file & defined on the native grid ----------- /
      !
      IF ( inpmap(imod,j) .EQ. 0 ) THEN
        !
#ifdef W3_T
        WRITE (mdst,9020)
#endif
        !
        CALL wmupd1 ( imod, idinp(imod,j), j, ierr )
        !
        ! 3.  Forcing input from file & defined on an input grid ------------- /
        !
      ELSE IF ( inpmap(imod,j) .GT. 0 ) THEN
        !
#ifdef W3_T
        WRITE (mdst,9030) inpmap(imod,j)
#endif
        !
        ! 3.a Check if input grid is available
        !
        jj     = -inpmap(imod,j)
        CALL w3setg ( jj, mdse, mdst )
        CALL w3seti ( jj, mdse, mdst )
        !
        IF ( tfn(1,j) .EQ. -1 ) THEN
          dttst  = 0.
        ELSE
          IF ( first .OR. ( j.EQ.1 .AND. iflstl(-jj) )          &
               .OR. ( j.EQ.4 .AND. iflsti(-jj) )          &
               .OR. ( j.EQ.6 .AND. iflstr(-jj) ) ) THEN
            dttst  = 1.
          ELSE
            dttst  = dsec21( time , tfn(:,j) )
          END IF
        END IF
        !
        IF ( j .EQ. 1 ) fllstl = iflstl(-jj)
        IF ( j .EQ. 4 ) fllsti = iflsti(-jj)
        IF ( j .EQ. 6 ) fllstr = iflstr(-jj)
        !
#ifdef W3_T
        WRITE (mdst,9031) j, idinp(jj,j), dttst, tfn(:,j)
#endif
        !
        ! 3.b If needed, update input grid
        !     Note: flags in WMMDATMD set for grid IMOD !
        !
        IF ( dttst .LE. 0. ) THEN
          !
          IF ( mdss.NE.mdso .AND. nmpscr.EQ.improc )            &
               WRITE (mdss,930) filext
          !
          CALL wmupd1 ( jj, idinp(jj,j), j, ierr )
          !
          IF ( j .EQ. 1 ) iflstl(-jj) = fllstl
          IF ( j .EQ. 4 ) iflsti(-jj) = fllsti
          IF ( j .EQ. 6 ) iflstr(-jj) = fllstr
          !
        END IF
        !
        ! 3.c Set up for update, and call updating routine
        !
        CALL w3setg ( imod, mdse, mdst )
        CALL w3seti ( imod, mdse, mdst )
        !
        CALL wmupd2 ( imod, j, jj, ierr )
        !
        ! 4.  Forcing input from CPL ----------------------------------------- /
        !
      ELSE ! INPMAP(IMOD,J) .LT. 0
        ! Data input and time stamp settings for forcing input from
        ! CPL are handled in wmesmfmd.ftn:GetImport
        !
#ifdef W3_T
        IF ( inpmap(imod,j) .EQ. -999 ) THEN
          ! *** Forcing input from CPL & defined on native grid ***
          WRITE (mdst,9040)
        ELSE
          ! *** Forcing input from CPL & defined on an input grid ***
          WRITE (mdst,9050) -inpmap(imod,j)
        END IF
#endif
        !
      END IF
      !
      ! 5.  Finalize for each type ----------------------------------------- /
      ! 5.a Process IERR output
      !
      IF ( ierr.GT.0 ) GOTO 2000
      IF ( ierr.LT.0 .AND. mdss.NE.mdso .AND. nmpscr.EQ.improc )    &
           WRITE (mdss,950) idflds(j)
      !
      ! 5.b End of master loop
      !
    END DO
    !
    ! 6.  Compute TDATA -------------------------------------------------- /
    !
    tdata  = etime
    !
    DO j=jfirst, 10
      IF ( .NOT. inflags1(j) ) cycle
      dttst  = dsec21( tfn(:,j) , tdata )
      IF ( dttst.GT.0. .AND. .NOT.  ( (fllstl .AND. j.EQ.1) .OR.    &
           (fllsti .AND. j.EQ.4) .OR.    &
           (fllstr .AND. j.EQ.6) ) ) THEN
        tdata  = tfn(:,j)
      END IF
    END DO
    !
    ! 6.  Compute TDN ---------------------------------------------------- /
    !
    tdn    = tdata
    CALL tick21 ( tdn, 1. )
    DO j=7, 9
      IF ( inflags1(j) ) THEN
        dttst  = dsec21( tfn(:,j) , tdn )
        IF ( dttst.GT.0. ) tdn = tfn(:,j)
      END IF
    END DO
    !
    ! 7.  Final test output ---------------------------------------------- /
    !
#ifdef W3_T
    WRITE (mdst,9070) ' J', '0-N', time, etime, tdata
    IF (lbound(idinp,2).LE.-7) WRITE (mdst,9071) -7, idinp(imod,-7), inflags1(-7), ti1
    IF (lbound(idinp,2).LE.-6) WRITE (mdst,9071) -6, idinp(imod,-6), inflags1(-6), ti2
    IF (lbound(idinp,2).LE.-5) WRITE (mdst,9071) -5, idinp(imod,-5), inflags1(-5), ti3
    IF (lbound(idinp,2).LE.-4) WRITE (mdst,9071) -4, idinp(imod,-4), inflags1(-4), ti4
    IF (lbound(idinp,2).LE.-3) WRITE (mdst,9071) -3, idinp(imod,-3), inflags1(-3), ti5
    IF (lbound(idinp,2).LE.-2) WRITE (mdst,9071) -2, idinp(imod,-2), inflags1(-2), tzn
    IF (lbound(idinp,2).LE.-1) WRITE (mdst,9071) -1, idinp(imod,-1), inflags1(-1), ttn
    IF (lbound(idinp,2).LE. 0) WRITE (mdst,9071)  0, idinp(imod, 0), inflags1( 0), tvn
    WRITE (mdst,9071) 1, idinp(imod,1), inflags1(1), tln
    WRITE (mdst,9072) 2, idinp(imod,2), inflags1(2), tc0, tcn
    WRITE (mdst,9072) 3, idinp(imod,3), inflags1(3), tw0, twn
    WRITE (mdst,9071) 4, idinp(imod,4), inflags1(4), tin
    WRITE (mdst,9072) 5, idinp(imod,5), inflags1(5), tu0, tun
    WRITE (mdst,9072) 6, idinp(imod,6), inflags1(6), tr0, trn
    WRITE (mdst,9071) 7, idinp(imod,7), inflags1(7), t0n
    WRITE (mdst,9071) 8, idinp(imod,8), inflags1(8), t1n
    WRITE (mdst,9073) 9, idinp(imod,9), inflags1(9), t2n, tdn
    WRITE (mdst,9072) 10, 'MOV'        , inflags1(10), tg0, tgn
#endif
    !
    RETURN
    !
    ! Error escape locations
    !
2000 CONTINUE
    CALL extcde ( 2000 )
    RETURN
    !
    ! Formats
    !
900 FORMAT ( '  Updating input for grid',i3,' at ',a)
901 FORMAT ( '     Updating ',a)
930 FORMAT ( '        First updating ',a)
950 FORMAT ( '        Past last ',a)
    !
#ifdef W3_T
9000 FORMAT ( ' TEST WMUPDT : INPUT : ',i4,i10.8,i7.6,            &
         '  <============================')
9001 FORMAT ( ' TEST WMUPDT : ',a2,1x,a3,3x,    2(i10.8,i7.6))
9002 FORMAT ( '               ',i2,1x,a3,l3,17x,1(i10.8,i7.6))
9003 FORMAT ( '               ',i2,1x,a3,l3,    2(i10.8,i7.6))
9004 FORMAT ( '               ',2x,1x,a3,3x,2i10             )
9010 FORMAT ( ' TEST WMUPDT : J, FLAG, INPMAP : ',i2,l2,i4)
9011 FORMAT ( ' TEST WMUPDT : ',a,', DTTST = ',e10.3,2x,i9.8,i7.6)
9020 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON THE NATIVE GRID')
9030 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON INPUT GRID',i4)
9031 FORMAT ( ' TEST WMUPDT : J =',i4,3xa,', DTTST = ',           &
         e10.3,2x,i9.8,i7.6)
9040 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON THE NATIVE GRID')
9050 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON INPUT GRID',i4)
9070 FORMAT ( ' TEST WMUPDT : ',a2,1x,a3,3x,    3(i10.8,i7.6))
9071 FORMAT ( '               ',i2,1x,a3,l3,17x,1(i10.8,i7.6))
9072 FORMAT ( '               ',i2,1x,a3,l3,    2(i10.8,i7.6))
9073 FORMAT ( '               ',i2,1x,a3,l3,17x,2(i10.8,i7.6))
#endif
    !/
    !/ End of WMUPDT ----------------------------------------------------- /
    !/

References w3timemd::dsec21(), wmmdatmd::etime, w3servmd::extcde(), w3gdatmd::filext, wmmdatmd::fllsti, wmmdatmd::fllstl, wmmdatmd::fllstr, wmmdatmd::idinp, wmmdatmd::iflsti, wmmdatmd::iflstl, wmmdatmd::iflstr, wmmdatmd::improc, w3idatmd::inflags1, wmmdatmd::inpmap, w3idatmd::jfirst, wmmdatmd::mdse, wmmdatmd::mdso, wmmdatmd::mdss, wmmdatmd::mdst, wmmdatmd::nmperr, wmmdatmd::nmpscr, w3gdatmd::nx, w3gdatmd::ny, w3timemd::stme21(), w3servmd::strace(), w3idatmd::t0n, w3idatmd::t1n, w3idatmd::t2n, w3idatmd::tc0, w3idatmd::tcn, w3idatmd::tdn, w3idatmd::tfn, w3idatmd::tg0, w3idatmd::tgn, w3idatmd::ti1, w3idatmd::ti2, w3idatmd::ti3, w3idatmd::ti4, w3idatmd::ti5, w3timemd::tick21(), w3wdatmd::time, w3idatmd::tin, w3idatmd::tln, w3idatmd::tr0, w3idatmd::trn, w3idatmd::ttn, w3idatmd::tu0, w3idatmd::tun, w3idatmd::tvn, w3idatmd::tw0, w3idatmd::twn, w3idatmd::tzn, w3gdatmd::w3setg(), w3idatmd::w3seti(), w3wdatmd::w3setw(), wmmdatmd::wmsetm(), wmupd1(), and wmupd2().

Referenced by wmwavemd::wmwave().

wmupdv()

subroutine wmupdtmd::wmupdv	(	integer, intent(in)	IMOD,
		real, dimension(nx,ny), intent(out)	VX,
		real, dimension(nx,ny), intent(out)	VY,
		integer, intent(in)	JMOD,
		real, dimension(grids(jmod)%nx,grids(jmod)%ny), intent(in)	VXI,
		real, dimension(grids(jmod)%nx,grids(jmod)%ny), intent(in)	VYI,
		real, intent(in)	UNDEF,
		integer, intent(in)	CONSTP
	)

Interpolate vector field from input grid to model grid.

Interpolating or averaging from input grid.

Parameters

[in]	IMOD	Output model number
[out]	VX	Output vector field
[out]	VY	Output vector field
[in]	JMOD	Input model number
[in]	VXI	Input vector field
[in]	VYI	Input vector field
[in]	UNDEF	Value for mapped out point and points not covered.
[in]	CONSTP	Convervation type

Author

H. L. Tolman

Date

06-Dec-2010

Definition at line 1305 of file wmupdtmd.F90.

    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         06-Dec-2010 |
    !/                  +-----------------------------------+
    !/
    !/    14-Oct-2006 : Origination.                        ( version 3.10 )
    !/    12-Jan-2007 : General clean-up and bug fixes.     ( version 3.10 )
    !/    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)
    !/    01-Jul-2019 : Generalize output to curv grids     ( version 7.13 )
    !/                  (R. Padilla-Hernandez, J.H. Alves, EMC/NOAA)
    !/
    !  1. Purpose :
    !
    !     Interpolate vector field from input grid to model grid.
    !
    !  2. Method :
    !
    !     Interpolating or averaging from input grid.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       IMOD    Int.   I   Output model number,
    !       VX/Y    Int.   O   Output vector field.
    !       JMOD    Int.   I   Input model number,
    !       VX/YI   Int.   I   Input vector field.
    !       UNDEF   Int.   I   Value for mapped out point and points not
    !                          covered.
    !       CONSTP  Int.   I   Conservation type :
    !                           1: Vector speed.
    !                           2: Vector speed squared.
    !                           *: Vector components.
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3ERVMD  Subroutine tracing.
    !      EXTCDE    Subr.   Id.    Program abort.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WMUPD2    Subr. WMUPDTMD Input update routine.
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !  7. Remarks :
    !
    !     - Grid pointers for output grid need to be set externally.
    !     - If input grid does not cover point of target grid, target grid
    !       values are set to UNDEF.
    !
    !  8. Structure :
    !
    !     See source code.
    !
    !  9. Switches :
    !
    !       !/S     Enable subroutine tracing.
    !       !/T     Enable test output
    !       !/T1    Test output interpolation data.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !/
    USE w3servmd, ONLY: extcde
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    !/
    USE w3gdatmd, ONLY: nx, ny, x0, y0, sx, sy, grids, flagll,      &
         gtype, rlgtype, clgtype, ungtype,           &
         iclose_none, iclose_smpl, iclose_trpl,      &
         hpfac, hqfac, xgrd, ygrd
    USE wmmdatmd, ONLY: improc, nmperr, nmpscr, mdst, mdse, mdso,   &
         mdss
    !/
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)     :: IMOD, JMOD, CONSTP
    REAL, INTENT(OUT)       :: VX(NX,NY), VY(NX,NY)
    REAL, INTENT(IN)        :: VXI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY),  &
         VYI(GRIDS(JMOD)%NX,GRIDS(JMOD)%NY),  &
         UNDEF
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: IXO, IYO, IX, IY, IXF0, IXFN, IYF0,  &
         IYFN, IXS0, IXSN, IYS0, IYSN, IXS,   &
         MXA, MYA, J, J1, J2, IXC, IYC, JJ,   &
         JX, JY
    INTEGER                 :: NPOIX, NPOIY, I,  IFIELDS,CURVI   !RP
 
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    INTEGER, ALLOCATABLE    :: NXA(:,:), NYA(:,:)
    REAL                    :: XR, YR, R1, R2, RT, XFL, XFR, XSL,   &
         XSR, YFL, YFR, YSL, YSR
    REAL                    :: VXL, VYL, VA0, VA, VA2, FACTOR,      &
         WTOT, WL
 
    REAL                    :: LONC, LATC, SXYC,                    &
         XDI, DTOLER, VALUEX, VALUEY
 
    REAL, ALLOCATABLE       :: RXA(:,:), RYA(:,:)
 
    !      REAL, ALLOCATABLE       :: VARIN(:,:)                        !RP
 
    LOGICAL                 :: MAP1(NX,NY), MAP2(NX,NY),            &
         MAP3(NX,NY), FLAGUP
    !
    INTEGER, POINTER        :: NXI, NYI, MAP(:,:), MAPI(:,:)
    REAL, POINTER           :: X0I, Y0I, SXI, SYI !RP , HPFACI, HQFACI
 
    REAL, POINTER           :: HPFACI(:,:), HQFACI(:,:)
    DOUBLE PRECISION, POINTER :: XGRDI(:,:), YGRDI(:,:), XGRDC(:,:), YGRDC(:,:)
 
    INTEGER, POINTER        :: ICLOSE
    REAL, ALLOCATABLE       :: XGRTMP(:),YGRTMP(:)
#ifdef W3_T1
    CHARACTER(LEN=17)       :: FORMAT1
#endif
    !/
    !/ ------------------------------------------------------------------- /
    ! 0.  Initialization
    ! 0.a Subroutine tracing and test output
    !
#ifdef W3_S
    CALL strace (ient, 'WMUPDV')
#endif
    !
    IF ( grids(imod)%GTYPE .EQ. ungtype .OR. &
         grids(jmod)%GTYPE .EQ. ungtype ) THEN
      WRITE (mdse,'(/2A)') ' *** ERROR WMUPDV: ', &
           'UNSTRUCTURED GRID SUPPORT NOT YET IMPLEMENTED ***'
      CALL extcde ( 999 )
    END IF
    !
    nxi    => grids(jmod)%NX
    nyi    => grids(jmod)%NY
    x0i    => grids(jmod)%X0
    y0i    => grids(jmod)%Y0
    sxi    => grids(jmod)%SX
    syi    => grids(jmod)%SY
    hpfaci => grids(jmod)%HPFAC
    hqfaci => grids(jmod)%HQFAC
    map    => grids(imod)%MAPSTA
    mapi   => grids(jmod)%MAPSTA
    iclose => grids(jmod)%ICLOSE
    !
    IF ( iclose .EQ. iclose_trpl ) THEN
      IF ( improc.EQ.nmperr ) WRITE(mdse,*)'SUBROUTINE WMUPDV IS'// &
           ' NOT YET ADAPTED FOR TRIPOLE GRIDS. STOPPING NOW.'
      CALL extcde ( 1 )
    END IF
 
    !
#ifdef W3_T
    WRITE (mdst,9000) imod, nx, ny, x0, y0, sx, sy,              &
         jmod, nxi, nyi, x0i, y0i, sxi, syi, undef
#endif
    !
    ! 0.b Initialize fields
    !
    vx     = undef
    vy     = undef
    !
    curvi=0
    IF ( grids(imod)%GTYPE .EQ. clgtype .OR. &
         grids(jmod)%GTYPE .EQ. clgtype ) THEN
      curvi=1
    END IF
 
    ! 1. Case of identical resolution and coinciding grids --------------- /
    IF(curvi .EQ. 0) THEN
      !
      IF ( abs(sx/sxi-1.) .LT. 1.e-3                         .AND.    &
           abs(sy/syi-1.) .LT. 1.e-3                         .AND.    &
           abs(mod((abs(x0-x0i))/sx+0.5,1.)-0.5) .LT. 1.e-2  .AND.    &
           abs(mod((abs(y0-y0i))/sy+0.5,1.)-0.5) .LT. 1.e-2 ) THEN
        !
        ! 1.a Offsets
        !
 
        ixo    = nint((x0-x0i)/sx)
        !
        IF ( flagll ) THEN
          ixf0   = 1
          ixfn   = nx
          ixs0   = -999
          ixsn   = -999
        ELSE
          ixf0   = max(  1  , 1-ixo )
          ixfn   = min( nx  , nxi-ixo )
          ixs0   = max(  1  , 1+ixo )
          ixsn   = ixs0 + ixfn - ixf0
        END IF
        !
        iyo    = nint((y0-y0i)/sy)
        !
        iyf0   = max(  1  , 1-iyo )
        iyfn   = min( ny  , nyi-iyo )
        iys0   = max(  1  , 1+iyo )
        iysn   = iys0 + iyfn - iyf0
        !
#ifdef W3_T
        WRITE (mdst,9010) ixo, iyo, ixf0, ixfn, iyf0, iyfn,      &
             ixs0, ixsn, iys0, iysn
#endif
        !
        ! 1.b Fill arrays for sea points only
        !
 
        DO ix=ixf0, ixfn
          IF ( flagll ) THEN
            ixs    = 1 + nint( mod(                             &
                 1080.+x0+(real(ix)-0.5)*sx-x0i , 360. ) / sx - 0.5 )
            IF ( ixs .GT. nxi ) cycle
          ELSE
            ixs    = ix + ixo
          END IF
          vx(ix,iyf0:iyfn) = vxi(ixs,iys0:iysn)
          vy(ix,iyf0:iyfn) = vyi(ixs,iys0:iysn)
        END DO
        !
        ! 1.c Return to calling routine
        !
        RETURN
        !
      END IF
    END IF !CURVI
    !
    ! 2.  General case --------------------------------------------------- /
    !
    ! 2.a Curvilinear grids
    !
    IF ( grids(imod)%GTYPE .EQ. clgtype .OR. &
         grids(jmod)%GTYPE .EQ. clgtype ) THEN
 
      xgrdi => grids(jmod)%XGRD   !LONS FOR INPUT FIELD
      ygrdi => grids(jmod)%YGRD    !LATS FOR INPUT FIELD
 
      !       GETTING THE INFO FOR THE CURVILINEAR GRID
      xgrdc => grids(imod)%XGRD     !LONS FOR CURVI GRID
      ygrdc => grids(imod)%YGRD     !LATS FOR CURVI GRID
      !HPFAC => GRIDS(IMOD)%HPFAC   !DELTAS IN LON FOR CURVI GRID
      !HQFAC => GRIDS(IMOD)%HQFAC   !DELTAS IN LAT FOR CURVI  GRID
      !
      !
      !  FOR NOW ONLY INTERPOLATION NOT AVERAGING THEN MXA=2
      mxa=2
      mya=2
      ALLOCATE ( nxa(nx,0:mxa) , rxa(nx,mxa) )
      nxa    = 0
      rxa    = 0.
      ALLOCATE ( nya(ny,0:mya) , rya(ny,mya) )
      nya    = 0
      rya    = 0.
 
      !IS THE TOLERANCE USED TO DETERMINE IF TWO VALUES ARE EQUAL IN LOCATION
      dtoler = 1e-5
      ! 2.a.1  running over the curvilinear grid
      ALLOCATE (xgrtmp(nxi),ygrtmp(nyi))
      xgrtmp=real(xgrdi(1,:))
      ygrtmp=real(ygrdi(:,1))
#ifdef W3_OMPH
      !$OMP PARALLEL DO PRIVATE(J,I,LONC,LATC,VALUEX,VALUEY)
#endif
      DO j=1,ny
        DO i=1,nx
          lonc=real(xgrdc(j,i))   !LON FOR EVERY CURVL GRID POINT
          latc=real(ygrdc(j,i))   !LAT FOR EVERY CURVL GRID POINT
 
          CALL interpolate2d(nxi,real(xgrtmp),nyi,real(ygrtmp), &
               vxi,vyi,lonc,latc,dtoler,valuex,valuey)
          vx(i,j)=valuex
          vy(i,j)=valuey
 
        END DO  !END I
      END DO  !END J
#ifdef W3_OMPH
      !$OMP END PARALLEL DO
#endif
      DEALLOCATE (xgrtmp, ygrtmp)
 
    ELSE
      !
      ! 2.b Rectilinear grids
      !
      ! 2.b.1 Interpolation / averaging data for X axis
      !
      IF ( sx/sxi .LT. 1.0001 ) THEN
        mxa    = 2
      ELSE
        mxa    = 2 + int(sx/sxi)
      END IF
      !
#ifdef W3_T
      WRITE (mdst,9020) 'X'
#endif
#ifdef W3_T1
      WRITE (format1,'(A,I2,A,I2,A)') "'(10X,",mxa+1,'I5,',mxa+1,"F6.2)'"
      WRITE (mdst,9021) nx, mxa
#endif
      !
      ALLOCATE ( nxa(nx,0:mxa) , rxa(nx,mxa) )
      nxa    = 0
      rxa    = 0.
      !
      IF ( mxa .EQ. 2 ) THEN
        !
        DO ix=1, nx
          IF ( flagll ) THEN
            xr     = 1. + mod       &
                 ( 1080.+x0+real(ix-1)*sx-x0i , 360. ) / sxi
          ELSE
            xr     = 1. + ( x0+real(ix-1)*sx - x0i ) / sxi
          END IF
          IF ( xr.GT.0. ) THEN
            j1     = int(xr)
            j2     = j1 + 1
            r2     = max( 0. , xr-real(j1) )
            r1     = 1. - r2
            IF ( flagll .AND. iclose.NE.iclose_none ) THEN
              j1 = 1 + mod(j1-1,nxi)
              j2 = 1 + mod(j2-1,nxi)
            END IF
            IF ( j1.GE.1 .AND. j1.LE.nxi .AND. r1.GT.0.05 ) THEN
              nxa(ix,0) = nxa(ix,0) + 1
              nxa(ix,nxa(ix,0)) = j1
              rxa(ix,nxa(ix,0)) = r1
            END IF
            IF ( j2.GE.1 .AND. j2.LE.nxi .AND. r2.GT.0.05 ) THEN
              nxa(ix,0) = nxa(ix,0) + 1
              nxa(ix,nxa(ix,0)) = j2
              rxa(ix,nxa(ix,0)) = r2
            END IF
            IF ( nxa(ix,0)  .GT. 0 ) THEN
              rt     = sum( rxa(ix,:) )
              IF ( rt .LT. 0.7 ) THEN
                nxa(ix,:) = 0
                rxa(ix,:) = 0.
              END IF
            END IF
          END IF
        END DO
        !
      ELSE
        !
        DO ix=1, nx
          !
          xfl    = x0 + real(ix-1)*sx - 0.5*sx
          xfr    = x0 + real(ix-1)*sx + 0.5*sx
          IF ( flagll ) THEN
            ixc    = 1 + nint( mod(                             &
                 1080.+x0+real(ix-1)*sx-x0i , 360. ) / sxi )
            ixs0   = ixc - 1 - mxa/2
            ixsn   = ixc + 1 + mxa/2
          ELSE
            ixc    = nint( 1. + ( x0+real(ix-1)*sx - x0i ) / sxi )
            ixs0   = max(  1  , ixc - 1 - mxa/2 )
            ixsn   = min( nxi , ixc + 1 + mxa/2 )
          END IF
          DO j=ixs0, ixsn
            jj=j
            IF ( flagll ) THEN
              IF ( iclose.NE.iclose_none ) jj = 1 + mod(j-1+nxi,nxi)
              IF ( jj.LT.1 .OR. jj.GT. nxi ) cycle
              ixc   = nint((0.5*(xfl+xfr)-x0i-real(jj-1)*sxi)/360.)
              IF ( ixc .NE. 0 ) THEN
                xfl    = xfl - real(ixc) * 360.
                xfr    = xfr - real(ixc) * 360.
              END IF
            ELSE
              jj     = j
            END IF
            xsl    = max( xfl , x0i + real(jj-1)*sxi - 0.5*sxi )
            xsr    = min( xfr , x0i + real(jj-1)*sxi + 0.5*sxi )
            r1     = max( 0. , xsr - xsl ) / sx
            IF ( r1 .GT. 0 ) THEN
              nxa(ix,0) = nxa(ix,0) + 1
              nxa(ix,nxa(ix,0)) = jj
              rxa(ix,nxa(ix,0)) = r1
            END IF
          END DO
          IF ( nxa(ix,0)  .GT. 0 ) THEN
            rt     = sum( rxa(ix,:) )
            IF ( rt .LT. 0.7 ) THEN
              nxa(ix,:) = 0
              rxa(ix,:) = 0.
            END IF
          END IF
        END DO
        !
      END IF
      !
#ifdef W3_T1
      DO, ix=1, nx
        IF ( nxa(ix,0) .GT. 0 ) WRITE (mdst,format1)                &
             ix, nxa(ix,1:mxa), rxa(ix,1:mxa), sum(rxa(ix,1:mxa))
      END DO
#endif
      !
      ! 2.b.2 Interpolation / averaging data for Y axis
      !
      IF ( sy/syi .LT. 1.0001 ) THEN
        mya    = 2
      ELSE
        mya    = 2 + int(sy/syi)
      END IF
      !
#ifdef W3_T
      WRITE (mdst,9020) 'Y'
#endif
#ifdef W3_T1
      format1 = '(10X,  I5,  F6.2)'
      WRITE (format1,'(A,I2,A,I2,A)') "'(10X,",mya+1,'I5,',mya+1,"F6.2)'"
      WRITE (mdst,9021) ny, mya
#endif
      !
      ALLOCATE ( nya(ny,0:mya) , rya(ny,mya) )
      nya    = 0
      rya    = 0.
      !
      IF ( mya .EQ. 2 ) THEN
        !
        DO iy=1, ny
          yr     = 1. + ( y0+real(iy-1)*sy - y0i ) / syi
          IF ( yr.GT.0. ) THEN
            j1     = int(yr)
            j2     = j1 + 1
            r2     = max( 0. , yr-real(j1) )
            r1     = 1. - r2
            IF ( j1.GE.1 .AND. j1.LE.nyi .AND. r1.GT.0.05 ) THEN
              nya(iy,0) = nya(iy,0) + 1
              nya(iy,nya(iy,0)) = j1
              rya(iy,nya(iy,0)) = r1
            END IF
            IF ( j2.GE.1 .AND. j2.LE.nyi .AND. r2.GT.0.05 ) THEN
              nya(iy,0) = nya(iy,0) + 1
              nya(iy,nya(iy,0)) = j2
              rya(iy,nya(iy,0)) = r2
            END IF
            IF ( nya(iy,0)  .GT. 0 ) THEN
              rt     = sum( rya(iy,:) )
              IF ( rt .LT. 0.7 ) THEN
                nya(iy,:) = 0
                rya(iy,:) = 0.
              END IF
            END IF
          END IF
        END DO
        !
      ELSE
        !
        DO iy=1, ny
          yfl    = y0 + real(iy-1)*sy - 0.5*sy
          yfr    = y0 + real(iy-1)*sy + 0.5*sy
          iyc    = nint( 1. + ( y0+real(iy-1)*sy - y0i ) / syi )
          iys0   = max(  1  , iyc - 1 - mya/2 )
          iysn   = min( nyi , iyc + 1 + mya/2 )
          DO j=iys0, iysn
            ysl    = max( yfl , y0i + real(j-1)*syi - 0.5*syi )
            ysr    = min( yfr , y0i + real(j-1)*syi + 0.5*syi )
            r1     = max( 0. , ysr - ysl ) / sy
            IF ( r1 .GT. 0 ) THEN
              nya(iy,0) = nya(iy,0) + 1
              nya(iy,nya(iy,0)) = j
              rya(iy,nya(iy,0)) = r1
            END IF
          END DO
          IF ( nya(iy,0)  .GT. 0 ) THEN
            rt     = sum( rya(iy,:) )
            IF ( rt .LT. 0.7 ) THEN
              nya(iy,:) = 0
              rya(iy,:) = 0.
            END IF
          END IF
        END DO
        !
      END IF
      !
    END IF
 
    !
#ifdef W3_T1
    DO, iy=1, ny
      IF ( nya(iy,0) .GT. 0 ) WRITE (mdst,format1)                &
           iy, nya(iy,1:mya), rya(iy,1:mya), sum(rya(iy,1:mya))
    END DO
#endif
    !
    ! 2.c Process grid
    !
    map1   = .false.
    map2   = .false.
    factor = 1.
    !
 
    DO ix=1, nx
      IF ( nxa(ix,0) .EQ. 0 ) cycle
      DO iy=1, ny
        IF ( nya(iy,0) .EQ. 0 ) cycle
        IF ( map(iy,ix).NE.0 ) THEN
          vxl    = 0.
          vyl    = 0.
          va     = 0.
          va2    = 0.
          wtot   = 0.
          DO j1=1, nxa(ix,0)
            jx     = nxa(ix,j1)
            DO j2=1, nya(iy,0)
              jy     = nya(iy,j2)
              IF ( mapi(jy,jx) .NE. 0 ) THEN
                wl     = rxa(ix,j1) * rya(iy,j2)
                wtot   = wtot + wl
                vxl    = vxl + wl * vxi(jx,jy)
                vyl    = vyl + wl * vyi(jx,jy)
                va     = va  + wl * sqrt                        &
                     ( vxi(jx,jy)**2 + vyi(jx,jy)**2 )
                va2    = va2 + wl *                             &
                     ( vxi(jx,jy)**2 + vyi(jx,jy)**2 )
              END IF
            END DO
          END DO
          IF ( wtot .LT. 0.05 ) THEN
            map1(ix,iy) = .true.
          ELSE
            map2(ix,iy) = .true.
            vxl    = vxl / wtot
            vyl    = vyl / wtot
            va     = va  / wtot
            va2    = sqrt( va2 / wtot )
            va0    = sqrt( vxl**2 + vyl**2 )
            IF ( constp .EQ. 1 ) THEN
              factor    = min( 1.25 , va/max(1.e-7,va0) )
            ELSE IF ( constp .EQ. 2 ) THEN
              factor    = min( 1.25 , va2/max(1.e-7,va0) )
            END IF
            vx(ix,iy) = factor * vxl
            vy(ix,iy) = factor * vyl
          END IF
        END IF
      END DO
    END DO
 
    !
    ! 2.d Reconcile mask differences
    !
#ifdef W3_T
    WRITE (mdst,9022)
#endif
    !
    jj     = 0
    iclose => grids(imod)%ICLOSE
    !
    DO
      IF ( jj .GT. swpmax ) EXIT
      flagup = .false.
      map3   = .false.
      jj     = jj + 1
#ifdef W3_T
      WRITE (mdst,9023) jj
#endif
      DO ix=1, nx
        DO iy=1, ny
          IF ( map1(ix,iy) ) THEN
            vxl    = 0.
            vyl    = 0.
            j1     = 0
            IF ( flagll ) THEN
              DO j2=ix-1, ix+1
                IF ( (j2.GT.1 .AND. j2.LE.nx) .OR. iclose.NE.iclose_none ) THEN
                  jx     = 1 + mod(nx+j2-1,nx)
                  DO jy=iy-1, iy+1
                    IF ( jy.GT.1 .AND. jy.LE.ny ) THEN
                      IF ( map2(jx,jy) ) THEN
                        vxl     = vxl + vx(jx,jy)
                        vyl     = vyl + vy(jx,jy)
                        j1      = j1 + 1
                      END IF
                    END IF
                  END DO
                END IF
              END DO
            ELSE
              DO jx=ix-1, ix+1
                IF ( jx.GT.1 .AND. jx.LE.nx ) THEN
                  DO jy=iy-1, iy+1
                    IF ( jy.GT.1 .AND. jy.LE.ny ) THEN
                      IF ( map2(jx,jy) ) THEN
                        vxl     = vxl + vx(jx,jy)
                        vyl     = vyl + vy(jx,jy)
                        j1      = j1 + 1
                      END IF
                    END IF
                  END DO
                END IF
              END DO
            END IF !FLAGLL
            IF ( j1 .GT. 0 ) THEN
              vx(ix,iy) = vxl / real(j1)
              vy(ix,iy) = vyl / real(j1)
              map1(ix,iy) = .false.
              map3(ix,iy) = .true.
              flagup = .true.
            END IF
          END IF
        END DO
      END DO
      IF ( flagup ) THEN
        map2   = map2 .OR. map3
      ELSE
        EXIT
      END IF
    END DO
 
    !
    ! 3. End of routine -------------------------------------------------- /
    !
    DEALLOCATE ( nxa, nya, rxa, rya )
    !
    RETURN
    !
    ! Formats
    !
#ifdef W3_T
9000 FORMAT ( ' TEST WMUPDV : GRID INFORMATION : '/               &
         '             ',3i5,4e11.3/                         &
         '             ',3i5,4e11.3/                         &
         '               UNDEFINED = ',e10.3)
9010 FORMAT ( ' TEST WMUPDV : COINCIDING GRIDS, OFFSETS :',2i6/   &
         '               TARGET GRID RANGES        :',4i6/   &
         '               SOURCE GRID RANGES        :',4i6)
9020 FORMAT ( ' TEST WMUPDV : WEIGHTS FOR ',a,' INTERPOATION')
#endif
#ifdef W3_T1
9021 FORMAT ( ' TEST WMUPDV : ARAY DIMENSIONED AS : ',2i6)
#endif
#ifdef W3_T
9022 FORMAT ( ' TEST WMUPDV : RECONCILING MASKS')
9023 FORMAT ( '               SWEEP NR ',i4)
#endif
    !/
    !/ End of WMUPDV ----------------------------------------------------- /
    !/

References w3gdatmd::clgtype, w3servmd::extcde(), w3gdatmd::flagll, w3gdatmd::grids, w3gdatmd::gtype, w3gdatmd::hpfac, w3gdatmd::hqfac, w3gdatmd::iclose_none, w3gdatmd::iclose_smpl, w3gdatmd::iclose_trpl, wmmdatmd::improc, interpolate2d(), wmmdatmd::mdse, wmmdatmd::mdso, wmmdatmd::mdss, wmmdatmd::mdst, wmmdatmd::nmperr, wmmdatmd::nmpscr, w3gdatmd::nx, w3gdatmd::ny, w3gdatmd::rlgtype, w3servmd::strace(), swpmax, w3gdatmd::sx, w3gdatmd::sy, w3gdatmd::ungtype, w3gdatmd::x0, w3gdatmd::xgrd, w3gdatmd::y0, and w3gdatmd::ygrd.

Referenced by wmupd2().

xycurvisearch()

integer function wmupdtmd::xycurvisearch	(	integer, intent(in)	LENGTH,
		real, dimension(length), intent(in)	ARRAY,
		real, intent(in)	VALUE,
		real, intent(in), optional	DELTA
	)

Search the location of a point(XC,YC) in a regular grid.

Given an array and a value to search, it returns the index of the element on the rectilinear grid that is closest to, but less than, the given value. "delta" is the threshold used to determine if two values are equal.

       if ( abs(x1 - x2) <= delta) then
          assume x1 = x2
       endif

Parameters

LENGTH	Dimension of input array
ARRAY	1D array for lats or longs
VALUE	Value to located in ARRAY
DELTA	Threshold to determine if two values are equal

Returns

XYCURVISEARCH

Author

H. L. Tolman

Date

20-Jan-2017

Definition at line 2625 of file wmupdtmd.F90.

    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         20-Jan-2017 |
    !/                  +-----------------------------------+
    !/                  (R. Padilla-Hernandez, EMC/NOAA)
    !/
    !/    01-Jul-2019 : Origination.                        ( version 7.13 )
    !/    01-Jul-2019 : Generalize output to curv grids     ( 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 :
    !
    !    Search the location of a point(XC,YC) in a regular grid
    !
    !
    !  2. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       LENGTH  Int.  Input  Dimension of input array
    !       ARRAY   Int.  Input  1D array for lats or longs
    !       VALUE   Real  Input  Value to be located in ARRAY
    !       DELTA   Real  Input  Threshold to determine if two values
    !                            are equal
    !     ----------------------------------------------------------------
    !
    !     Internal parameters
    !     ----------------------------------------------------------------
    !
    !     ----------------------------------------------------------------
    !
    !  3. Subroutines and functions :
    !
    !      Name           Type       Scope            Description
    !     ----------------------------------------------------------------
    !     XYCURVISEARCH   Function   Find indexes     See bellow
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines and functions used :
    !
    !     -
    !
    !  5. Remarks :
    !       GIVEN AN ARRAY  AND A VALUE TO SEARCH, IT RETURNS THE INDEX OF
    !       THE ELEMENT ON THE RECTILINEAR GRID THAT IS CLOSEST TO, BUT
    !       LESS THAN, THE GIVEN VALUE.
    !       "DELTA" IS THE THERSHOLD  USED TO DETERMINE IF TWO VALUES ARE EQUAL
    !       IF ( ABS(X1 - X2) <= DELTA) THEN
    !          ASSUME X1 = X2
    !       ENDIF
    !
    !  6. Switches :
    !     -
    !
    !  7. Source code :
 
    INTEGER, INTENT(IN) :: LENGTH
    REAL, DIMENSION(LENGTH), INTENT(IN) :: ARRAY
    REAL, INTENT(IN) :: VALUE
    REAL, INTENT(IN), OPTIONAL :: DELTA
 
    INTEGER :: XYCURVISEARCH
 
    INTEGER :: LEFT, MIDDLE, RIGHT
 
 
    left = 1
    right = length
    DO
      IF (left > right) THEN
        EXIT
      ENDIF
      middle = nint((left+right) / 2.0)
      IF ( abs(array(middle) - VALUE) <= delta) THEN
        xycurvisearch = middle
        RETURN
      ELSE IF (array(middle) > VALUE) THEN
        right = middle - 1
      ELSE
        left = middle + 1
      END IF
    END DO
    xycurvisearch = right
 

Referenced by averaging(), interpolate(), and interpolate2d().

Variable Documentation

swpmax

integer, parameter wmupdtmd::swpmax = 5

SWPMAX.

Definition at line 88 of file wmupdtmd.F90.

  INTEGER, PARAMETER      :: SWPMAX = 5

Referenced by wmupds(), and wmupdv().