MODULE module_interp_info 4
INTEGER , PARAMETER :: NOT_DEFINED_YET = 0
INTEGER , PARAMETER :: BILINEAR = 1
INTEGER , PARAMETER :: SINT = 2
INTEGER , PARAMETER :: NEAREST_NEIGHBOR = 3
INTEGER , PARAMETER :: QUADRATIC = 4
INTEGER , PARAMETER :: SPLINE = 5
INTEGER , PARAMETER :: SINT_NEW = 12
INTEGER :: interp_method_type = 0
CONTAINS
SUBROUTINE interp_info_init 1
#if (EM_CORE == 1)
CALL nl_get_interp_method_type ( 1 , interp_method_type )
#else
interp_method_type = 2
#endif
END SUBROUTINE interp_info_init
END MODULE module_interp_info
!WRF:MEDIATION_LAYER:INTERPOLATIONFUNCTION
!
!
!=========================================================================
SUBROUTINE interp_init 1,2
USE module_interp_info
CALL interp_info_init
END SUBROUTINE interp_init
!=========================================================================
#if ! defined(NMM_CORE) || NMM_CORE!=1
SUBROUTINE interp_fcn ( cfld, & ! CD field 2,6
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! Nest ratio, i- and j-directions
USE module_interp_info
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
IF ( interp_method_type .EQ. NOT_DEFINED_YET ) THEN
interp_method_type = SINT
END IF
IF ( interp_method_type .EQ. BILINEAR ) THEN
CALL interp_fcn_blint ( cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! Nest ratio, i- and j-directions
ELSE IF ( MOD(interp_method_type,10) .EQ. SINT ) THEN
CALL interp_fcn_sint ( cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! Nest ratio, i- and j-directions
ELSE IF ( interp_method_type .EQ. NEAREST_NEIGHBOR ) THEN
CALL interp_fcn_nn ( cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! Nest ratio, i- and j-directions
ELSE IF ( interp_method_type .EQ. QUADRATIC ) THEN
CALL interp_fcn_lagr ( cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! Nest ratio, i- and j-directions
ELSE
CALL wrf_error_fatal ('Hold on there cowboy, we need to know which interpolation option you want')
END IF
END SUBROUTINE interp_fcn
!=========================================================================
! Overlapping linear horizontal iterpolation for mass, u, and v staggerings.
SUBROUTINE interp_fcn_blint ( cfld, & ! CD field 1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! Nest ratio, i- and j-directions
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, ioff, joff, i, j, k
REAL :: wx, wy, cfld_ll, cfld_lr, cfld_ul, cfld_ur
REAL :: cxp0, cxp1, nx, cyp0, cyp1, ny
! Fortran functions. Yes, yes, I know, probably pretty slow.
REAL, EXTERNAL :: nest_loc_of_cg
INTEGER, EXTERNAL :: compute_CGLL
! This stag stuff is to keep us away from the outer most row
! and column for the unstaggered directions. We are going to
! consider "U" an xstag variable and "V" a ystag variable. The
! vertical staggering is handled in the actual arguments. The
! ckte and nkte are the ending vertical dimensions for computations
! for this particular variable.
IF ( xstag ) THEN
istag = 0
ioff = 1
ELSE
istag = 1
ioff = 0
END IF
IF ( ystag ) THEN
jstag = 0
joff = 1
ELSE
jstag = 1
joff = 0
END IF
! Loop over each j-index on this tile for the nested domain.
j_loop : DO nj = njts, MIN(njde-jstag,njte)
! This is the lower-left j-index of the CG.
! Example is 3:1 ratio, mass-point staggering. We have listed six CG values
! as an example: A, B, C, D, E, F. For a 3:1 ratio, each of these CG cells has
! nine associated FG points.
! |=========|=========|=========|
! | - - - | - - - | - - - |
! | | | |
! | - D - | - E - | - F - |
! | | | |
! | 1 2 3 | 4 5 6 | 7 8 9 |
! |=========|=========|=========|
! | - - - | - - - | - - - |
! | | | |
! | - A - | - B - | - C - |
! | | | |
! | - - - | - - - | - - - |
! |=========|=========|=========|
! To interpolate to FG point 4, we will use CG points: A, B, D, E. It is adequate to
! find the lower left point. The lower left (LL) point for "4" is "A". Below
! are a few more points.
! 2 => A
! 3 => A
! 4 => A
! 5 => B
! 6 => B
! 7 => B
cj = compute_CGLL ( nj , jpos , nrj , jstag )
ny = REAL(nj)
cyp0 = nest_loc_of_cg ( cj , jpos , nrj , joff )
cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff )
! What is the weighting for this CG point to the FG point, j-weight only.
wy = ( cyp1 - ny ) / ( cyp1 - cyp0 )
! Vertical dim of the nest domain.
k_loop : DO nk = nkts, nkte
! Loop over each i-index on this tile for the nested domain.
i_loop : DO ni = nits, MIN(nide-istag,nite)
IF ( imask ( ni, nj ) .EQ. 1 ) THEN
! The coarse grid location that is to the lower left of the FG point.
ci = compute_CGLL ( ni , ipos , nri , istag )
nx = REAL(ni)
cxp0 = nest_loc_of_cg ( ci , ipos , nri , ioff )
cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff )
wx = ( cxp1 - nx ) / ( cxp1 - cxp0 )
! The four surrounding CG values.
cfld_ll = cfld(ci ,nk,cj )
cfld_lr = cfld(ci+1,nk,cj )
cfld_ul = cfld(ci ,nk,cj+1)
cfld_ur = cfld(ci+1,nk,cj+1)
! Bilinear interpolation in horizontal.
nfld( ni , nk , nj ) = wy * ( cfld_ll * wx + cfld_lr * (1.-wx) ) + &
(1.-wy) * ( cfld_ul * wx + cfld_ur * (1.-wx) )
END IF
END DO i_loop
END DO k_loop
END DO j_loop
END SUBROUTINE interp_fcn_blint
!=========================================================================
! Overlapping linear horizontal iterpolation for longitude
SUBROUTINE interp_fcn_blint_ll ( cfld_inp, & ! CD field,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! Nest ratio, i- and j-directions
clat_in, nlat_in, & ! CG, FG latitude
cinput_from_file, ninput_from_file ) ! CG, FG T/F input from file
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld_inp, cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clat_in
REAL, DIMENSION ( nims:nime, njms:njme ) :: nlat_in
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
LOGICAL :: cinput_from_file, ninput_from_file
! Local
INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, ioff, joff, i, j, k
REAL :: wx, wy, cfld_ll, cfld_lr, cfld_ul, cfld_ur
REAL :: cxp0, cxp1, nx, cyp0, cyp1, ny
LOGICAL :: probably_by_dateline
REAL :: max_lon, min_lon
LOGICAL :: probably_by_pole
REAL :: max_lat, min_lat
! Fortran functions. Yes, yes, I know, probably pretty slow.
REAL, EXTERNAL :: nest_loc_of_cg
INTEGER, EXTERNAL :: compute_CGLL
! This stag stuff is to keep us away from the outer most row
! and column for the unstaggered directions. We are going to
! consider "U" an xstag variable and "V" a ystag variable. The
! vertical staggering is handled in the actual arguments. The
! ckte and nkte are the ending vertical dimensions for computations
! for this particular variable.
IF ( xstag ) THEN
istag = 0
ioff = 1
ELSE
istag = 1
ioff = 0
END IF
IF ( ystag ) THEN
jstag = 0
joff = 1
ELSE
jstag = 1
joff = 0
END IF
! If this is a projection where the nest is over the pole, and
! we are using the parent to interpolate the longitudes, then
! we are going to have longitude troubles. If this is the case,
! stop the model right away.
probably_by_pole = .FALSE.
max_lat = -90
min_lat = +90
DO nj = njts, MIN(njde-jstag,njte)
DO ni = nits, MIN(nide-istag,nite)
max_lat = MAX ( nlat_in(ni,nj) , max_lat )
min_lat = MIN ( nlat_in(ni,nj) , min_lat )
END DO
END DO
IF ( ( max_lat .GT. 85 ) .OR. ( ABS(min_lat) .GT. 85 ) ) THEN
probably_by_pole = .TRUE.
END IF
IF ( ( probably_by_pole ) .AND. ( .NOT. ninput_from_file ) ) THEN
CALL wrf_error_fatal ( 'Nest over the pole, single input domain, longitudes will be wrong' )
END IF
! Initialize to NOT being by dateline.
probably_by_dateline = .FALSE.
max_lon = -180
min_lon = +180
DO nj = njts, MIN(njde-jstag,njte)
cj = compute_CGLL ( nj , jpos , nrj , jstag )
DO ni = nits, MIN(nide-istag,nite)
ci = compute_CGLL ( ni , ipos , nri , istag )
max_lon = MAX ( cfld_inp(ci,1,cj) , max_lon )
min_lon = MIN ( cfld_inp(ci,1,cj) , min_lon )
END DO
END DO
IF ( max_lon - min_lon .GT. 300 ) THEN
probably_by_dateline = .TRUE.
END IF
! Load "continuous" longitude across the date line
DO cj = MIN(cjts-1,cjms), MAX(cjte+1,cjme)
DO ci = MIN(cits-1,cims), MAX(cite+1,cime)
IF ( ( cfld_inp(ci,ckts,cj) .LT. 0 ) .AND. ( probably_by_dateline ) ) THEN
cfld(ci,ckts,cj) = 360 + cfld_inp(ci,ckts,cj)
ELSE
cfld(ci,ckts,cj) = cfld_inp(ci,ckts,cj)
END IF
END DO
END DO
! Loop over each j-index on this tile for the nested domain.
j_loop : DO nj = njts, MIN(njde-jstag,njte)
! This is the lower-left j-index of the CG.
! Example is 3:1 ratio, mass-point staggering. We have listed six CG values
! as an example: A, B, C, D, E, F. For a 3:1 ratio, each of these CG cells has
! nine associated FG points.
! |=========|=========|=========|
! | - - - | - - - | - - - |
! | | | |
! | - D - | - E - | - F - |
! | | | |
! | 1 2 3 | 4 5 6 | 7 8 9 |
! |=========|=========|=========|
! | - - - | - - - | - - - |
! | | | |
! | - A - | - B - | - C - |
! | | | |
! | - - - | - - - | - - - |
! |=========|=========|=========|
! To interpolate to FG point 4, we will use CG points: A, B, D, E. It is adequate to
! find the lower left point. The lower left (LL) point for "4" is "A". Below
! are a few more points.
! 2 => A
! 3 => A
! 4 => A
! 5 => B
! 6 => B
! 7 => B
cj = compute_CGLL ( nj , jpos , nrj , jstag )
ny = REAL(nj)
cyp0 = nest_loc_of_cg ( cj , jpos , nrj , joff )
cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff )
! What is the weighting for this CG point to the FG point, j-weight only.
wy = ( cyp1 - ny ) / ( cyp1 - cyp0 )
! Vertical dim of the nest domain.
k_loop : DO nk = nkts, nkte
! Loop over each i-index on this tile for the nested domain.
i_loop : DO ni = nits, MIN(nide-istag,nite)
IF ( imask ( ni, nj ) .EQ. 1 ) THEN
! The coarse grid location that is to the lower left of the FG point.
ci = compute_CGLL ( ni , ipos , nri , istag )
nx = REAL(ni)
cxp0 = nest_loc_of_cg ( ci , ipos , nri , ioff )
cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff )
wx = ( cxp1 - nx ) / ( cxp1 - cxp0 )
! The four surrounding CG values.
cfld_ll = cfld(ci ,nk,cj )
cfld_lr = cfld(ci+1,nk,cj )
cfld_ul = cfld(ci ,nk,cj+1)
cfld_ur = cfld(ci+1,nk,cj+1)
! Bilinear interpolation in horizontal.
nfld( ni , nk , nj ) = wy * ( cfld_ll * wx + cfld_lr * (1.-wx) ) + &
(1.-wy) * ( cfld_ul * wx + cfld_ur * (1.-wx) )
END IF
END DO i_loop
END DO k_loop
END DO j_loop
! Put nested longitude back into the -180 to 180 range.
DO nj = njts, MIN(njde-jstag,njte)
DO ni = nits, MIN(nide-istag,nite)
IF ( nfld(ni,nkts,nj) .GT. 180 ) THEN
nfld(ni,nkts,nj) = -360 + nfld(ni,nkts,nj)
END IF
END DO
END DO
END SUBROUTINE interp_fcn_blint_ll
!=========================================================================
! Lagrange interpolating polynomials, set up as a quadratic, with an average of
! the overlap.
SUBROUTINE interp_fcn_lagr ( cfld, & ! CD field 1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! Nest ratio, i- and j-directions
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, i, j, k
REAL :: nx, x0, x1, x2, x3, x
REAL :: ny, y0, y1, y2, y3
REAL :: cxm1, cxp0, cxp1, cxp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2
REAL :: cym1, cyp0, cyp1, cyp2
INTEGER :: ioff, joff
! Fortran functions.
REAL, EXTERNAL :: lagrange_quad_avg
REAL, EXTERNAL :: nest_loc_of_cg
INTEGER, EXTERNAL :: compute_CGLL
! This stag stuff is to keep us away from the outer most row
! and column for the unstaggered directions. We are going to
! consider "U" an xstag variable and "V" a ystag variable. The
! vertical staggering is handled in the actual arguments. The
! ckte and nkte are the ending vertical dimensions for computations
! for this particular variable.
! The ioff and joff are offsets due to the staggering. It is a lot
! simpler with ioff and joff if
! u var => ioff=1
! v var => joff=1
! otherwise zero.
! Note that is OPPOSITE of the istag, jstag vars. The stag variables are
! used for the domain dimensions, the offset guys are used in the
! determination of grid points between the CG and FG
IF ( xstag ) THEN
istag = 0
ioff = 1
ELSE
istag = 1
ioff = 0
END IF
IF ( ystag ) THEN
jstag = 0
joff = 1
ELSE
jstag = 1
joff = 0
END IF
! Loop over each j-index on this tile for the nested domain.
j_loop : DO nj = njts, MIN(njde-jstag,njte)
! This is the lower-left j-index of the CG.
! Example is 3:1 ratio, mass-point staggering. We have listed sixteen CG values
! as an example: A through P. For a 3:1 ratio, each of these CG cells has
! nine associated FG points.
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - M - | - N d | - O - | - P - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - I - | - J c | - K - | - L - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - 1 2 | 3 4 5 | 6 7 8 | - - - |
! | | | | |
! | - E - | - F b | - G - | - H - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - A - | - B a | - C - | - D - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! To interpolate to FG point 4, 5, or 6 we will use CG points: A through P. It is
! sufficient to find the lower left corner of a 4-point interpolation, and then extend
! each side by one unit.
! Here are the lower left hand corners of the following FG points:
! 1 => E
! 2 => E
! 3 => E
! 4 => F
! 5 => F
! 6 => F
! 7 => G
! 8 => G
cj = compute_CGLL ( nj , jpos , nrj , jstag )
! Vertical dim of the nest domain.
k_loop : DO nk = nkts, nkte
! Loop over each i-index on this tile for the nested domain.
i_loop : DO ni = nits, MIN(nide-istag,nite)
! The coarse grid location that is to the lower left of the FG point.
ci = compute_CGLL ( ni , ipos , nri , istag )
! To interpolate to point "*" (look in grid cell "F"):
! 1. Use ABC to get a quadratic valid at "a"
! Use BCD to get a quadratic valid at "a"
! Average these to get the final value for "a"
! 2. Use EFG to get a quadratic valid at "b"
! Use FGH to get a quadratic valid at "b"
! Average these to get the final value for "b"
! 3. Use IJK to get a quadratic valid at "c"
! Use JKL to get a quadratic valid at "c"
! Average these to get the final value for "c"
! 4. Use MNO to get a quadratic valid at "d"
! Use NOP to get a quadratic valid at "d"
! Average these to get the final value for "d"
! 5. Use abc to get a quadratic valid at "*"
! Use bcd to get a quadratic valid at "*"
! Average these to get the final value for "*"
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - M - | - N d | - O - | - P - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - I - | - J c | - K - | - L - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - * | - - - | - - - |
! | | | | |
! | - E - | - F b | - G - | - H - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - A - | - B a | - C - | - D - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! Overlapping quadratic interpolation.
IF ( imask ( ni, nj ) .EQ. 1 ) THEN
! I-direction location of "*"
nx = REAL(ni)
! I-direction location of "A", "E", "I", "M"
cxm1 = nest_loc_of_cg ( ci-1 , ipos , nri , ioff )
! I-direction location of "B", "F", "J", "N"
cxp0 = nest_loc_of_cg ( ci , ipos , nri , ioff )
! I-direction location of "C", "G", "K", "O"
cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff )
! I-direction location of "D", "H", "L", "P"
cxp2 = nest_loc_of_cg ( ci+2 , ipos , nri , ioff )
! Value at "a"
nfld_m1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj-1), cfld(ci+0,nk,cj-1), cfld(ci+1,nk,cj-1), cfld(ci+2,nk,cj-1) )
! Value at "b"
nfld_p0 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj+0), cfld(ci+0,nk,cj+0), cfld(ci+1,nk,cj+0), cfld(ci+2,nk,cj+0) )
! Value at "c"
nfld_p1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj+1), cfld(ci+0,nk,cj+1), cfld(ci+1,nk,cj+1), cfld(ci+2,nk,cj+1) )
! Value at "d"
nfld_p2 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj+2), cfld(ci+0,nk,cj+2), cfld(ci+1,nk,cj+2), cfld(ci+2,nk,cj+2) )
! J-direction location of "*"
ny = REAL(nj)
! J-direction location of "A", "B", "C", "D"
cym1 = nest_loc_of_cg ( cj-1 , jpos , nrj , joff )
! J-direction location of "E", "F", "G", "H"
cyp0 = nest_loc_of_cg ( cj , jpos , nrj , joff )
! J-direction location of "I", "J", "K", "L"
cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff )
! J-direction location of "M", "N", "O", "P"
cyp2 = nest_loc_of_cg ( cj+2 , jpos , nrj , joff )
! Value at "*"
nfld(ni,nk,nj) = lagrange_quad_avg ( ny, cym1, cyp0, cyp1, &
cyp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2 )
END IF
END DO i_loop
END DO k_loop
END DO j_loop
END SUBROUTINE interp_fcn_lagr
!=================================================================================
REAL FUNCTION lagrange_quad ( x , x0, x1, x2, y0, y1, y2 )
IMPLICIT NONE
REAL :: x , x0, x1, x2, y0, y1, y2
! Lagrange = sum prod ( x - xj )
! i=0,n ( j=0,n --------- * yi )
! j<>i ( xi - xj )
! For a quadratic, in the above equation, we are setting n=2. Three points
! required for a quadratic, points x0, x1, x2 (hence n=2).
lagrange_quad = &
(x-x1)*(x-x2)*y0 / ( (x0-x1)*(x0-x2) ) + &
(x-x0)*(x-x2)*y1 / ( (x1-x0)*(x1-x2) ) + &
(x-x0)*(x-x1)*y2 / ( (x2-x0)*(x2-x1) )
END FUNCTION lagrange_quad
!=================================================================================
REAL FUNCTION lagrange_quad_avg ( x , x0, x1, x2, x3, y0, y1, y2, y3 )
IMPLICIT NONE
REAL, EXTERNAL :: lagrange_quad
REAL :: x , x0, x1, x2, x3, y0, y1, y2, y3
! Since there are three points required for a quadratic, we compute it twice
! (once with x0, x1, x2 and once with x1, x2, x3), and then average those values. This will
! reduce overshoot. The "x" point is where we are interpolating TO.
! x0 x1 x x2
! x1 x x2 x3
lagrange_quad_avg = &
! ( lagrange_quad ( x , x0, x1, x2, y0, y1, y2 ) + &
! lagrange_quad ( x , x1, x2, x3, y1, y2, y3 ) ) / &
! 2.
( lagrange_quad ( x , x0, x1, x2, y0, y1, y2 ) * ( x2 - x ) + &
lagrange_quad ( x , x1, x2, x3, y1, y2, y3 ) * ( x - x1 ) ) / &
( x2 - x1 )
END FUNCTION lagrange_quad_avg
!=================================================================================
REAL FUNCTION nest_loc_of_cg ( ci , ipos , nri , ioff )
! I and J direction equations for mass and momentum values for even
! and odd ratios: Given that the starting value of the nest in the
! CG grid cell is defined as (1,1), what is the location of the CG
! location in FG index units. Example, for a 2:1 ratio, the location
! of the mass point T is 1.5 (3:1 ratio = 2, 4:1 ratio = 2.5, etc).
! Note that for momentum points, the CG U point is defined as "1", the
! same as the I-direction of the (1,1) location of the FG U point.
! Same for V, but in the J-direction.
IMPLICIT NONE
INTEGER :: ci , ipos , nri , ioff
nest_loc_of_cg = &
( ci - ipos ) * nri + ( 1 - ioff ) * REAL ( nri + 1 ) / 2. + ioff
END FUNCTION nest_loc_of_cg
!=================================================================================
FUNCTION compute_CGLL ( ni , ipos , nri , istag ) RESULT ( CGLL_loc ),1
IMPLICIT NONE
INTEGER , INTENT(IN ) :: ni , ipos , nri , istag
INTEGER :: CGLL_loc
! Local vars
INTEGER :: starting_position , increments_of_CG_cells
INTEGER :: location_of_LL_wrt_this_CG
INTEGER :: ioff
INTEGER , PARAMETER :: MOMENTUM_STAG = 0
INTEGER , PARAMETER :: MASS_POINT_STAG = 1
starting_position = ipos
increments_of_CG_cells = ( ni - 1 ) / nri
ioff = MOD ( nri , 2 )
IF ( istag .EQ. MOMENTUM_STAG ) THEN
location_of_LL_wrt_this_CG = MOD ( ( ni - 1 ) , nri ) / ( nri + ioff ) - istag ! zero
ELSE IF ( istag .EQ. MASS_POINT_STAG ) THEN
location_of_LL_wrt_this_CG = ( MOD ( ( ni - 1 ) , nri ) + ioff ) / ( ( nri + ioff ) / 2 ) - istag
ELSE
CALL wrf_error_fatal ( 'Hold on there pard, there are only two staggerings I accept.' )
END IF
CGLL_loc = starting_position + increments_of_CG_cells + location_of_LL_wrt_this_CG
! WRITE ( 6 , '(a,i4, i4, i4, i4)') 'ni ipos nri stag', ni, ipos, nri, istag
! WRITE ( 6 , '(a,i4, i4, i4, i4)') 'strt inc loc CGLL', starting_position , increments_of_CG_cells , location_of_LL_wrt_this_CG , CGLL_loc
! print *,' '
END FUNCTION compute_CGLL
!=================================================================================
! Smolarkiewicz positive definite, monotonic transport.
SUBROUTINE interp_fcn_sint ( cfld, & ! CD field 1,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, nioff, njoff
INTEGER nfx, ior
PARAMETER (ior=2)
INTEGER nf
REAL psca(cims:cime,cjms:cjme,nri*nrj)
LOGICAL icmask( cims:cime, cjms:cjme )
INTEGER i,j,k
INTEGER nrio2, nrjo2
! Iterate over the ND tile and compute the values
! from the CD tile.
ioff = 0 ; joff = 0
nioff = 0 ; njoff = 0
IF ( xstag ) THEN
ioff = (nri-1)/2
nioff = nri
ENDIF
IF ( ystag ) THEN
joff = (nrj-1)/2
njoff = nrj
ENDIF
nrio2 = nri/2
nrjo2 = nrj/2
nfx = nri * nrj
!$OMP PARALLEL DO &
!$OMP PRIVATE ( i,j,k,ni,nj,ci,cj,ip,jp,nk,ck,nf,icmask,psca )
DO k = ckts, ckte
icmask = .FALSE.
DO nf = 1,nfx
DO j = cjms,cjme
nj = (j-jpos) * nrj + ( nrjo2 + 1 ) ! j point on nest
DO i = cims,cime
ni = (i-ipos) * nri + ( nrio2 + 1 ) ! i point on nest
if ( ni .ge. nits-nioff-nrio2 .and. &
ni .le. nite+nioff+nrio2 .and. &
nj .ge. njts-njoff-nrjo2 .and. &
nj .le. njte+njoff+nrjo2 ) then
if ( ni.ge.nims.and.ni.le.nime.and.nj.ge.njms.and.nj.le.njme) then
if ( imask(ni,nj) .eq. 1 ) then
icmask( i, j ) = .TRUE.
endif
endif
if ( ni-nioff.ge.nims.and.ni.le.nime.and.nj-njoff.ge.njms.and.nj.le.njme) then
if (ni .ge. nits-nioff .and. nj .ge. njts-njoff ) then
if ( imask(ni-nioff,nj-njoff) .eq. 1) then
icmask( i, j ) = .TRUE.
endif
endif
endif
endif
psca(i,j,nf) = cfld(i,k,j)
ENDDO ! i
ENDDO ! j
ENDDO ! nf
! tile dims in this call to sint are 1-over to account for the fact
! that the number of cells on the nest local subdomain is not
! necessarily a multiple of the nest ratio in a given dim.
! this could be a little less ham-handed.
CALL sint( psca, &
cims, cime, cjms, cjme, icmask, &
cits-1, cite+1, cjts-1, cjte+1, nrj*nri, xstag, ystag )
DO nj = njts, njte+joff
cj = jpos + (nj-1) / nrj ! j coord of CD point
jp = mod ( nj-1 , nrj ) ! coord of ND w/i CD point
nk = k
ck = nk
DO ni = nits, nite+ioff
ci = ipos + (ni-1) / nri ! i coord of CD point
ip = mod ( ni-1 , nri ) ! coord of ND w/i CD point
if ( ( ni-ioff .ge. nits ) .and. ( nj-joff .ge. njts ) ) then
if ( imask ( ni, nj ) .eq. 1 .or. imask ( ni-ioff, nj-joff ) .eq. 1 ) then
nfld( ni-ioff, nk, nj-joff ) = psca( ci , cj, ip+1 + (jp)*nri )
endif
endif
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
END SUBROUTINE interp_fcn_sint
!=========================================================================
! Nearest neighbor interpolation.
SUBROUTINE interp_fcn_nn ( cfld, & ! CD field 1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
INTEGER ci, cj, ck, ni, nj, nk
! Iterate over the ND tile and assign the values
! from the CD tile. This is a trivial implementation
! of the interp_fcn; just copies the values from the CD into the ND
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
if ( imask ( ni, nj ) .eq. 1 ) then
ci = ipos + (ni-1) / nri ! i coord of CD point
nfld( ni, nk, nj ) = cfld( ci , ck , cj )
endif
ENDDO
ENDDO
ENDDO
END SUBROUTINE interp_fcn_nn
!=========================================================================
SUBROUTINE interp_fcn_bl ( cfld, & ! CD field 2,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! Nest ratio, i- and j-directions
cht, nht, & ! topography for CG and FG
ct_max_p,nt_max_p, & ! temperature (K) at max press, want CG value
cght_max_p,nght_max_p, & ! height (m) at max press, want CG value
cmax_p,nmax_p, & ! max pressure (Pa) in column, want CG value
ct_min_p,nt_min_p, & ! temperature (K) at min press, want CG value
cght_min_p,nght_min_p, & ! height (m) at min press, want CG value
cmin_p,nmin_p, & ! min pressure (Pa) in column, want CG value
zn, p_top ) ! eta levels
USE module_timing
! USE module_configure
USE module_model_constants , ONLY : g , r_d, cp, p1000mb, t0
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cht, ct_max_p, cght_max_p, cmax_p, ct_min_p, cght_min_p, cmin_p
REAL, DIMENSION ( nims:nime, njms:njme ) :: nht, nt_max_p, nght_max_p, nmax_p, nt_min_p, nght_min_p, nmin_p
REAL, DIMENSION ( ckms:ckme ) :: zn
REAL :: p_top
REAL, EXTERNAL :: v_interp_col
! Local
INTEGER ci, cj, ni, nj, nk, istag, jstag, i, j, k
REAL :: wx, wy, nprs, cfld_ll, cfld_lr, cfld_ul, cfld_ur
REAL , DIMENSION(ckms:ckme) :: cprs
REAL :: p00 , t00 , a , tiso , p_surf
! Yes, memory sized to allow "outside the tile" indexing for horiz interpolation. This
! is really an intermediate domain that has quite a bit of usable real estate surrounding
! the tile dimensions.
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cpb
! A bit larger than tile sized to allow horizontal interpolation on the CG.
REAL, DIMENSION ( cits-2:cite+2, cjts-2:cjte+2 ) :: cfld_max_p, cfld_min_p
! The usual tile size for the FG local array.
REAL, DIMENSION ( nits:nite, nkts:nkte, njts:njte ) :: npb
! Get base state constants
CALL nl_get_base_pres ( 1 , p00 )
CALL nl_get_base_temp ( 1 , t00 )
CALL nl_get_base_lapse ( 1 , a )
CALL nl_get_iso_temp ( 1 , tiso )
! This stag stuff is to keep us away from the outer most row
! and column for the unstaggered directions. We are going to
! consider "U" an xstag variable and "V" a ystag variable. The
! vertical staggering is handled in the actual arguments. The
! ckte and nkte are the ending vertical dimensions for computations
! for this particular variable.
IF ( xstag ) THEN
istag = 0
ELSE
istag = 1
END IF
IF ( ystag ) THEN
jstag = 0
ELSE
jstag = 1
END IF
! Compute the reference pressure for the CG, function only of constants and elevation.
! We extend the i,j range to allow us to do horizontal interpolation. We only need
! one extra grid cell surrounding the nest, and the intermediate domain has plenty of
! room with the halos set up for higher-order interpolations. For intermediate domains,
! it turns out that the "domain" size actually fits within the "tile" size. Yeppers,
! that is backwards from what usually happens. That intermediate domain size is a couple
! grid points larger than necessary, and the tile is a couple of grid cells larger still.
! For our low-order interpolation, we can use the tile size for the CG, and we will have
! plenty of data on our boundaries.
DO j = cjts-2 , cjte+2
DO i = cits-2 , cite+2
p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*cht(i,j)/a/r_d ) **0.5 )
DO k = ckts , ckte
cpb(i,k,j) = zn(k)*(p_surf - p_top) + p_top
END DO
IF ( ckte .EQ. ckme ) THEN
cfld_max_p(i,j) = cght_max_p(i,j) * g
cfld_min_p(i,j) = cght_min_p(i,j) * g
ELSE
cfld_max_p(i,j) = ct_max_p(i,j) * (p1000mb/cmax_p(i,j))**(r_d/cp) - t0
cfld_min_p(i,j) = ct_min_p(i,j) * (p1000mb/cmin_p(i,j))**(r_d/cp) - t0
END IF
END DO
END DO
! Compute the reference pressure for the FG. This is actually the size of the entire
! domain, not some chopped down piece of intermediate domain, as in the parent
! grid. We do the traditional MAX(dom end -1,tile end), since we know a priori that the
! pressure is a mass point field (because the topo elevation is a mass point field).
DO j = njts , MIN(njde-1,njte)
DO i = nits , MIN(nide-1,nite)
p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*nht(i,j)/a/r_d ) **0.5 )
DO k = nkts , nkte
npb(i,k,j) = zn(k)*(p_surf - p_top) + p_top
END DO
END DO
END DO
! Loop over each j-index on this tile for the nested domain.
j_loop : DO nj = njts, MIN(njde-jstag,njte)
! This is the lower-left j-index of the CG.
! Example is 3:1 ratio, mass-point staggering. We have listed six CG values
! as an example: A, B, C, D, E, F. For a 3:1 ratio, each of these CG cells has
! nine associated FG points.
! |=========|=========|=========|
! | - - - | - - - | - - - |
! | | | |
! | - D - | - E - | - F - |
! | | | |
! | 1 2 3 | 4 5 6 | 7 8 9 |
! |=========|=========|=========|
! | - - - | - - - | - - - |
! | | | |
! | - A - | - B - | - C - |
! | | | |
! | - - - | - - - | - - - |
! |=========|=========|=========|
! To interpolate to FG point 4, we will use CG points: A, B, D, E. It is adequate to
! find the lower left point. The lower left (LL) point for "4" is "A". Below
! are a few more points.
! 2 => A
! 3 => A
! 4 => A
! 5 => B
! 6 => B
! 7 => B
! We want an equation that returns the CG LL:
! CG LL = ipos (the starting point of the nest in the CG)
! + (ni-1)/nri (gives us the CG cell, based on the nri-groups of FG cells
! - istag (a correction term, this is either zero for u in the x-dir,
! since we are doing an "i" example, or 1 for anything else)
! + (MOD(ni-1,nri)+1 + nri/2)/nri (gives us specifically related CG point for each of the nri
! FG points, for example, we want points "1", "4", and "7" all
! to point to the CG at the left for the LL point)
! For grid points 4, 5, 6, we want the CG LL (sans the first two terms) to be -1, 0, 0 (which
! means that the CG point for "4" is to the left, and the CG LL point for "5" and "6"
! is in the current CG index.
cj = jpos + (nj-1)/nrj - jstag + (MOD(nj-1,nrj)+1 + nrj/2)/nrj
! What is the weighting for this CG point to the FG point, j-weight only.
IF ( ystag ) THEN
wy = 1. - ( REAL(MOD(nj+(nrj-1)/2,nrj)) / REAL(nrj) + 1. / REAL (2 * nrj) )
ELSE
wy = 1. - ( REAL(MOD(nj+(nrj-1)/2,nrj)) / REAL(nrj) )
END IF
! Vertical dim of the nest domain.
k_loop : DO nk = nkts, nkte
! Loop over each i-index on this tile for the nested domain.
i_loop : DO ni = nits, MIN(nide-istag,nite)
! The coarse grid location that is to the lower left of the FG point.
ci = ipos + (ni-1)/nri - istag + (MOD(ni-1,nri)+1 + nri/2)/nri
! Weights in the x-direction.
IF ( xstag ) THEN
wx = 1. - ( REAL(MOD(ni+(nri-1)/2,nri)) / REAL(nri) + 1. / REAL (2 * nri) )
ELSE
wx = 1. - ( REAL(MOD(ni+(nri-1)/2,nri)) / REAL(nri) )
END IF
! The pressure of the FG point.
IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
nprs = npb( ni , nk , nj )
ELSE IF ( xstag ) THEN
nprs = ( npb( ni-1, nk , nj ) + npb( ni , nk , nj ) ) * 0.5
ELSE IF ( ystag ) THEN
nprs = ( npb( ni , nk , nj-1) + npb( ni , nk , nj ) ) * 0.5
END IF
! The four surrounding CG values.
IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
cprs(:) = cpb(ci ,:,cj )
cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , &
cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) )
cprs(:) = cpb(ci+1,:,cj )
cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , &
cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) )
cprs(:) = cpb(ci ,:,cj+1)
cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, &
cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) )
cprs(:) = cpb(ci+1,:,cj+1)
cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, &
cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
ELSE IF ( xstag ) THEN
cprs(:) = ( cpb(ci ,:,cj ) + cpb(ci-1,:,cj ) )*0.5
cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , &
cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) )
cprs(:) = ( cpb(ci+1,:,cj ) + cpb(ci ,:,cj ) )*0.5
cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , &
cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) )
cprs(:) = ( cpb(ci ,:,cj+1) + cpb(ci-1,:,cj+1) )*0.5
cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, &
cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) )
cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci ,:,cj+1) )*0.5
cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, &
cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
ELSE IF ( ystag ) THEN
cprs(:) = ( cpb(ci ,:,cj ) + cpb(ci ,:,cj-1) )*0.5
cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , &
cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) )
cprs(:) = ( cpb(ci+1,:,cj ) + cpb(ci+1,:,cj-1) )*0.5
cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , &
cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) )
cprs(:) = ( cpb(ci ,:,cj+1) + cpb(ci ,:,cj ) )*0.5
cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, &
cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) )
cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci+1,:,cj ) )*0.5
cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, &
cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
END IF
! Bilinear interpolation in horizontal with vertically corrected CG field values.
nfld( ni , nk , nj ) = wy * ( cfld_ll * wx + cfld_lr * (1.-wx) ) + &
(1.-wy) * ( cfld_ul * wx + cfld_ur * (1.-wx) )
END DO i_loop
END DO k_loop
END DO j_loop
! If this is ph_2, make the values at k=1 all zero
IF ( ckme .EQ. ckte ) THEN
DO nj = njts,njte
DO ni = nits, nite
nfld(ni,nkts,nj) = 0.0
END DO
END DO
END IF
END SUBROUTINE interp_fcn_bl
!==================================
FUNCTION v_interp_col ( cfld_orig , cprs_orig , ckms , ckme , ckte , nprs, ni, nj, nk, ci, cj, &,1
cfld_max_p , cmax_p , cfld_min_p , cmin_p ) RESULT ( cfld_interp )
IMPLICIT NONE
INTEGER , INTENT(IN) :: ni, nj, nk, ci, cj
INTEGER , INTENT(IN) :: ckms , ckme , ckte
REAL , DIMENSION(ckms:ckme) , INTENT(IN) :: cfld_orig , cprs_orig
REAL , INTENT(IN) :: cfld_max_p , cmax_p , cfld_min_p , cmin_p
REAL , INTENT(IN) :: nprs
REAL :: cfld_interp
! Local
INTEGER :: ck
LOGICAL :: found
CHARACTER(LEN=256) :: joe_mess
REAL , DIMENSION(ckms:ckme+1+1) :: cfld , cprs
! Fill input arrays
cfld(1) = cfld_max_p
cprs(1) = cmax_p
cfld(ckte+2) = cfld_min_p
cprs(ckte+2) = cmin_p
DO ck = ckms , ckte
cfld(ck+1) = cfld_orig(ck)
cprs(ck+1) = cprs_orig(ck)
END DO
found = .FALSE.
IF ( cprs(ckms) .LT. nprs ) THEN
cfld_interp = cfld(ckms)
RETURN
ELSE IF ( cprs(ckte+2) .GE. nprs ) THEN
cfld_interp = cfld(ckte+2)
RETURN
END IF
DO ck = ckms , ckte+1
IF ( ( cprs(ck ) .GE. nprs ) .AND. &
( cprs(ck+1) .LT. nprs ) ) THEN
cfld_interp = ( cfld(ck ) * ( nprs - cprs(ck+1) ) + &
cfld(ck+1) * ( cprs(ck) - nprs ) ) / &
( cprs(ck) - cprs(ck+1) )
RETURN
END IF
END DO
CALL wrf_error_fatal ( 'ERROR -- vertical interpolation for nest interp cannot find trapping pressures' )
END FUNCTION v_interp_col
!==================================
! this is the default function used in feedback.
SUBROUTINE copy_fcn ( cfld, & ! CD field,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ),INTENT(IN) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
INTEGER :: icmin,icmax,jcmin,jcmax
INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
INTEGER , PARAMETER :: passes = 2
INTEGER spec_zone
! Loop over the coarse grid in the area of the fine mesh. Do not
! process the coarse grid values that are along the lateral BC
! provided to the fine grid. Since that is in the specified zone
! for the fine grid, it should not be used in any feedback to the
! coarse grid as it should not have changed.
! Due to peculiarities of staggering, it is simpler to handle the feedback
! for the staggerings based upon whether it is a even ratio (2::1, 4::1, etc.) or
! an odd staggering ratio (3::1, 5::1, etc.).
! Though there are separate grid ratios for the i and j directions, this code
! is not general enough to handle aspect ratios .NE. 1 for the fine grid cell.
! These are local integer increments in the looping. Basically, istag=1 means
! that we will assume one less point in the i direction. Note that ci and cj
! have a maximum value that is decreased by istag and jstag, respectively.
! Horizontal momentum feedback is along the face, not within the cell. For a
! 3::1 ratio, temperature would use 9 pts for feedback, while u and v use
! only 3 points for feedback from the nest to the parent.
CALL nl_get_spec_zone( 1 , spec_zone )
istag = 1 ; jstag = 1
IF ( xstag ) istag = 0
IF ( ystag ) jstag = 0
IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio
IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + jstag + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + istag + 1
cfld( ci, ck, cj ) = 0.
DO ijpoints = 1 , nri * nrj
ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints )
END DO
! cfld( ci, ck, cj ) = 1./9. * &
! ( nfld( ni-1, nk , nj-1) + &
! nfld( ni , nk , nj-1) + &
! nfld( ni+1, nk , nj-1) + &
! nfld( ni-1, nk , nj ) + &
! nfld( ni , nk , nj ) + &
! nfld( ni+1, nk , nj ) + &
! nfld( ni-1, nk , nj+1) + &
! nfld( ni , nk , nj+1) + &
! nfld( ni+1, nk , nj+1) )
ENDDO
ENDDO
ENDDO
ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + jstag + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + istag + 1
cfld( ci, ck, cj ) = 0.
DO ijpoints = (nri+1)/2 , (nri+1)/2 + nri*(nri-1) , nri
ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints )
END DO
! cfld( ci, ck, cj ) = 1./3. * &
! ( nfld( ni , nk , nj-1) + &
! nfld( ni , nk , nj ) + &
! nfld( ni , nk , nj+1) )
ENDDO
ENDDO
ENDDO
ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + jstag + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + istag + 1
cfld( ci, ck, cj ) = 0.
DO ijpoints = ( nrj*nrj +1 )/2 - nrj/2 , ( nrj*nrj +1 )/2 - nrj/2 + nrj-1
ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
1./REAL( nrj) * nfld( ni+ipoints , nk , nj+jpoints )
END DO
! cfld( ci, ck, cj ) = 1./3. * &
! ( nfld( ni-1, nk , nj ) + &
! nfld( ni , nk , nj ) + &
! nfld( ni+1, nk , nj ) )
ENDDO
ENDDO
ENDDO
END IF
! Even refinement ratio
ELSE IF ( MOD(nrj,2) .EQ. 0) THEN
IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
! This is a simple schematic of the feedback indexing used in the even
! ratio nests. For simplicity, a 2::1 ratio is depicted. Only the
! mass variable staggering is shown.
! Each of
! the boxes with a "T" and four small "t" represents a coarse grid (CG)
! cell, that is composed of four (2::1 ratio) fine grid (FG) cells.
! Shown below is the area of the CG that is in the area of the FG. The
! first grid point of the depicted CG is the starting location of the nest
! in the parent domain (ipos,jpos - i_parent_start and j_parent_start from
! the namelist).
! For each of the CG points, the feedback loop is over each of the FG points
! within the CG cell. For a 2::1 ratio, there are four total points (this is
! the ijpoints loop). The feedback value to the CG is the arithmetic mean of
! all of the FG values within each CG cell.
! |-------------||-------------| |-------------||-------------|
! | t t || t t | | t t || t t |
! jpos+ | || | | || |
! (njde-njds)- | T || T | | T || T |
! jstag | || | | || |
! | t t || t t | | t t || t t |
! |-------------||-------------| |-------------||-------------|
! |-------------||-------------| |-------------||-------------|
! | t t || t t | | t t || t t |
! | || | | || |
! | T || T | | T || T |
! | || | | || |
! | t t || t t | | t t || t t |
! |-------------||-------------| |-------------||-------------|
!
! ...
! ...
! ...
! ...
! ...
! |-------------||-------------| |-------------||-------------|
! jpoints = 1 | t t || t t | | t t || t t |
! | || | | || |
! | T || T | | T || T |
! | || | | || |
! jpoints = 0, | t t || t t | | t t || t t |
! nj=3 |-------------||-------------| |-------------||-------------|
! |-------------||-------------| |-------------||-------------|
! jpoints = 1 | t t || t t | | t t || t t |
! | || | | || |
! jpos | T || T | ... | T || T |
! | || | ... | || |
! jpoints = 0, | t t || t t | ... | t t || t t |
! nj=1 |-------------||-------------| |-------------||-------------|
! ^ ^
! | |
! | |
! ipos ipos+
! ni = 1 3 (nide-nids)/nri
! ipoints= 0 1 0 1 -istag
!
! For performance benefits, users can comment out the inner most loop (and cfld=0) and
! hardcode the loop feedback. For example, it is set up to run a 2::1 ratio
! if uncommented. This lacks generality, but is likely to gain timing benefits
! with compilers unable to unroll inner loops that do not have parameterized sizes.
! The extra +1 ---------/ and the extra -1 ----\ (both for ci and cj)
! / \ keeps the feedback out of the
! / \ outer row/col, since that CG data
! / \ specified the nest boundary originally
! / \ This
! / \ is just
! / \ a sentence to not end a line
! / \ with a stupid backslash
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + jstag
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + istag
cfld( ci, ck, cj ) = 0.
DO ijpoints = 1 , nri * nrj
ipoints = MOD((ijpoints-1),nri)
jpoints = (ijpoints-1)/nri
cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints )
END DO
! cfld( ci, ck, cj ) = 1./4. * &
! ( nfld( ni , nk , nj ) + &
! nfld( ni+1, nk , nj ) + &
! nfld( ni , nk , nj+1) + &
! nfld( ni+1, nk , nj+1) )
END DO
END DO
END DO
! U
ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN
! |---------------|
! | |
! jpoints = 1 u u |
! | |
! U |
! | |
! jpoints = 0, u u |
! nj=3 | |
! |---------------|
! |---------------|
! | |
! jpoints = 1 u u |
! | |
! jpos U |
! | |
! jpoints = 0, u u |
! nj=1 | |
! |---------------|
!
! ^
! |
! |
! ipos
! ni = 1 3
! ipoints= 0 1 0
!
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + 1
cfld( ci, ck, cj ) = 0.
DO ijpoints = 1 , nri*nrj , nri
ipoints = MOD((ijpoints-1),nri)
jpoints = (ijpoints-1)/nri
cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints )
END DO
! cfld( ci, ck, cj ) = 1./2. * &
! ( nfld( ni , nk , nj ) + &
! nfld( ni , nk , nj+1) )
ENDDO
ENDDO
ENDDO
! V
ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + 1
cfld( ci, ck, cj ) = 0.
DO ijpoints = 1 , nri
ipoints = MOD((ijpoints-1),nri)
jpoints = (ijpoints-1)/nri
cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints )
END DO
! cfld( ci, ck, cj ) = 1./2. * &
! ( nfld( ni , nk , nj ) + &
! nfld( ni+1, nk , nj ) )
ENDDO
ENDDO
ENDDO
END IF
END IF
RETURN
END SUBROUTINE copy_fcn
!==================================
! this is the 1pt function used in feedback.
SUBROUTINE copy_fcnm ( cfld, & ! CD field,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
USE module_wrf_error
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
INTEGER :: icmin,icmax,jcmin,jcmax
INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
INTEGER , PARAMETER :: passes = 2
INTEGER spec_zone
CALL nl_get_spec_zone( 1, spec_zone )
istag = 1 ; jstag = 1
IF ( xstag ) istag = 0
IF ( ystag ) jstag = 0
IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + jstag + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + istag + 1
cfld( ci, ck, cj ) = nfld( ni , nk , nj )
ENDDO
ENDDO
ENDDO
ELSE ! even refinement ratio, pick nearest neighbor on SW corner
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + 1
ipoints = nri/2 -1
jpoints = nrj/2 -1
cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints )
END DO
END DO
END DO
END IF
RETURN
END SUBROUTINE copy_fcnm
!==================================
! this is the 1pt function used in feedback for integers
SUBROUTINE copy_fcni ( cfld, & ! CD field,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
USE module_wrf_error
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
INTEGER :: icmin,icmax,jcmin,jcmax
INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
INTEGER , PARAMETER :: passes = 2
INTEGER spec_zone
CALL nl_get_spec_zone( 1, spec_zone )
istag = 1 ; jstag = 1
IF ( xstag ) istag = 0
IF ( ystag ) jstag = 0
IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + jstag + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + istag + 1
cfld( ci, ck, cj ) = nfld( ni , nk , nj )
ENDDO
ENDDO
ENDDO
ELSE ! even refinement ratio
DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
nj = (cj-jpos)*nrj + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
ni = (ci-ipos)*nri + 1
ipoints = nri/2 -1
jpoints = nrj/2 -1
cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints )
END DO
END DO
END DO
END IF
RETURN
END SUBROUTINE copy_fcni
!==================================
SUBROUTINE vert_interp_vert_nesting ( cfld, & ! CD field 1,1
ids, ide, kds, kde, jds, jde, &
ims, ime, kms, kme, jms, jme, &
its, ite, kts, kte, jts, jte, &
pgrid_s_vert, pgrid_e_vert, & ! vertical dimensions of parent grid
cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c, & ! coarse grid extrapolation constants
alt_u_c, alt_u_n)
!KAL vertical interpolation for u, v, and mass points (w is below in a different subroutine) for vertical nesting
IMPLICIT NONE
REAL, DIMENSION ( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: cfld
INTEGER, INTENT(IN) :: ids, ide, kds, kde, jds, jde, &
ims, ime, kms, kme, jms, jme, &
its, ite, kts, kte, jts, jte
INTEGER, INTENT(IN) :: pgrid_s_vert, pgrid_e_vert ! vertical dimensions of the parent grid
REAL, INTENT(IN) :: cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c
REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1), INTENT(IN) :: alt_u_c
REAL, DIMENSION(kde+1), INTENT(IN) :: alt_u_n
!local
INTEGER :: i,j,k
REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1) :: pro_u_c ! variable in 1D on the coarse grid
REAL, DIMENSION(kde+1) :: pro_u_n
DO j = jms,jme
DO i = ims,ime
! pro_u_c is u on the 1D coarse grid
do k = pgrid_s_vert,pgrid_e_vert-1
pro_u_c(k+1) = cfld(i,k,j)
enddo
!KAL fill in the surface value and the top value using extrapolation
pro_u_c(1 ) = cf1_c*cfld(i,1,j) &
+ cf2_c*cfld(i,2,j) &
+ cf3_c*cfld(i,3,j)
pro_u_c(pgrid_e_vert+1) = cfn_c *cfld(i,pgrid_e_vert-1,j) &
+ cfn1_c*cfld(i,pgrid_e_vert-2,j)
call inter_wrf_copy(pro_u_c, alt_u_c, pgrid_e_vert+1, pro_u_n, alt_u_n, kde+1)
do k = 1,kde-1
cfld(i,k,j) = pro_u_n(k+1)
enddo
ENDDO
ENDDO
END SUBROUTINE vert_interp_vert_nesting
!==================================
SUBROUTINE vert_interp_vert_nesting_w ( cfld, & ! CD field,1
ids, ide, kds, kde, jds, jde, &
ims, ime, kms, kme, jms, jme, &
its, ite, kts, kte, jts, jte, &
pgrid_s_vert, pgrid_e_vert, & ! vertical dimensions of parent grid
alt_w_c, alt_w_n)
!KAL vertical interpolation at w points for vertical nesting
IMPLICIT NONE
REAL, DIMENSION ( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: cfld
INTEGER, INTENT(IN) :: ids, ide, kds, kde, jds, jde, &
ims, ime, kms, kme, jms, jme, &
its, ite, kts, kte, jts, jte
INTEGER, INTENT(IN) :: pgrid_s_vert, pgrid_e_vert ! vertical dimensions of the parent grid
REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert), INTENT(IN) :: alt_w_c
REAL, DIMENSION(kde), INTENT(IN) :: alt_w_n
!local
INTEGER :: i,j,k
REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert) :: pro_w_c ! variable in 1D on the coarse grid
REAL, DIMENSION(kde) :: pro_w_n
DO j = jms,jme
DO i = ims,ime
! pro_w_c is w on the 1D coarse grid
do k = pgrid_s_vert,pgrid_e_vert
pro_w_c(k) = cfld(i,k,j)
enddo
call inter_wrf_copy(pro_w_c, alt_w_c, pgrid_e_vert, pro_w_n, alt_w_n, kde)
do k = 1,kde
cfld(i,k,j) = pro_w_n(k)
enddo
ENDDO
ENDDO
END SUBROUTINE vert_interp_vert_nesting_w
!-----------------------------------------------------------------------------------------
SUBROUTINE vert_interp_vert_nesting_1d ( cfld, & ! CD field 5,1
ids, ide, kds, kde, jds, jde, &
ims, ime, kms, kme, jms, jme, &
its, ite, kts, kte, jts, jte, &
pgrid_s_vert, pgrid_e_vert, & ! vertical dimensions of parent grid
cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c, & ! coarse grid extrapolation constants
alt_u_c, alt_u_n)
!KAL vertical interpolation for u, v, and mass points (w is below in a different subroutine) for vertical nesting
IMPLICIT NONE
REAL, DIMENSION (kms:kme),INTENT(INOUT) :: cfld
INTEGER, INTENT(IN) :: ids, ide, kds, kde, jds, jde, &
ims, ime, kms, kme, jms, jme, &
its, ite, kts, kte, jts, jte
INTEGER, INTENT(IN) :: pgrid_s_vert, pgrid_e_vert ! vertical dimensions of the parent grid
REAL, INTENT(IN) :: cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c
REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1), INTENT(IN) :: alt_u_c
REAL, DIMENSION(kde+1), INTENT(IN) :: alt_u_n
!local
INTEGER :: i,j,k
REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1) :: pro_u_c ! variable in 1D on the coarse grid
REAL, DIMENSION(kde+1) :: pro_u_n
! pro_u_c is u on the 1D coarse grid
do k = pgrid_s_vert,pgrid_e_vert-1
pro_u_c(k+1) = cfld(k)
enddo
!KAL fill in the surface value and the top value using extrapolation
pro_u_c(1 ) = cf1_c*cfld(1) &
+ cf2_c*cfld(2) &
+ cf3_c*cfld(3)
pro_u_c(pgrid_e_vert+1) = cfn_c *cfld(pgrid_e_vert-1) &
+ cfn1_c*cfld(pgrid_e_vert-2)
call inter_wrf_copy(pro_u_c, alt_u_c, pgrid_e_vert+1, pro_u_n, alt_u_n, kde+1)
do k = 1,kde-1
cfld(k) = pro_u_n(k+1)
enddo
END SUBROUTINE vert_interp_vert_nesting_1d
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!KAL this is a direct copy of a subroutine from ndown, but a dependency on ndown will not work because it is not always compiled (for ideal cases), and most likely not compliled in the order needed.
SUBROUTINE inter_wrf_copy(pro_c,alt_c,kde_c,pro_n,alt_n,kde_n) 3,1
!KAL this routine has been added for vertical nesting
IMPLICIT NONE
INTEGER , INTENT(IN) :: kde_c,kde_n
REAL , DIMENSION(kde_c) , INTENT(IN ) :: pro_c,alt_c
REAL , DIMENSION(kde_n) , INTENT(IN ) :: alt_n
REAL , DIMENSION(kde_n) , INTENT(OUT) :: pro_n
real ,dimension(kde_c) :: a,b,c,d
real :: p
integer :: i,j
call coeff_mon_wrf_copy(alt_c,pro_c,a,b,c,d,kde_c)
do i = 1,kde_n-1
do j=1,kde_c-1
if ( (alt_n(i) .ge. alt_c(j)).and.(alt_n(i) .lt. alt_c(j+1)) ) then
p = alt_n(i)-alt_c(j)
pro_n(i) = p*( p*(a(j)*p+b(j))+c(j)) + d(j)
goto 20
endif
enddo
20 continue
enddo
pro_n(kde_n) = pro_c(kde_c)
END SUBROUTINE inter_wrf_copy
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11
!KAL this is a direct copy of a subroutine from ndown, but a dependency on ndown will not work because it is not always compiled (for ideal cases), and most likely not compliled in the order needed.
subroutine coeff_mon_wrf_copy(x,y,a,b,c,d,n) 1
!KAL this routine has been added for vertical nesting
implicit none
integer :: n
real ,dimension(n) :: x,y,a,b,c,d
real ,dimension(n) :: h,s,p,yp
integer :: i
do i=1,n-1
h(i) = (x(i+1)-x(i))
s(i) = (y(i+1)-y(i)) / h(i)
enddo
do i=2,n-1
p(i) = (s(i-1)*h(i)+s(i)*h(i-1)) / (h(i-1)+h(i))
enddo
p(1) = s(1)
p(n) = s(n-1)
do i=1,n
yp(i) = p(i)
enddo
!!!!!!!!!!!!!!!!!!!!!
do i=2,n-1
yp(i) = (sign(1.,s(i-1))+sign(1.,s(i)))* min( abs(s(i-1)),abs(s(i)),0.5*abs(p(i)))
enddo
do i = 1,n-1
a(i) = (yp(i)+yp(i+1)-2.*s(i))/(h(i)*h(i))
b(i) = (3.*s(i)-2.*yp(i)-yp(i+1))/h(i)
c(i) = yp(i)
d(i) = y(i)
enddo
end subroutine coeff_mon_wrf_copy
!-----------------------------------------------------------------------------------------
!==================================
SUBROUTINE p2c ( cfld, & ! CD field 36,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj & ! nest ratios
)
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
CALL interp_fcn (cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
END SUBROUTINE p2c
!==================================
SUBROUTINE c2f_interp ( cfld, & ! CD field,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
! cbdy_xs, nbdy_xs, &
! cbdy_xe, nbdy_xe, &
! cbdy_ys, nbdy_ys, &
! cbdy_ye, nbdy_ye, &
! cbdy_txs, nbdy_txs, &
! cbdy_txe, nbdy_txe, &
! cbdy_tys, nbdy_tys, &
! cbdy_tye, nbdy_tye, &
parent_id,nest_id &!cyl
) ! boundary arrays
USE module_configure
IMPLICIT NONE
!------------------------------------------------------------
! Subroutine c2f_interp interpolate field from coarse resolution domain
! to its nested domain. It is written by Dave Gill in NCAR for the purpose
! running phys/module_sf_oml.F-DPWP in only d01 and d02
! Chiaying Lee RSMAS/UM
!------------------------------------------------------------
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj,parent_id,nest_id !cyl
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs
! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe
! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys
! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye
REAL cdt, ndt
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
! Iterate over the ND tile and compute the values
! from the CD tile.
!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
! write(0,*)'cyl parentid',parent_id
! write(0,*)'cyl nestid',nest_id
! If ( nest_id .le. 2 .and. (1.0/rdx .ge. 3000.0 .and. 1.0/rdy .ge. 3000.0) ) then ! cyl: only run it in the nest domain with dx, dy < 3 km
If ( nest_id .eq. 3 ) then
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
jp = mod ( nj , nrj ) ! coord of ND w/i CD point
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
ci = ipos + (ni-1) / nri ! j coord of CD point
ip = mod ( ni , nri ) ! coord of ND w/i CD point
! This is a trivial implementation of the interp_fcn; just copies
! the values from the CD into the ND
nfld( ni, nk, nj ) = cfld( ci , ck , cj )
ENDDO
ENDDO
ENDDO
ENDIF ! cyl
RETURN
END SUBROUTINE c2f_interp
!==================================
SUBROUTINE bdy_interp ( cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
cbdy_xs, nbdy_xs, & ! Boundary components, for the CG and FG,
cbdy_xe, nbdy_xe, & ! for each of the four sides (x start, e end, y start, y end)
cbdy_ys, nbdy_ys, & ! and also for the two components of the LBC:
cbdy_ye, nbdy_ye, & ! the "starting" value and the tendency
cbdy_txs, nbdy_txs, &
cbdy_txe, nbdy_txe, & ! The CG is at a parent time step ahead of the FG
cbdy_tys, nbdy_tys, &
cbdy_tye, nbdy_tye, &
cdt, ndt ) ! Time step size for CG and FG
USE module_interp_info
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs
REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe
REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys
REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye
REAL cdt, ndt
! Local
INTEGER nijds, nijde, spec_bdy_width
nijds = min(nids, njds)
nijde = max(nide, njde)
CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
IF ( interp_method_type .EQ. NOT_DEFINED_YET ) THEN
interp_method_type = SINT
END IF
IF ( interp_method_type .EQ. SINT ) THEN
CALL bdy_interp1( cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nijds, nijde , & ! start and end of nest LBC size in the LONG direction
spec_bdy_width , & ! width of the LBC, the SHORT direction
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, imask, &
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
cbdy_xs, nbdy_xs, & ! Boundary components, for the CG and FG,
cbdy_xe, nbdy_xe, & ! for each of the four sides (x start, e end, y start, y end)
cbdy_ys, nbdy_ys, & ! and also for the two components of the LBC:
cbdy_ye, nbdy_ye, & ! the "starting" value and the tendency
cbdy_txs, nbdy_txs, &
cbdy_txe, nbdy_txe, & ! The CG is at a parent time step ahead of the FG
cbdy_tys, nbdy_tys, &
cbdy_tye, nbdy_tye, &
cdt, ndt & ! Time step size for CG and FG
)
ELSE IF ( ( interp_method_type .EQ. BILINEAR ) .OR. &
( interp_method_type .EQ. NEAREST_NEIGHBOR ) .OR. &
( interp_method_type .EQ. QUADRATIC ) .OR. &
( interp_method_type .EQ. SPLINE ) .OR. &
( interp_method_type .EQ. SINT_NEW ) ) THEN
CALL bdy_interp2( cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nijds, nijde , & ! start and end of nest LBC size in the LONG direction
spec_bdy_width , & ! width of the LBC, the SHORT direction
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, imask, &
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
cbdy_xs, nbdy_xs, & ! Boundary components, for the CG and FG,
cbdy_xe, nbdy_xe, & ! for each of the four sides (x start, e end, y start, y end)
cbdy_ys, nbdy_ys, & ! and also for the two components of the LBC:
cbdy_ye, nbdy_ye, & ! the "starting" value and the tendency
cbdy_txs, nbdy_txs, &
cbdy_txe, nbdy_txe, & ! The CG is at a parent time step ahead of the FG
cbdy_tys, nbdy_tys, &
cbdy_tye, nbdy_tye, &
cdt, ndt & ! Time step size for CG and FG
)
ELSE
CALL wrf_error_fatal ('Hold on there cowboy #2, we need to know which nested lateral boundary interpolation option you want')
END IF
END SUBROUTINE bdy_interp
!==================================
SUBROUTINE bdy_interp1( cfld, & ! CD field 1,5
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nijds, nijde, spec_bdy_width , &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw1, &
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
cbdy_xs, bdy_xs, &
cbdy_xe, bdy_xe, &
cbdy_ys, bdy_ys, &
cbdy_ye, bdy_ye, &
cbdy_txs, bdy_txs, &
cbdy_txe, bdy_txe, &
cbdy_tys, bdy_tys, &
cbdy_tye, bdy_tye, &
cdt, ndt &
)
! USE module_configure , ONLY : nl_get_spec_zone, nl_get_relax_zone
USE module_state_description
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw1, & ! ignore
ipos, jpos, &
nri, nrj
INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs ! not used
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe ! not used
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys ! not used
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye ! not used
REAL :: cdt, ndt
REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs
REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe
REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys
REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye
! Local
REAL*8 rdt
INTEGER ci, cj, ck, ni, nj, nk, ni1, nj1, nk1, ip, jp, ioff, joff
INTEGER nfx, ior
PARAMETER (ior=2)
INTEGER nf
REAL psca1(cims:cime,cjms:cjme,nri*nrj)
REAL psca(cims:cime,cjms:cjme,nri*nrj)
LOGICAL icmask( cims:cime, cjms:cjme )
INTEGER i,j,k
INTEGER shw
INTEGER spec_zone
INTEGER relax_zone
INTEGER sz
INTEGER n2ci,n
INTEGER n2cj
! statement functions for converting a nest index to coarse
n2ci(n) = (n+ipos*nri-1)/nri
n2cj(n) = (n+jpos*nrj-1)/nrj
rdt = 1.D0/cdt
shw = 0
ioff = 0 ; joff = 0
IF ( xstag ) THEN
ioff = MAX((nri-1)/2,1)
ENDIF
IF ( ystag ) THEN
joff = MAX((nrj-1)/2,1)
ENDIF
! Iterate over the ND tile and compute the values
! from the CD tile.
CALL nl_get_spec_zone( 1, spec_zone )
CALL nl_get_relax_zone( 1, relax_zone )
sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width)
nfx = nri * nrj
!$OMP PARALLEL DO &
!$OMP PRIVATE ( i,j,k,ni,nj,ni1,nj1,ci,cj,ip,jp,nk,ck,nf,icmask,psca,psca1 )
DO k = ckts, ckte
DO nf = 1,nfx
DO j = cjms,cjme
nj = (j-jpos) * nrj + ( nrj / 2 + 1 ) ! j point on nest
DO i = cims,cime
ni = (i-ipos) * nri + ( nri / 2 + 1 ) ! i point on nest
psca1(i,j,nf) = cfld(i,k,j)
ENDDO
ENDDO
ENDDO
! hopefully less ham handed but still correct and more efficient
! sintb ignores icmask so it does not matter that icmask is not set
!
! SOUTH BDY
IF ( njts .ge. njds .and. njts .le. njds + sz + joff ) THEN
CALL sintb( psca1, psca, &
cims, cime, cjms, cjme, icmask, &
n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njds)), n2cj(MIN(njte,njds+sz+joff)), nrj*nri, xstag, ystag )
ENDIF
! NORTH BDY
IF ( njte .le. njde .and. njte .ge. njde - sz - joff ) THEN
CALL sintb( psca1, psca, &
cims, cime, cjms, cjme, icmask, &
n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njde-sz-joff)), n2cj(MIN(njte,njde-1+joff)), nrj*nri, xstag, ystag )
ENDIF
! WEST BDY
IF ( nits .ge. nids .and. nits .le. nids + sz + ioff ) THEN
CALL sintb( psca1, psca, &
cims, cime, cjms, cjme, icmask, &
n2ci(MAX(nits,nids)), n2ci(MIN(nite,nids+sz+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag )
ENDIF
! EAST BDY
IF ( nite .le. nide .and. nite .ge. nide - sz - ioff ) THEN
CALL sintb( psca1, psca, &
cims, cime, cjms, cjme, icmask, &
n2ci(MAX(nits,nide-sz-ioff)), n2ci(MIN(nite,nide-1+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag )
ENDIF
DO nj1 = MAX(njds,njts-1), MIN(njde+joff,njte+joff+1)
cj = jpos + (nj1-1) / nrj ! j coord of CD point
jp = mod ( nj1-1 , nrj ) ! coord of ND w/i CD point
nk = k
ck = nk
DO ni1 = MAX(nids,nits-1), MIN(nide+ioff,nite+ioff+1)
ci = ipos + (ni1-1) / nri ! j coord of CD point
ip = mod ( ni1-1 , nri ) ! coord of ND w/i CD point
ni = ni1-ioff
nj = nj1-joff
IF ( ( ni.LT.nids) .OR. (nj.LT.njds) ) THEN
CYCLE
END IF
!bdy contains the value at t-dt. psca contains the value at t
!compute dv/dt and store in bdy_t
!afterwards store the new value of v at t into bdy
! WEST
IF ( ni .ge. nids .and. ni .lt. nids + sz ) THEN
bdy_txs( nj,k,ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy_xs( nj,k,ni ) = nfld(ni,k,nj)
ENDIF
! SOUTH
IF ( nj .ge. njds .and. nj .lt. njds + sz ) THEN
bdy_tys( ni,k,nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy_ys( ni,k,nj ) = nfld(ni,k,nj)
ENDIF
! EAST
IF ( xstag ) THEN
IF ( ni .ge. nide - sz + 1 .AND. ni .le. nide ) THEN
bdy_txe( nj,k,nide-ni+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy_xe( nj,k,nide-ni+1 ) = nfld(ni,k,nj)
ENDIF
ELSE
IF ( ni .ge. nide - sz .AND. ni .le. nide-1 ) THEN
bdy_txe( nj,k,nide-ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy_xe( nj,k,nide-ni ) = nfld(ni,k,nj)
ENDIF
ENDIF
! NORTH
IF ( ystag ) THEN
IF ( nj .ge. njde - sz + 1 .AND. nj .le. njde ) THEN
bdy_tye( ni,k,njde-nj+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy_ye( ni,k,njde-nj+1 ) = nfld(ni,k,nj)
ENDIF
ELSE
IF ( nj .ge. njde - sz .AND. nj .le. njde-1 ) THEN
bdy_tye(ni,k,njde-nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy_ye( ni,k,njde-nj ) = nfld(ni,k,nj)
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
RETURN
END SUBROUTINE bdy_interp1
!==================================
SUBROUTINE bdy_interp2( cfld, & ! CD field 1,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nijds, nijde, spec_bdy_width , &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw1, &
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
cbdy_xs, bdy_xs, &
cbdy_xe, bdy_xe, &
cbdy_ys, bdy_ys, &
cbdy_ye, bdy_ye, &
cbdy_txs, bdy_txs, &
cbdy_txe, bdy_txe, &
cbdy_tys, bdy_tys, &
cbdy_tye, bdy_tye, &
cdt, ndt &
)
! USE module_configure , ONLY : nl_get_spec_zone, nl_get_relax_zone
! USE module_state_description
USE module_interp_info
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw1, & ! ignore
ipos, jpos, &
nri, nrj
INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs ! not used
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe ! not used
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys ! not used
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye ! not used
REAL :: cdt, ndt
REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs
REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe
REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys
REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye
! Local
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld_horiz_interp ! mem dimensioned on purpose
! to allow interpolating routine
! to assume this is a mem
! sized array
INTEGER ni, nj, nk, istag, jstag
INTEGER shw
INTEGER spec_zone
INTEGER relax_zone
INTEGER sz
REAL*8 rdt
shw = 0 ! dummy, not used, but needed for the calling interface
! Horizontally interpolate the CG to the FG, store in nfld_horiz_interp
CALL interp_fcn ( cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld_horiz_interp, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
MAX(nits-nri,nids),MIN(nite+nri,nide),&
nkts, nkte, &
MAX(njts-nrj,njds),MIN(njte+nrj,njde),&
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
! ipos-1, jpos-1, & ! Position of lower left of nest in CD
nri, nrj ) ! Nest ratio, i- and j-directions
! Staggering, to determine loop indexes
IF ( xstag ) THEN
istag = 0
ELSE
istag = 1
END IF
IF ( ystag ) THEN
jstag = 0
ELSE
jstag = 1
END IF
! CG time step reciprocal, for computing tendencies.
rdt = 1.D0/cdt
CALL nl_get_spec_zone( 1, spec_zone )
CALL nl_get_relax_zone( 1, relax_zone )
! Belt and suspenders ... sz is just spec_bdy_width.
sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width)
!$OMP PARALLEL DO &
!$OMP PRIVATE ( ni,nj,nk )
DO nj = MAX ( njts-nrj, njds ) , MIN ( njte+nrj, njde-jstag )
DO nk = nkts, nkte
DO ni = MAX( nits-nri, nids ) , MIN ( nite+nri, nide-istag )
! WEST boundary
IF ( ni .LT. nids + sz ) THEN
bdy_txs(nj,nk,ni) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj))
bdy_xs (nj,nk,ni) = nfld(ni,nk,nj)
END IF
! SOUTH boundary
IF ( nj .LT. njds + sz ) THEN
bdy_tys(ni,nk,nj) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj))
bdy_ys (ni,nk,nj) = nfld(ni,nk,nj)
END IF
! EAST boundary
IF ( xstag ) THEN
IF ( ( ni .GE. nide - sz + 1 ) .AND. ( ni .LE. nide ) ) THEN
bdy_txe(nj,nk,nide-ni+1) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj))
bdy_xe (nj,nk,nide-ni+1) = nfld(ni,nk,nj)
END IF
ELSE
IF ( ( ni .GE. nide - sz ) .AND. ( ni .LE. nide-1 ) ) THEN
bdy_txe(nj,nk,nide-ni ) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj))
bdy_xe (nj,nk,nide-ni ) = nfld(ni,nk,nj)
END IF
END IF
! NORTH boundary
IF ( ystag ) THEN
IF ( ( nj .GE. njde - sz + 1 ) .AND. ( nj .LE. njde ) ) THEN
bdy_tye(ni,nk,njde-nj+1) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj))
bdy_ye (ni,nk,njde-nj+1) = nfld(ni,nk,nj)
END IF
ELSE
IF ( ( nj .GE. njde - sz ) .AND. ( nj .LE. njde-1 ) ) THEN
bdy_tye(ni,nk,njde-nj ) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj))
bdy_ye (ni,nk,njde-nj ) = nfld(ni,nk,nj)
END IF
END IF
END DO ! nest i
END DO ! nest k
END DO ! nest j
!$OMP END PARALLEL DO
END SUBROUTINE bdy_interp2
!==================================
SUBROUTINE interp_fcni( cfld, & ! CD field,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
! Iterate over the ND tile and compute the values
! from the CD tile.
!write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
!write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
jp = mod ( nj , nrj ) ! coord of ND w/i CD point
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
if ( imask(ni,nj) .NE. 1 ) cycle
ci = ipos + (ni-1) / nri ! j coord of CD point
ip = mod ( ni , nri ) ! coord of ND w/i CD point
! This is a trivial implementation of the interp_fcn; just copies
! the values from the CD into the ND
nfld( ni, nk, nj ) = cfld( ci , ck , cj )
ENDDO
ENDDO
ENDDO
RETURN
END SUBROUTINE interp_fcni
SUBROUTINE interp_fcnm( cfld, & ! CD field,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
! Iterate over the ND tile and compute the values
! from the CD tile.
!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
jp = mod ( nj , nrj ) ! coord of ND w/i CD point
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
ci = ipos + (ni-1) / nri ! j coord of CD point
ip = mod ( ni , nri ) ! coord of ND w/i CD point
! This is a trivial implementation of the interp_fcn; just copies
! the values from the CD into the ND
nfld( ni, nk, nj ) = cfld( ci , ck , cj )
ENDDO
ENDDO
ENDDO
RETURN
END SUBROUTINE interp_fcnm
SUBROUTINE interp_fcnm_lu( cfld, & ! CD field,6
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
cxlat, nxlat, &
cxlong, nxlong, &
cdx, ndx, &
cid, nid )
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj, &
cid, nid
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, INTENT(IN) :: cdx, ndx
REAL, INTENT(IN), DIMENSION ( cims:cime, cjms:cjme ) :: cxlat, cxlong
REAL, INTENT(IN), DIMENSION ( nims:nime, njms:njme ) :: nxlat, nxlong
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Local
INTEGER i, ci, cj, ck, ni, nj, nk, ip, jp, ierr
#ifdef TERRAIN_AND_LANDUSE
INTEGER, DIMENSION(256) :: ipath ! array for integer coded ascii for passing path down to get_landuse
REAL , ALLOCATABLE, DIMENSION(:,:) :: xlat_g, xlon_g, landuse_g
CHARACTER*256 :: message
CHARACTER*256 :: rsmas_data_path
LOGICAL :: input_from_hires, input_from_file
INTEGER, EXTERNAL :: get_landuse
LOGICAL, EXTERNAL :: wrf_dm_on_monitor
CALL nl_get_input_from_hires( nid , input_from_hires)
CALL nl_get_input_from_file ( nid , input_from_file )
IF ( input_from_file .AND. input_from_hires ) THEN
Write(message, '(a,i3,a)') &
"Warning : input_from_file turned on for domain ", nid, ", input_from_hires disabled"
CALL wrf_message(message)
END IF
IF ( .NOT. input_from_file .AND. input_from_hires ) THEN
allocate(xlat_g(nids:nide,njds:njde))
allocate(xlon_g(nids:nide,njds:njde))
allocate(landuse_g(nids:nide,njds:njde))
CALL nl_get_rsmas_data_path(1,rsmas_data_path)
DO i = 1, LEN(TRIM(rsmas_data_path))
ipath(i) = ICHAR(rsmas_data_path(i:i))
ENDDO
#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
CALL wrf_patch_to_global_real ( nxlat, xlat_g , nid, ' ' , 'xy' , &
nids, nide-1 , njds , njde-1 , 1 , 1 , &
nims, nime , njms , njme , 1 , 1 , &
nits, nite , njts , njte , 1 , 1 )
CALL wrf_patch_to_global_real ( nxlong, xlon_g, nid, ' ' , 'xy' , &
nids, nide-1 , njds , njde-1 , 1 , 1 , &
nims, nime , njms , njme , 1 , 1 , &
nits, nite , njts , njte , 1 , 1 )
IF ( wrf_dm_on_monitor() ) THEN
ierr = get_landuse ( ndx/1000., xlat_g, xlon_g, &
landuse_g, &
nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1, &
ipath, LEN(TRIM(rsmas_data_path)) )
IF ( ierr == 1 ) THEN
WRITE(message,fmt='(a)') 'get_landuse : aborted!'
CALL wrf_error_fatal(TRIM(message))
ENDIF
ENDIF
CALL wrf_global_to_patch_real ( landuse_g , nfld(:,1,:), nid, ' ' , 'xy' , &
nids, nide-1 , njds , njde-1 , 1 , 1 , &
nims, nime , njms , njme , 1 , 1 , &
nits, nite , njts , njte , 1 , 1 )
#else
ierr = get_landuse ( ndx/1000., nxlat(nids:nide,njds:njde), nxlong(nids:nide,njds:njde), &
nfld(nids:nide,1,njds:njde), &
nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1, &
ipath, LEN(TRIM(rsmas_data_path)) )
#endif
deallocate(xlat_g)
deallocate(xlon_g)
deallocate(landuse_g)
ELSE
#endif
! Iterate over the ND tile and compute the values
! from the CD tile.
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
jp = mod ( nj , nrj ) ! coord of ND w/i CD point
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
ci = ipos + (ni-1) / nri ! j coord of CD point
ip = mod ( ni , nri ) ! coord of ND w/i CD point
! This is a trivial implementation of the interp_fcn; just copies
! the values from the CD into the ND
if ( imask(ni,nj) .eq. 1 ) then
nfld( ni, nk, nj ) = cfld( ci , ck , cj )
endif
ENDDO
ENDDO
ENDDO
#ifdef TERRAIN_AND_LANDUSE
END IF
#endif
RETURN
END SUBROUTINE interp_fcnm_lu
SUBROUTINE interp_fcnm_imask( cfld, & ! CD field,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
! Iterate over the ND tile and compute the values
! from the CD tile.
!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte,cjts,cjte
!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte,njts,njte
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
jp = mod ( nj , nrj ) ! coord of ND w/i CD point
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
ci = ipos + (ni-1) / nri ! j coord of CD point
ip = mod ( ni , nri ) ! coord of ND w/i CD point
! This is a trivial implementation of the interp_fcn; just copies
! the values from the CD into the ND
if ( imask(ni,nj) .eq. 1 ) then
nfld( ni, nk, nj ) = cfld( ci , ck , cj )
endif
ENDDO
ENDDO
ENDDO
RETURN
END SUBROUTINE interp_fcnm_imask
#endif
! end of first block of ARW-only routines
! NMM: We still allow interp_mask_land_field because it is needed, but no
! equivalent exists. Use of this in WRF-NMM is an error and will have
! unintended consequences.
SUBROUTINE interp_mask_land_field ( enable, & ! says whether to allow interpolation or just the bcasts,7
cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
clu, nlu )
USE module_configure
USE module_wrf_error
USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers
IMPLICIT NONE
LOGICAL, INTENT(IN) :: enable
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater, ierr
REAL :: avg , sum , dx , dy
INTEGER , PARAMETER :: max_search = 5
CHARACTER(LEN=255) :: message
INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte)
REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte)
! Find out what the water value is.
CALL nl_get_iswater(1,iswater)
! Right now, only mass point locations permitted.
IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
! Loop over each i,k,j in the nested domain.
IF ( enable ) THEN
DO nj = njts, njte
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
ELSE
cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
END IF
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
ELSE
ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
END IF
!
! (ci,cj+1) (ci+1,cj+1)
! - -------------
! 1-dy | | |
! | | |
! - | * |
! dy | | (ni,nj) |
! | | |
! - -------------
! (ci,cj) (ci+1,cj)
!
! |--|--------|
! dx 1-dx
! For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri )
ELSE
dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri )
END IF
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj )
ELSE
dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj )
END IF
! This is a "land only" field. If this is a water point, no operations required.
IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) ) THEN
nfld(ni,nk,nj) = cfld(ci ,ck,cj )
! If this is a nested land point, and the surrounding coarse values are all land points,
! then this is a simple 4-pt interpolation.
ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. &
( NINT(clu(ci ,cj )) .NE. iswater ) .AND. &
( NINT(clu(ci+1,cj )) .NE. iswater ) .AND. &
( NINT(clu(ci ,cj+1)) .NE. iswater ) .AND. &
( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN
nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + &
dy * cfld(ci ,ck,cj+1) ) + &
dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + &
dy * cfld(ci+1,ck,cj+1) )
! If this is a nested land point and there are NO coarse land values surrounding,
! we temporarily punt.
ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. &
( NINT(clu(ci ,cj )) .EQ. iswater ) .AND. &
( NINT(clu(ci+1,cj )) .EQ. iswater ) .AND. &
( NINT(clu(ci ,cj+1)) .EQ. iswater ) .AND. &
( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN
nfld(ni,nk,nj) = -1
! If there are some water points and some land points, take an average.
ELSE IF ( NINT(nlu(ni ,nj )) .NE. iswater ) THEN
icount = 0
sum = 0
IF ( NINT(clu(ci ,cj )) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj )
END IF
IF ( NINT(clu(ci+1,cj )) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj )
END IF
IF ( NINT(clu(ci ,cj+1)) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj+1)
END IF
IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj+1)
END IF
nfld(ni,nk,nj) = sum / REAL ( icount )
END IF
END DO
END DO
END DO
! Get an average of the whole domain for problem locations.
sum_n = 0
icount_n = 0
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
IF ( nfld(ni,nk,nj) .NE. -1 ) THEN
IF ( NINT(nlu(ni,nj)) .NE. iswater ) THEN
icount_n(nk) = icount_n(nk) + 1
sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj)
END IF
END IF
END DO
END DO
END DO
CALL wrf_dm_sum_reals( sum_n(nkts:nkte), dummy(nkts:nkte))
sum_n = dummy
CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte))
icount_n = idummy
DO nk = nkts, nkte
IF ( icount_n(nk) .GT. 0 ) &
avg_n(nk) = sum_n(nk) / icount_n(nk)
END DO
ENDIF
IF ( enable ) THEN
IF ( ANY(nfld .EQ. -1) ) THEN
! OK, if there were any of those island situations, we try to search a bit broader
! of an area in the coarse grid.
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
ELSE
cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
END IF
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
ELSE
ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
END IF
ist = MAX (ci-max_search,cits)
ien = MIN (ci+max_search,cite,cide-1)
jst = MAX (cj-max_search,cjts)
jen = MIN (cj+max_search,cjte,cjde-1)
icount = 0
sum = 0
DO jj = jst,jen
DO ii = ist,ien
IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ii,nk,jj)
END IF
END DO
END DO
IF ( icount .GT. 0 ) THEN
nfld(ni,nk,nj) = sum / REAL ( icount )
ELSE
Write(message,fmt='(a,i4,a,i4,a,f10.4)') &
'horizontal interp error - island (', ni, ',', nj, '), using average ', avg_n(nk)
CALL wrf_message ( message )
nfld(ni,nk,nj) = avg_n(nk)
END IF
END IF
END DO
END DO
END DO
ENDIF
ENDIF
ELSE
CALL wrf_error_fatal ( "only unstaggered fields right now" )
END IF
END SUBROUTINE interp_mask_land_field
SUBROUTINE interp_mask_water_field ( enable, & ! says whether to allow interpolation or just the bcasts,7
cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
clu, nlu, cflag, nflag )
USE module_configure
USE module_wrf_error
USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers
IMPLICIT NONE
LOGICAL, INTENT(IN) :: enable
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj, cflag, nflag
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
INTEGER :: icount , ii , jj , ist , ien , jst , jen, ierr
REAL :: avg , sum , dx , dy
INTEGER , PARAMETER :: max_search = 5
INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte)
REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte)
CHARACTER(LEN=255) :: message
! Right now, only mass point locations permitted.
IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
IF ( enable ) THEN
! Loop over each i,k,j in the nested domain.
DO nj = njts, njte
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
ELSE
cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
END IF
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
!dave IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
ELSE
ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
END IF
!
! (ci,cj+1) (ci+1,cj+1)
! - -------------
! 1-dy | | |
! | | |
! - | * |
! dy | | (ni,nj) |
! | | |
! - -------------
! (ci,cj) (ci+1,cj)
!
! |--|--------|
! dx 1-dx
! At ni=2, we are on the coarse grid point, so dx = 0
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri )
ELSE
dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri )
END IF
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj )
ELSE
dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj )
END IF
! This is a "water only" field. If this is a land point, no operations required.
IF ( ( NINT(nlu(ni ,nj )) .NE. nflag ) ) THEN
nfld(ni,nk,nj) = cfld(ci ,ck,cj )
! If this is a nested water point, and the surrounding coarse values are all water points,
! then this is a simple 4-pt interpolation.
ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. nflag ) .AND. &
( NINT(clu(ci ,cj )) .EQ. nflag ) .AND. &
( NINT(clu(ci+1,cj )) .EQ. nflag ) .AND. &
( NINT(clu(ci ,cj+1)) .EQ. nflag ) .AND. &
( NINT(clu(ci+1,cj+1)) .EQ. nflag ) ) THEN
nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + &
dy * cfld(ci ,ck,cj+1) ) + &
dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + &
dy * cfld(ci+1,ck,cj+1) )
! If this is a nested water point and there are NO coarse water values surrounding,
! we temporarily punt.
ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. nflag ) .AND. &
( NINT(clu(ci ,cj )) .NE. nflag ) .AND. &
( NINT(clu(ci+1,cj )) .NE. nflag ) .AND. &
( NINT(clu(ci ,cj+1)) .NE. nflag ) .AND. &
( NINT(clu(ci+1,cj+1)) .NE. nflag ) ) THEN
nfld(ni,nk,nj) = -4
! If there are some land points and some water points, take an average.
ELSE IF ( NINT(nlu(ni ,nj )) .EQ. nflag ) THEN
icount = 0
sum = 0
IF ( NINT(clu(ci ,cj )) .EQ. nflag ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj )
END IF
IF ( NINT(clu(ci+1,cj )) .EQ. nflag ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj )
END IF
IF ( NINT(clu(ci ,cj+1)) .EQ. nflag ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj+1)
END IF
IF ( NINT(clu(ci+1,cj+1)) .EQ. nflag ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj+1)
END IF
nfld(ni,nk,nj) = sum / REAL ( icount )
END IF
END DO
END DO
END DO
! Get an average of the whole domain for problem locations.
sum_n = 0
icount_n = 0
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
IF ( nfld(ni,nk,nj) .NE. -1 ) THEN
IF ( NINT(nlu(ni,nj)) .EQ. nflag ) THEN
icount_n(nk) = icount_n(nk) + 1
sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj)
END IF
END IF
END DO
END DO
END DO
CALL wrf_dm_sum_reals( sum_n(nkts:nkte), dummy(nkts:nkte))
sum_n = dummy
CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte))
icount_n = idummy
DO nk = nkts, nkte
IF ( icount_n(nk) .GT. 0 ) &
avg_n(nk) = sum_n(nk) / icount_n(nk)
END DO
ENDIF
IF ( enable ) THEN
IF ( ANY(nfld .EQ. -4) ) THEN
! OK, if there were any of those lake situations, we try to search a bit broader
! of an area in the coarse grid.
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
!dave IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( nfld(ni,nk,nj) .EQ. -4 ) THEN
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
ELSE
cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
END IF
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
ELSE
ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
END IF
ist = MAX (ci-max_search,cits)
ien = MIN (ci+max_search,cite,cide-1)
jst = MAX (cj-max_search,cjts)
jen = MIN (cj+max_search,cjte,cjde-1)
icount = 0
sum = 0
DO jj = jst,jen
DO ii = ist,ien
IF ( NINT(clu(ii,jj)) .EQ. nflag ) THEN
icount = icount + 1
sum = sum + cfld(ii,nk,jj)
END IF
END DO
END DO
IF ( icount .GT. 0 ) THEN
nfld(ni,nk,nj) = sum / REAL ( icount )
ELSE
Write(message,fmt='(a,i4,a,i4,a,f10.4)') &
'horizontal interp error - lake (', ni, ',', nj, '), using average ', avg_n(nk)
CALL wrf_message ( message )
nfld(ni,nk,nj) = avg_n(nk)
END IF
END IF
END DO
END DO
END DO
ENDIF
ENDIF
ELSE
CALL wrf_error_fatal ( "only unstaggered fields right now" )
END IF
END SUBROUTINE interp_mask_water_field
! Begin second block of ARW-only routines
#if ! defined(NMM_CORE) || NMM_CORE!=1
SUBROUTINE p2c_mask ( cfld, & ! CD field,3
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
clu, nlu, & ! land use categories
ctslb,ntslb, & ! soil temps
cnum_soil_layers,nnum_soil_layers, & ! number of soil layers for tslb
ciswater, niswater ) ! iswater category
USE module_configure
USE module_wrf_error
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj, &
cnum_soil_layers, nnum_soil_layers, &
ciswater, niswater
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
REAL, DIMENSION ( cims:cime, 1:cnum_soil_layers, cjms:cjme ) :: ctslb
REAL, DIMENSION ( nims:nime, 1:nnum_soil_layers, njms:njme ) :: ntslb
! Local
INTEGER ci, cj, ck, ni, nj, nk
INTEGER :: icount
REAL :: sum , dx , dy
! Right now, only mass point locations permitted.
IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
! Loop over each i,k,j in the nested domain.
DO nj = njts, MIN(njde-1,njte)
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
ELSE
cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
END IF
DO nk = nkts, nkte
ck = nk
DO ni = nits, MIN(nide-1,nite)
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
ELSE
ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
END IF
!
! (ci,cj+1) (ci+1,cj+1)
! - -------------
! 1-dy | | |
! | | |
! - | * |
! dy | | (ni,nj) |
! | | |
! - -------------
! (ci,cj) (ci+1,cj)
!
! |--|--------|
! dx 1-dx
! At ni=2, we are on the coarse grid point, so dx = 0
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri )
ELSE
dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri )
END IF
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj )
ELSE
dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj )
END IF
! This is a "water only" field. If this is a land point, no operations required.
IF ( ( NINT(nlu(ni ,nj )) .NE. niswater ) ) THEN
nfld(ni,nk,nj) = 273.18
! If this is a nested water point, and the surrounding coarse values are all water points,
! then this is a simple 4-pt interpolation.
ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. niswater ) .AND. &
( NINT(clu(ci ,cj )) .EQ. niswater ) .AND. &
( NINT(clu(ci+1,cj )) .EQ. niswater ) .AND. &
( NINT(clu(ci ,cj+1)) .EQ. niswater ) .AND. &
( NINT(clu(ci+1,cj+1)) .EQ. niswater ) ) THEN
nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + &
dy * cfld(ci ,ck,cj+1) ) + &
dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + &
dy * cfld(ci+1,ck,cj+1) )
! If this is a nested water point and there are NO coarse water values surrounding,
! we manufacture something from the deepest CG soil temp.
ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. niswater ) .AND. &
( NINT(clu(ci ,cj )) .NE. niswater ) .AND. &
( NINT(clu(ci+1,cj )) .NE. niswater ) .AND. &
( NINT(clu(ci ,cj+1)) .NE. niswater ) .AND. &
( NINT(clu(ci+1,cj+1)) .NE. niswater ) ) THEN
nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * ctslb(ci ,cnum_soil_layers,cj ) + &
dy * ctslb(ci ,cnum_soil_layers,cj+1) ) + &
dx * ( ( 1. - dy ) * ctslb(ci+1,cnum_soil_layers,cj ) + &
dy * ctslb(ci+1,cnum_soil_layers,cj+1) )
! If there are some land points and some water points, take an average of the water points.
ELSE IF ( NINT(nlu(ni ,nj )) .EQ. niswater ) THEN
icount = 0
sum = 0
IF ( NINT(clu(ci ,cj )) .EQ. niswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj )
END IF
IF ( NINT(clu(ci+1,cj )) .EQ. niswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj )
END IF
IF ( NINT(clu(ci ,cj+1)) .EQ. niswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj+1)
END IF
IF ( NINT(clu(ci+1,cj+1)) .EQ. niswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj+1)
END IF
nfld(ni,nk,nj) = sum / REAL ( icount )
END IF
END DO
END DO
END DO
ELSE
CALL wrf_error_fatal ( "only unstaggered fields right now" )
END IF
END SUBROUTINE p2c_mask
SUBROUTINE none
END SUBROUTINE none
SUBROUTINE smoother ( cfld , &,3
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in
nri, nrj &
)
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos
LOGICAL, INTENT(IN) :: xstag, ystag
INTEGER :: smooth_option, feedback , spec_zone
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
! If there is no feedback, there can be no smoothing.
CALL nl_get_feedback ( 1, feedback )
IF ( feedback == 0 ) RETURN
CALL nl_get_spec_zone ( 1, spec_zone )
! These are the 2d smoothers used on the fedback data. These filters
! are run on the coarse grid data (after the nested info has been
! fedback). Only the area of the nest in the coarse grid is filtered.
CALL nl_get_smooth_option ( 1, smooth_option )
IF ( smooth_option == 0 ) THEN
! no op
ELSE IF ( smooth_option == 1 ) THEN
CALL sm121 ( cfld , &
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
xstag, ystag, & ! staggering of field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos & ! Position of lower left of nest in
)
ELSE IF ( smooth_option == 2 ) THEN
CALL smdsm ( cfld , &
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
xstag, ystag, & ! staggering of field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos & ! Position of lower left of nest in
)
END IF
END SUBROUTINE smoother
SUBROUTINE sm121 ( cfld , & 1,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
xstag, ystag, & ! staggering of field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos & ! Position of lower left of nest in
)
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew
INTEGER :: i , j , k , loop
INTEGER :: istag,jstag
INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt)
istag = 1 ; jstag = 1
IF ( xstag ) istag = 0
IF ( ystag ) jstag = 0
! Simple 1-2-1 smoother.
smoothing_passes : DO loop = 1 , smooth_passes
DO k = ckts , ckte
! Initialize dummy cfldnew
DO i = MAX(ipos,cits-3) , MIN(ipos+(nide-nids)/nri,cite+3)
DO j = MAX(jpos,cjts-3) , MIN(jpos+(njde-njds)/nrj,cjte+3)
cfldnew(i,j) = cfld(i,k,j)
END DO
END DO
! 1-2-1 smoothing in the j direction first,
DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
cfldnew(i,j) = 0.25 * ( cfld(i,k,j+1) + 2.*cfld(i,k,j) + cfld(i,k,j-1) )
END DO
END DO
! then 1-2-1 smoothing in the i direction last
DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
cfld(i,k,j) = 0.25 * ( cfldnew(i+1,j) + 2.*cfldnew(i,j) + cfldnew(i-1,j) )
END DO
END DO
END DO
END DO smoothing_passes
END SUBROUTINE sm121
SUBROUTINE smdsm ( cfld , & 1,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
xstag, ystag, & ! staggering of field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos & ! Position of lower left of nest in
)
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew
REAL , DIMENSION ( 2 ) :: xnu
INTEGER :: i , j , k , loop , n
INTEGER :: istag,jstag
INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt)
xnu = (/ 0.50 , -0.52 /)
istag = 1 ; jstag = 1
IF ( xstag ) istag = 0
IF ( ystag ) jstag = 0
! The odd number passes of this are the "smoother", the even
! number passes are the "de-smoother" (note the different signs on xnu).
smoothing_passes : DO loop = 1 , smooth_passes * 2
n = 2 - MOD ( loop , 2 )
DO k = ckts , ckte
DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i,k,j+1) + cfld(i,k,j-1)) * 0.5-cfld(i,k,j))
END DO
END DO
DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
cfld(i,k,j) = cfldnew(i,j)
END DO
END DO
DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i+1,k,j) + cfld(i-1,k,j)) * 0.5-cfld(i,k,j))
END DO
END DO
DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
cfld(i,k,j) = cfldnew(i,j)
END DO
END DO
END DO
END DO smoothing_passes
END SUBROUTINE smdsm
!==================================
! this is used to modify a field over the nest so we can see where the nest is
SUBROUTINE mark_domain ( cfld, & ! CD field,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj ) ! nest ratios
USE module_configure
USE module_wrf_error
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
INTEGER :: icmin,icmax,jcmin,jcmax
INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
istag = 1 ; jstag = 1
IF ( xstag ) istag = 0
IF ( ystag ) jstag = 0
DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-jstag-1,cjte)
nj = (cj-jpos)*nrj + jstag + 1
DO ck = ckts, ckte
nk = ck
DO ci = MAX(ipos+1,cits),MIN(ipos+(nide-nids)/nri-istag-1,cite)
ni = (ci-ipos)*nri + istag + 1
cfld( ci, ck, cj ) = 9021000. !magic number: Beverly Hills * 100.
ENDDO
ENDDO
ENDDO
END SUBROUTINE mark_domain
#endif
! end of second block of WRF-ARW-specific interpolation schemes
#if ( NMM_CORE == 1 )
!=======================================================================================
! Old circa 2007 interpolation schemes that are still in use
! This is gopal's doing
!=======================================================================================
SUBROUTINE force_sst_nmm (cfld, & ! CD field,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
CBWGT4, HBWGT4, CCSST, CSST ) ! just dummys
USE module_timing
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, njms:njme ) :: nfld
REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
INTEGER , INTENT(IN) :: csst(*), ccsst(*)
! local
LOGICAL FLIP
INTEGER i,j,k,n
REAL SUM,AMAXVAL
REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT
if(csst(1) /= 1) return
!
!*** INDEX CONVENTIONS
!*** NBWGT4=0
!*** 4
!***
!***
!***
!*** h
!*** 1 2
!*** NBWGT1=1 NBWGT2=0
!***
!***
!*** 3
!*** NBWGT3=0
DO J=NJTS,MIN(NJTE,NJDE-1)
DO I=NITS,MIN(NITE,NIDE-1)
NBWGT(1,I,J)=HBWGT1(I,J)
NBWGT(2,I,J)=HBWGT2(I,J)
NBWGT(3,I,J)=HBWGT3(I,J)
NBWGT(4,I,J)=HBWGT4(I,J)
ENDDO
ENDDO
DO J=NJTS,MIN(NJTE,NJDE-1)
DO I=NITS,MIN(NITE,NIDE-1)
AMAXVAL=0.
DO N=1,4
AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
ENDDO
FLIP=.TRUE.
SUM=0.0
DO N=1,4
IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
NBWGT(N,I,J)=1.0
FLIP=.FALSE.
ELSE
NBWGT(N,I,J)=0.0
ENDIF
SUM=SUM+NBWGT(N,I,J)
IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
ENDDO
ENDDO
ENDDO
DO J=NJTS,MIN(NJTE,NJDE-1)
DO I=NITS,MIN(NITE,NIDE-1)
IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ) &
+ NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ) &
+ NBWGT(3,I,J)*CFLD(IIH(I,J), JJH(I,J)-1) &
+ NBWGT(4,I,J)*CFLD(IIH(I,J), JJH(I,J)+1)
ELSE
NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ) &
+ NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ) &
+ NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1) &
+ NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1)
ENDIF
ENDDO
ENDDO
END SUBROUTINE force_sst_nmm
SUBROUTINE nmm_smoother_ikj ( cfld , &,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
xstag, ystag, &
ipos, jpos, &
nri, nrj &
)
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
LOGICAL, INTENT(IN) :: xstag, ystag
! Local
INTEGER :: feedback
INTEGER, PARAMETER :: smooth_passes = 5
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew
INTEGER :: ci, cj, ck
INTEGER :: is, npass
REAL :: AVGH
CHARACTER (LEN=256) :: a_message
RETURN
! If there is no feedback, there can be no smoothing.
CALL nl_get_feedback ( 1, feedback )
IF ( feedback == 0 ) RETURN
WRITE(a_message,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT'
CALL wrf_message ( a_message )
DO npass = 1, smooth_passes
DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
if(mod(cj,2) .eq. 0)THEN
is=0 ! even rows for mass points (2,4,6,8)
else
is=1 ! odd rows for mass points (1,3,5,7)
endif
DO ck = ckts, ckte
DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
IF(IS==0)THEN ! (2,4,6,8)
AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1)
ELSE
AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1)
ENDIF
CFLDNEW(CI,CK,CJ) = (AVGH + 4*CFLD(CI,CK,CJ)) / 8.0
ENDDO
ENDDO
ENDDO
DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
if(mod(cj,2) .eq. 0)THEN
is=0 ! even rows for mass points (2,4,6,8)
else
is=1 ! odd rows for mass points (1,3,5,7)
endif
DO ck = ckts, ckte
DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ)
ENDDO
ENDDO
ENDDO
ENDDO ! do npass
END SUBROUTINE nmm_smoother_ikj
SUBROUTINE nmm_smoother_ijk ( cfld , &,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
xstag, ystag, &
ipos, jpos, &
nri, nrj &
)
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos
REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(INOUT) :: cfld
LOGICAL, INTENT(IN) :: xstag, ystag
! Local
INTEGER :: feedback
INTEGER, PARAMETER :: smooth_passes = 5
REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfldnew
INTEGER :: ci, cj, ck
INTEGER :: is, npass
REAL :: AVGH
CHARACTER (LEN=256) :: a_message
RETURN
! If there is no feedback, there can be no smoothing.
CALL nl_get_feedback ( 1, feedback )
IF ( feedback == 0 ) RETURN
WRITE(a_message,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT'
CALL wrf_message ( a_message )
DO npass = 1, smooth_passes
DO ck = ckts, ckte
DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
if(mod(cj,2) .eq. 0)THEN
is=0 ! even rows for mass points (2,4,6,8)
else
is=1 ! odd rows for mass points (1,3,5,7)
endif
DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
IF(IS==0)THEN ! (2,4,6,8)
AVGH = CFLD(CI,CJ+1,CK) + CFLD(CI,CJ-1,CK) + CFLD(CI+1,CJ+1,CK) + CFLD(CI+1,CJ-1,CK)
ELSE
AVGH = CFLD(CI,CJ+1,CK) + CFLD(CI,CJ-1,CK) + CFLD(CI-1,CJ+1,CK) + CFLD(CI-1,CJ-1,CK)
ENDIF
CFLDNEW(CI,CJ,CK) = (AVGH + 4*CFLD(CI,CJ,CK)) / 8.0
ENDDO
ENDDO
ENDDO
DO ck = ckts, ckte
DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
if(mod(cj,2) .eq. 0)THEN
is=0 ! even rows for mass points (2,4,6,8)
else
is=1 ! odd rows for mass points (1,3,5,7)
endif
DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
CFLD(CI,CJ,CK) = CFLDNEW(CI,CJ,CK)
ENDDO
ENDDO
ENDDO
ENDDO ! do npass
END SUBROUTINE nmm_smoother_ijk
SUBROUTINE nmm_vsmoother_ikj ( cfld , &,2
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
xstag, ystag, &
ipos, jpos, &
nri, nrj &
)
USE module_configure
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
nri, nrj, &
ipos, jpos
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
LOGICAL, INTENT(IN) :: xstag, ystag
! Local
INTEGER :: feedback
INTEGER, PARAMETER :: smooth_passes = 5
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew
INTEGER :: ci, cj, ck
INTEGER :: is, npass
REAL :: AVGV
CHARACTER (LEN=256) :: a_message
RETURN
! If there is no feedback, there can be no smoothing.
CALL nl_get_feedback ( 1, feedback )
IF ( feedback == 0 ) RETURN
WRITE(a_message,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR VELOCITY'
CALL wrf_message ( a_message )
DO npass = 1, smooth_passes
DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
if(mod(cj,2) .eq. 0)THEN
is=1 ! even rows for mass points (2,4,6,8)
else
is=0 ! odd rows for mass points (1,3,5,7)
endif
DO ck = ckts, ckte
DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
IF(IS==0)THEN ! (2,4,6,8)
AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1)
ELSE
AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1)
ENDIF
CFLDNEW(CI,CK,CJ) = (AVGV + 4*CFLD(CI,CK,CJ)) / 8.0
ENDDO
ENDDO
ENDDO
DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
if(mod(cj,2) .eq. 0)THEN
is=1 ! even rows for mass points (2,4,6,8)
else
is=0 ! odd rows for mass points (1,3,5,7)
endif
DO ck = ckts, ckte
DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ)
ENDDO
ENDDO
ENDDO
ENDDO
END SUBROUTINE nmm_vsmoother_ikj
!======================================================================================
! End of gopal's doing
!======================================================================================
!======================================================================================
! New NMM Interpolation Routines; wrappers around module_interp_nmm (Sam's doing)
!======================================================================================
!--------------------------------------------------------------------------------------
subroutine NoInterpMany(cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
cpint,npint, cpd,npd, cq,nq, ct,nt, &
cfis,nfis)
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
! parent domain
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD,cpint,ct,cq
REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: cpd,cfis
! nested domain
REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: nFIS,npd
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(IN) :: NFLD,npint,nt,nq
end subroutine NoInterpMany
subroutine DownAged2D(junk, &,3
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
c_age,n_age, cfld)
use module_interp_nmm, only: c2n_copy2d_nomask
use module_interp_store
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
integer, intent(in) :: c_age
integer, intent(inout) :: n_age
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFLD,junk
REAL,DIMENSION(nims:nime,njms:njme), INTENT(INOUT) :: nfld
logical bad
integer i,j
! Skip if the nest is up-to-date with the parent. Special age
! of 0 means the values are invalid (parent just moved, nest
! just moved or one was initialized).
if(n_age==c_age .and. n_age/=0 .and. c_age/=0) then
!write(0,*) 'Grid ',grid_id,' not storing pdyn in DownAged2D'
!write(0,*) ' reason: n_age=',n_age,' c_age=',c_age
return
end if
n_age=c_age
!write(0,*) 'Storing grid ',parent_grid_id,' pdyn_smooth in grid ',grid_id,' pdyn_parent'
call c2n_copy2d_nomask(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
cfld,nfld, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .true.)
end subroutine DownAged2D
subroutine ForceNearSST (cfld, & ! CD field,3
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
cactivate, nactivate)
use module_interp_nmm, only: c2n_sst
use module_interp_store
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
integer, intent(In), dimension(*) :: cactivate, nactivate
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme), INTENT(INOUT) :: nfld
if(nactivate(1)/=1) return
call c2n_sst(hnear_i,hnear_j, &
cfld,nfld, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte)
end subroutine ForceNearSST
subroutine DownNear (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_nmm, only: c2n_near2d, c2n_near3d
use module_interp_store
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme), INTENT(INOUT) :: nfld
if(nkts==nkte) then
call c2n_near2d(hnear_i,hnear_j, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte)
else
call c2n_near3d(hnear_i,hnear_j, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte)
endif
end subroutine DownNear
subroutine DownNearIKJ (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_nmm, only: c2n_near3dikj
use module_interp_store
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: nfld
if(nkts==nkte) &
call wrf_error_fatal('IJ interpolation of an IKJ variable is not supported and makes no sense anyway. Use DownNear instead.')
call c2n_near3dikj(hnear_i,hnear_j, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte)
end subroutine DownNearIKJ
subroutine UpNear(cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_store
use module_interp_nmm, only: n2c_near2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(OUT) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: nfld
if(nkts/=nkte) &
call wrf_error_fatal('Up nearest neighbor interpolation is not implemented.')
call n2c_near2d( cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, &
cims, cime, cjms, cjme, &
cits, cite, cjts, cjte, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte)
end subroutine UpNear
subroutine DownINear (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_nmm, only: c2n_inear2d
use module_interp_store
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFLD
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(INOUT) :: nfld
if(nkts/=nkte) &
call wrf_error_fatal('3D integer nearest neighbor interpolation is not implemented.')
call c2n_inear2d(hnear_i,hnear_j, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte)
end subroutine DownINear
subroutine UpINear (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_store
use module_interp_nmm, only: n2c_inear2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(OUT) :: CFLD
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: nfld
if(nkts/=nkte) &
call wrf_error_fatal('3D integer nearest neighbor interpolation is not implemented.')
call n2c_inear2d( cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, &
cims, cime, cjms, cjme, &
cits, cite, cjts, cjte, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte)
end subroutine UpINear
subroutine DownMass (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
emethod, evalue) ! extrapolation method
use module_interp_nmm, only: c2n_mass, c2n_copy2d
use module_interp_store
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj, emethod
real, intent(in) :: evalue
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(INOUT) :: nfld
if(nkts==nkte) then
call c2n_copy2d(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .true.)
else
call c2n_mass(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
cfld,nfld,iinfo,winfo,imask, &
emethod,evalue, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte)
endif
end subroutine DownMass
subroutine DownMassIKJ (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
emethod, evalue) ! extrapolation method
use module_interp_nmm, only: c2n_massikj
use module_interp_store
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj,emethod
real, intent(in) :: evalue
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: nfld
if(nkts==nkte) &
call wrf_error_fatal('IKJ 2D interpolation of an IJ array is not implemented (and makes no sense anyway). Use DownCopy instead.')
call c2n_massikj(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
cfld,nfld,iinfo,winfo,imask, &
emethod, evalue, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte)
end subroutine DownMassIKJ
subroutine UpMassIKJ (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
emethod, evalue) ! extrapolation method
use module_interp_store
use module_interp_nmm, only: n2c_massikj, n2c_copy2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj, emethod
real, intent(in) :: evalue
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(OUT) :: CFLD
REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(IN) :: nfld
if(nkts==nkte) then
call n2c_copy2d(&
cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, &
cims, cime, cjms, cjme, &
cits, cite, cjts, cjte, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .true.)
else
call n2c_massikj(&
cfld,nfld,parent_iinfo,parent_winfo, &
ipos,jpos,emethod, evalue, &
cids, cide, cjds, cjde, ckds, ckde, &
cims, cime, cjms, cjme, ckms, ckme, &
cits, cite, cjts, cjte, ckts, ckte, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte)
endif
end subroutine UpMassIKJ
subroutine UpMass (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
emethod, evalue) ! extrapolation method
use module_interp_store
use module_interp_nmm, only: n2c_mass, n2c_copy2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj, emethod
real, intent(in) :: evalue
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(OUT) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(IN) :: nfld
if(nkts==nkte) then
call n2c_copy2d(&
cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, &
cims, cime, cjms, cjme, &
cits, cite, cjts, cjte, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .true.)
else
call n2c_mass(&
cfld,nfld,parent_iinfo,parent_winfo, &
ipos,jpos,emethod, evalue, &
cids, cide, cjds, cjde, ckds, ckde, &
cims, cime, cjms, cjme, ckms, ckme, &
cits, cite, cjts, cjte, ckts, ckte, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte)
endif
end subroutine UpMass
subroutine UpCopy (cfld, & ! CD field,3
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_nmm, only: n2c_copy3d, n2c_copy2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(OUT) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(IN) :: nfld
if(nkts==nkte) then
call n2c_copy2d(&
cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, &
cims, cime, cjms, cjme, &
cits, cite, cjts, cjte, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .true.)
else
call n2c_copy3d(&
cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, ckds, ckde, &
cims, cime, cjms, cjme, ckms, ckme, &
cits, cite, cjts, cjte, ckts, ckte, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte, .true.)
endif
end subroutine UpCopy
subroutine UpMax (cfld, & ! CD field,3
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_nmm, only: n2c_max3d, n2c_max2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(OUT) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(IN) :: nfld
if(nkts==nkte) then
call n2c_max2d(&
cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, &
cims, cime, cjms, cjme, &
cits, cite, cjts, cjte, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .true.)
else
call n2c_max3d(&
cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, ckds, ckde, &
cims, cime, cjms, cjme, ckms, ckme, &
cits, cite, cjts, cjte, ckts, ckte, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte, .true.)
endif
end subroutine UpMax
subroutine DownCopy (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_store
use module_interp_nmm, only: c2n_copy3d, c2n_copy2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(INOUT) :: nfld
if(nkts==nkte) then
call c2n_copy2d(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .true.)
else
call c2n_copy3d(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte, .true.)
endif
end subroutine DownCopy
subroutine UpVel (cfld, & ! CD field,3
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_nmm, only: n2c_copy3d, n2c_copy2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(OUT) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(IN) :: nfld
if(nkts==nkte) then
call n2c_copy2d( cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, &
cims, cime, cjms, cjme, &
cits, cite, cjts, cjte, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .false.)
else
call n2c_copy3d(&
cfld,nfld,ipos,jpos, &
cids, cide, cjds, cjde, ckds, ckde, &
cims, cime, cjms, cjme, ckms, ckme, &
cits, cite, cjts, cjte, ckts, ckte, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte, .false.)
endif
end subroutine UpVel
subroutine DownVel (cfld, & ! CD field,4
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj) ! nest ratios
use module_interp_store
use module_interp_nmm, only: c2n_copy3d, c2n_copy2d
implicit none
LOGICAL,INTENT(IN) :: xstag, ystag
INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw,ipos,jpos,nri,nrj
INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD
REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(INOUT) :: nfld
if(nkts==nkte) then
call c2n_copy2d(IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .false.)
else
call c2n_copy3d(IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
cfld,nfld,imask, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte, .false.)
endif
end subroutine DownVel
SUBROUTINE BdyMass (cfld, & ! CD field,6
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
c_bxs,n_bxs, &
c_bxe,n_bxe, &
c_bys,n_bys, &
c_bye,n_bye, &
c_btxs,n_btxs, &
c_btxe,n_btxe, &
c_btys,n_btys, &
c_btye,n_btye, &
emethod,evalue) ! Extrapolation information
! use module_state_description
USE module_configure
USE module_wrf_error
use module_interp_store
use module_interp_nmm, only: c2b_mass, c2b_copy2d
IMPLICIT NONE
integer, parameter :: bdyw = 1
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj, emethod
real, intent(in) :: evalue
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld,ccwm
REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld,ncwm
!
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Output field boundary info:
real,dimension(nims:nime,nkms:nkme,bdyw) :: n_bys,n_bye
real,dimension(njms:njme,nkms:nkme,bdyw) :: n_bxs,n_bxe
! Unused parameters:
REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,c_bxe,c_bys,c_bye
REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
if(nkts==nkte) then
call c2b_copy2d(iih,jjh, &
hbwgt1,hbwgt2,hbwgt3,hbwgt4, &
cfld, &
n_bxs, n_bxe, n_bys, n_bye, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, &
.true.)
else
call c2b_mass(iih,jjh, &
hbwgt1,hbwgt2,hbwgt3,hbwgt4, &
cfld, &
iinfo_bxs,iinfo_bxe,iinfo_bys,iinfo_bye, &
winfo_bxs,winfo_bxe,winfo_bys,winfo_bye, &
n_bxs, n_bxe, n_bys, n_bye, &
emethod, evalue, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte)
endif
END SUBROUTINE BdyMass
!
!--------------------------------------------------------------------------------------
!
SUBROUTINE BdyCopy (cfld, & ! CD field,6
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
c_bxs,n_bxs, &
c_bxe,n_bxe, &
c_bys,n_bys, &
c_bye,n_bye, &
c_btxs,n_btxs, &
c_btxe,n_btxe, &
c_btys,n_btys, &
c_btye,n_btye)
! use module_state_description
USE module_configure
USE module_wrf_error
use module_interp_nmm, only: c2b_copy3d, c2b_copy2d
use module_interp_store
IMPLICIT NONE
integer, parameter :: bdyw = 1
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
!
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Output field boundary info:
real,dimension(nims:nime,nkms:nkme,bdyw) :: n_bys,n_bye
real,dimension(njms:njme,nkms:nkme,bdyw) :: n_bxs,n_bxe
! Nest-parent horizontal interpolation information:
! Unused parameters:
REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,c_bxe,c_bys,c_bye
REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
if(nkts==nkte) then
call c2b_copy2d(iiv,jjv, &
vbwgt1,vbwgt2,vbwgt3,vbwgt4, &
cfld, &
n_bxs, n_bxe, n_bys, n_bye, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .false.)
else
call c2b_copy3d(iih,jjh, &
hbwgt1,hbwgt2,hbwgt3,hbwgt4, &
cfld, &
n_bxs, n_bxe, n_bys, n_bye, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte, .false.)
endif
END SUBROUTINE BdyCopy
!
!--------------------------------------------------------------------------------------
!
subroutine NoInterp()
end subroutine NoInterp
!
!--------------------------------------------------------------------------------------
!
SUBROUTINE BdyVel (cfld, & ! CD field,6
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
c_bxs,n_bxs, &
c_bxe,n_bxe, &
c_bys,n_bys, &
c_bye,n_bye, &
c_btxs,n_btxs, &
c_btxe,n_btxe, &
c_btys,n_btys, &
c_btye,n_btye)
! use module_state_description
USE module_configure
USE module_wrf_error
use module_interp_nmm, only: c2b_copy3d, c2b_copy2d
use module_interp_store
IMPLICIT NONE
integer, parameter :: bdyw = 1
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
!
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Output field boundary info:
real,dimension(nims:nime,nkms:nkme,bdyw) :: n_bys,n_bye
real,dimension(njms:njme,nkms:nkme,bdyw) :: n_bxs,n_bxe
! Nest-parent horizontal interpolation information:
! Unused parameters:
REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,c_bxe,c_bys,c_bye
REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
if(nkts==nkte) then
call c2b_copy2d(iiv,jjv, &
vbwgt1,vbwgt2,vbwgt3,vbwgt4, &
cfld, &
n_bxs, n_bxe, n_bys, n_bye, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte, .false.)
else
call c2b_copy3d(iiv,jjv, &
vbwgt1,vbwgt2,vbwgt3,vbwgt4, &
cfld, &
n_bxs, n_bxe, n_bys, n_bye, &
cims, cime, cjms, cjme, ckms, ckme, &
nids, nide, njds, njde, nkds, nkde, &
nims, nime, njms, njme, nkms, nkme, &
nits, nite, njts, njte, nkts, nkte, .false.)
endif
END SUBROUTINE BdyVel
!
!--------------------------------------------------------------------------------------
!
SUBROUTINE BdyNear (cfld, & ! CD field,6
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
c_bxs,n_bxs, &
c_bxe,n_bxe, &
c_bys,n_bys, &
c_bye,n_bye, &
c_btxs,n_btxs, &
c_btxe,n_btxe, &
c_btys,n_btys, &
c_btye,n_btye)
! use module_state_description
USE module_configure
USE module_wrf_error
use module_interp_nmm, only: c2b_near2d
use module_interp_store
IMPLICIT NONE
integer, parameter :: bdyw = 1
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Output field boundary info:
real,dimension(nims:nime,1,bdyw) :: n_bys,n_bye
real,dimension(njms:njme,1,bdyw) :: n_bxs,n_bxe
! Unused parameters:
REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,c_bxe,c_bys,c_bye
REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
if(nkts/=nkte) &
call wrf_error_fatal('3D boundary nearest neighbor interpolation is not implemented.')
call c2b_near2d(hnear_i,hnear_j,cfld, &
n_bxs, n_bxe, n_bys, n_bye, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte)
END SUBROUTINE BdyNear
SUBROUTINE BdyINear (cfld, & ! CD field,6
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
c_bxs,n_bxs, &
c_bxe,n_bxe, &
c_bys,n_bys, &
c_bye,n_bye, &
c_btxs,n_btxs, &
c_btxe,n_btxe, &
c_btys,n_btys, &
c_btye,n_btye)
! use module_state_description
USE module_configure
USE module_wrf_error
use module_interp_nmm, only: c2b_inear2d
use module_interp_store
IMPLICIT NONE
integer, parameter :: bdyw = 1
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
INTEGER, DIMENSION ( cims:cime, cjms:cjme ) :: cfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
! Output field boundary info:
integer,dimension(nims:nime,1,bdyw) :: n_bys,n_bye
integer,dimension(njms:njme,1,bdyw) :: n_bxs,n_bxe
! Unused parameters:
integer, DIMENSION( * ), INTENT(INOUT) :: c_bxs,c_bxe,c_bys,c_bye
integer, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
if(nkts/=nkte) &
call wrf_error_fatal('3D boundary nearest neighbor interpolation is not implemented.')
call c2b_inear2d(hnear_i,hnear_j,cfld, &
n_bxs, n_bxe, n_bys, n_bye, &
cims, cime, cjms, cjme, &
nids, nide, njds, njde, &
nims, nime, njms, njme, &
nits, nite, njts, njte)
END SUBROUTINE BdyINear
!--------------------------------------------------------------------------------------
! End of Sam's doing
!--------------------------------------------------------------------------------------
#endif
! Third block of ARW-specific routines
#if ! defined(NMM_CORE) || NMM_CORE!=1
SUBROUTINE interp_mask_field ( enable, & ! says whether to allow interpolation or just the bcasts,4
cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
clu, nlu, cflag, nflag )
USE module_configure
USE module_wrf_error
USE module_dm , only : wrf_dm_sum_reals, wrf_dm_sum_integers
IMPLICIT NONE
LOGICAL, INTENT(IN) :: enable
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
ipos, jpos, &
nri, nrj, cflag, nflag
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
INTEGER :: icount, ii , jj , ist , ien , jst , jen , iswater, ierr
REAL :: avg, sum, dx , dy
INTEGER :: icount_water(nkts:nkte), icount_land(nkts:nkte), idummy(nkts:nkte)
REAL :: avg_water(nkts:nkte), avg_land(nkts:nkte), sum_water(nkts:nkte), sum_land(nkts:nkte), dummy(nkts:nkte)
CHARACTER (len=256) :: message
CHARACTER (len=256) :: a_mess
! Find out what the water value is.
!CALL nl_get_iswater(1,iswater)
iswater = nflag
! Right now, only mass point locations permitted.
IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
! Loop over each i,k,j in the nested domain.
IF ( enable ) THEN
DO nj = njts, njte
! first coarse position equal to or below nest point
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1
ELSE
cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1
END IF
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
IF ( imask(ni, nj) .NE. 1 ) cycle
! first coarse position equal to or to the left of nest point
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
ci = ( ni + (nri/2)-1 ) / nri + ipos -1
ELSE
ci = ( ni + (nri-1)/2 ) / nri + ipos -1
END IF
!
! (ci,cj+1) (ci+1,cj+1)
! - -------------
! 1-dy | | |
! | | |
! - | * |
! dy | | (ni,nj) |
! | | |
! - -------------
! (ci,cj) (ci+1,cj)
!
! |--|--------|
! dx 1-dx
! For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0
IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri )
ELSE
dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri )
END IF
IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj )
ELSE
dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj )
END IF
! Nested cell is a water cell.
IF ( ( NINT(nlu(ni, nj)) .EQ. iswater ) ) THEN
! If the surrounding coarse values are all WATER points,
! i.e. open water, this is a simple 4-pt interpolation.
! If the surrounding coarse values are all LAND points,
! i.e. this is a 1-cell lake, we have no better way to
! come up with the value than to do a simple 4-pt interpolation.
IF ( ALL( clu(ci:ci+1,cj:cj+1) == iswater ) .OR. &
ALL( clu(ci:ci+1,cj:cj+1) /= iswater ) ) THEN
nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + &
dy * cfld(ci ,ck,cj+1) ) + &
dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + &
dy * cfld(ci+1,ck,cj+1) )
! If there are some land points and some water points, take an average.
ELSE
icount = 0
sum = 0
IF ( NINT(clu(ci ,cj )) .EQ. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj )
END IF
IF ( NINT(clu(ci+1,cj )) .EQ. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj )
END IF
IF ( NINT(clu(ci ,cj+1)) .EQ. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj+1)
END IF
IF ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj+1)
END IF
nfld(ni,nk,nj) = sum / REAL ( icount )
END IF
! Nested cell is a land cell.
ELSE IF ( ( NINT(nlu(ni, nj)) .NE. iswater ) ) THEN
! If the surrounding coarse values are all LAND points,
! this is a simple 4-pt interpolation.
! If the surrounding coarse values are all WATER points,
! i.e. this is a 1-cell island, we have no better way to
! come up with the value than to do a simple 4-pt interpolation.
IF ( ALL( clu(ci:ci+1,cj:cj+1) == iswater ) .OR. &
ALL( clu(ci:ci+1,cj:cj+1) /= iswater ) ) THEN
nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + &
dy * cfld(ci ,ck,cj+1) ) + &
dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + &
dy * cfld(ci+1,ck,cj+1) )
! If there are some water points and some land points, take an average.
ELSE
icount = 0
sum = 0
IF ( NINT(clu(ci ,cj )) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj )
END IF
IF ( NINT(clu(ci+1,cj )) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj )
END IF
IF ( NINT(clu(ci ,cj+1)) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci ,ck,cj+1)
END IF
IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN
icount = icount + 1
sum = sum + cfld(ci+1,ck,cj+1)
END IF
nfld(ni,nk,nj) = sum / REAL ( icount )
END IF
END IF
END DO
END DO
END DO
END IF
ELSE
CALL wrf_error_fatal ( "only unstaggered fields right now" )
END IF
END SUBROUTINE interp_mask_field
SUBROUTINE interp_mask_soil ( enable, & ! says whether to allow interpolation or just the bcasts,4
cfld, & ! CD field
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
clu, nlu )
USE module_configure
USE module_wrf_error
USE module_dm , only : wrf_dm_sum_real, wrf_dm_sum_integer
IMPLICIT NONE
LOGICAL, INTENT(IN) :: enable
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
INTEGER :: icount, ii , jj , ist , ien , jst , jen , iswater, num_soil_cat, ierr
REAL :: avg, sum, dx , dy
INTEGER , ALLOCATABLE :: icount_water(:,: ), icount_land(:,:)
INTEGER , PARAMETER :: max_search = 5
CHARACTER*120 message
INTEGER, PARAMETER :: isoilwater = 14
CALL nl_get_iswater(1,iswater)
CALL nl_get_num_soil_cat(1,num_soil_cat)
allocate (icount_water(nkms:nkme,1:num_soil_cat))
allocate ( icount_land(nkms:nkme,1:num_soil_cat))
! Right now, only mass point locations permitted.
IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
! Loop over each i,k,j in the nested domain.
IF ( enable ) THEN
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
DO nk = nkts, nkte
ck = nk
DO ni = nits, nite
ci = ipos + (ni-1) / nri ! j coord of CD point
IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( ( NINT(nlu(ni, nj)) .EQ. iswater ) ) then
IF ( ( NINT(clu(ci ,cj )) .EQ. iswater ) ) then
nfld(ni,nk,nj) = cfld(ci,ck,cj)
ELSE
nfld(ni,nk,nj) = -1
ENDIF
ELSE IF ( ( NINT(nlu(ni, nj)) .NE. iswater ) ) THEN
IF ( ( NINT(clu(ci ,cj )) .NE. iswater ) ) THEN
nfld(ni,nk,nj) = cfld(ci,ck,cj)
ELSE
nfld(ni,nk,nj) = -1
ENDIF
END IF
END DO
END DO
END DO
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
IF ( NINT(nlu(ni,nj)) .EQ. iswater ) THEN
nfld(ni,nk,nj) = isoilwater
END IF
END IF
END DO
END DO
END DO
#if 0
IF ( ANY(nfld .EQ. -1) ) THEN
! Get an average of the whole domain for problem locations.
sum_water = 0
icount_water = 0
sum_land = 0
icount_land = 0
avg_water = 0
avg_land = 0
DO nj = njts, njte
cj = jpos + (nj-1) / nrj ! j coord of CD point
DO nk = nkts, nkte
DO ni = nits, nite
ci = ipos + (ni-1) / nri ! j coord of CD point
IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
ist = MAX (ci-max_search,cits)
ien = MIN (ci+max_search,cite,cide-1)
jst = MAX (cj-max_search,cjts)
jen = MIN (cj+max_search,cjte,cjde-1)
DO jj = jst,jen
DO ii = ist,ien
IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN
icount_land(nk,cfld(ii,nk,jj)) = icount_land(nk,cfld(ii,nk,jj)) +1
END IF
END DO
END DO
IF ( maxval(icount_land(nk,:)) .GT. 0 .and. maxloc(icount_land(nk,:)) .ne. isoilwater ) then
nfld(ni,nk,nj) = maxloc(icount_land(nk,:))
END IF
END IF
END DO
END DO
END DO
END IF ! nfld = -1
IF ( ANY(nfld .EQ. -1) ) THEN
sum_water = 0
icount_water = 0
sum_land = 0
icount_land = 0
avg_water = 0
avg_land = 0
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
IF ( nlu(ni,nj ) .NE. iswater ) THEN
icount_land(nk,nfld(ni,nk,nj)) = icount_land(nk,nfld(ni,nk,nj)) +1
END IF
ENDDO
ENDDO
ENDDO
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( nfld(ni,nk,nj) .EQ. -1 .and. maxloc(icount_land(nk,:)) .ne. isoilwater) THEN
nfld(ni,nk,nj) = MAXLOC(icount_land(nk,:))
END IF
ENDDO
ENDDO
ENDDO
END IF ! nfld = -1
#endif
IF ( ANY(nfld .EQ. -1) ) THEN
DO nj = njts, njte
DO nk = nkts, nkte
DO ni = nits, nite
IF ( imask(ni, nj) .NE. 1 ) cycle
IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
nfld(ni,nk,nj) = 8
END IF
ENDDO
ENDDO
ENDDO
END IF ! nfld = -1
END IF ! enable
ELSE
CALL wrf_error_fatal ( "only unstaggered fields right now" )
END IF
deallocate (icount_water)
deallocate (icount_land)
END SUBROUTINE interp_mask_soil
!=========================================================================
! Lagrange interpolating polynomials, set up as a quadratic, with an average of
! the overlap. Specifically for longitude near the date line.
SUBROUTINE interp_fcn_lagr_ll ( cfld_inp, & ! CD field,1
cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nfld, & ! ND field
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, & ! stencil half width for interp
imask, & ! interpolation mask
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! Nest ratio, i- and j-directions
clat_in, nlat_in, & ! CG, FG latitude
cinput_from_file, ninput_from_file ) ! CG, FG T/F input from file
IMPLICIT NONE
INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
cims, cime, ckms, ckme, cjms, cjme, &
cits, cite, ckts, ckte, cjts, cjte, &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
ipos, jpos, &
nri, nrj
LOGICAL, INTENT(IN) :: xstag, ystag
REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld_inp, cfld
REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clat_in
REAL, DIMENSION ( nims:nime, njms:njme ) :: nlat_in
INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
LOGICAL :: cinput_from_file, ninput_from_file
! Local
INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, i, j, k
REAL :: nx, x0, x1, x2, x3, x
REAL :: ny, y0, y1, y2, y3
REAL :: cxm1, cxp0, cxp1, cxp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2
REAL :: cym1, cyp0, cyp1, cyp2
INTEGER :: ioff, joff
LOGICAL :: probably_by_dateline
REAL :: max_lon, min_lon
LOGICAL :: probably_by_pole
REAL :: max_lat, min_lat
! Fortran functions.
REAL, EXTERNAL :: lagrange_quad_avg
REAL, EXTERNAL :: nest_loc_of_cg
INTEGER, EXTERNAL :: compute_CGLL
! This stag stuff is to keep us away from the outer most row
! and column for the unstaggered directions. We are going to
! consider "U" an xstag variable and "V" a ystag variable. The
! vertical staggering is handled in the actual arguments. The
! ckte and nkte are the ending vertical dimensions for computations
! for this particular variable.
! The ioff and joff are offsets due to the staggering. It is a lot
! simpler with ioff and joff if
! u var => ioff=1
! v var => joff=1
! otherwise zero.
! Note that is OPPOSITE of the istag, jstag vars. The stag variables are
! used for the domain dimensions, the offset guys are used in the
! determination of grid points between the CG and FG
IF ( xstag ) THEN
istag = 0
ioff = 1
ELSE
istag = 1
ioff = 0
END IF
IF ( ystag ) THEN
jstag = 0
joff = 1
ELSE
jstag = 1
joff = 0
END IF
! If this is a projection where the nest is over the pole, and
! we are using the parent to interpolate the longitudes, then
! we are going to have longitude troubles. If this is the case,
! stop the model right away.
probably_by_pole = .FALSE.
max_lat = -90
min_lat = +90
DO nj = njts, MIN(njde-jstag,njte)
DO ni = nits, MIN(nide-istag,nite)
max_lat = MAX ( nlat_in(ni,nj) , max_lat )
min_lat = MIN ( nlat_in(ni,nj) , min_lat )
END DO
END DO
IF ( ( max_lat .GT. 85 ) .OR. ( ABS(min_lat) .GT. 85 ) ) THEN
probably_by_pole = .TRUE.
END IF
IF ( ( probably_by_pole ) .AND. ( .NOT. ninput_from_file ) ) THEN
CALL wrf_error_fatal ( 'Nest over the pole, single input domain, longitudes will be wrong' )
END IF
! Initialize to NOT being by dateline.
probably_by_dateline = .FALSE.
max_lon = -180
min_lon = +180
DO nj = njts, MIN(njde-jstag,njte)
cj = compute_CGLL ( nj , jpos , nrj , jstag )
DO ni = nits, MIN(nide-istag,nite)
ci = compute_CGLL ( ni , ipos , nri , istag )
max_lon = MAX ( cfld_inp(ci,1,cj) , max_lon )
min_lon = MIN ( cfld_inp(ci,1,cj) , min_lon )
END DO
END DO
IF ( max_lon - min_lon .GT. 300 ) THEN
probably_by_dateline = .TRUE.
END IF
! Load "continuous" longitude across the date line
DO cj = MIN(cjts-1,cjms), MAX(cjte+1,cjme)
DO ci = MIN(cits-1,cims), MAX(cite+1,cime)
IF ( ( cfld_inp(ci,ckts,cj) .LT. 0 ) .AND. ( probably_by_dateline ) ) THEN
cfld(ci,ckts,cj) = 360 + cfld_inp(ci,ckts,cj)
ELSE
cfld(ci,ckts,cj) = cfld_inp(ci,ckts,cj)
END IF
END DO
END DO
! Loop over each j-index on this tile for the nested domain.
j_loop : DO nj = njts, MIN(njde-jstag,njte)
! This is the lower-left j-index of the CG.
! Example is 3:1 ratio, mass-point staggering. We have listed sixteen CG values
! as an example: A through P. For a 3:1 ratio, each of these CG cells has
! nine associated FG points.
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - M - | - N d | - O - | - P - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - I - | - J c | - K - | - L - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - 1 2 | 3 4 5 | 6 7 8 | - - - |
! | | | | |
! | - E - | - F b | - G - | - H - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - A - | - B a | - C - | - D - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! To interpolate to FG point 4, 5, or 6 we will use CG points: A through P. It is
! sufficient to find the lower left corner of a 4-point interpolation, and then extend
! each side by one unit.
! Here are the lower left hand corners of the following FG points:
! 1 => E
! 2 => E
! 3 => E
! 4 => F
! 5 => F
! 6 => F
! 7 => G
! 8 => G
cj = compute_CGLL ( nj , jpos , nrj , jstag )
! Vertical dim of the nest domain.
k_loop : DO nk = nkts, nkte
! Loop over each i-index on this tile for the nested domain.
i_loop : DO ni = nits, MIN(nide-istag,nite)
! The coarse grid location that is to the lower left of the FG point.
ci = compute_CGLL ( ni , ipos , nri , istag )
! To interpolate to point "*" (look in grid cell "F"):
! 1. Use ABC to get a quadratic valid at "a"
! Use BCD to get a quadratic valid at "a"
! Average these to get the final value for "a"
! 2. Use EFG to get a quadratic valid at "b"
! Use FGH to get a quadratic valid at "b"
! Average these to get the final value for "b"
! 3. Use IJK to get a quadratic valid at "c"
! Use JKL to get a quadratic valid at "c"
! Average these to get the final value for "c"
! 4. Use MNO to get a quadratic valid at "d"
! Use NOP to get a quadratic valid at "d"
! Average these to get the final value for "d"
! 5. Use abc to get a quadratic valid at "*"
! Use bcd to get a quadratic valid at "*"
! Average these to get the final value for "*"
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - M - | - N d | - O - | - P - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - I - | - J c | - K - | - L - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - * | - - - | - - - |
! | | | | |
! | - E - | - F b | - G - | - H - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! | - - - | - - - | - - - | - - - |
! | | | | |
! | - A - | - B a | - C - | - D - |
! | | | | |
! | - - - | - - - | - - - | - - - |
! |=========|=========|=========|=========|
! Overlapping quadratic interpolation.
IF ( imask ( ni, nj ) .EQ. 1 ) THEN
! I-direction location of "*"
nx = REAL(ni)
! I-direction location of "A", "E", "I", "M"
cxm1 = nest_loc_of_cg ( ci-1 , ipos , nri , ioff )
! I-direction location of "B", "F", "J", "N"
cxp0 = nest_loc_of_cg ( ci , ipos , nri , ioff )
! I-direction location of "C", "G", "K", "O"
cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff )
! I-direction location of "D", "H", "L", "P"
cxp2 = nest_loc_of_cg ( ci+2 , ipos , nri , ioff )
! Value at "a"
nfld_m1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, &
cfld(ci-1,nk,cj-1), cfld(ci+0,nk,cj-1), &
cfld(ci+1,nk,cj-1), cfld(ci+2,nk,cj-1) )
! Value at "b"
nfld_p0 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, &
cfld(ci-1,nk,cj+0), cfld(ci+0,nk,cj+0), &
cfld(ci+1,nk,cj+0), cfld(ci+2,nk,cj+0) )
! Value at "c"
nfld_p1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, &
cfld(ci-1,nk,cj+1), cfld(ci+0,nk,cj+1), &
cfld(ci+1,nk,cj+1), cfld(ci+2,nk,cj+1) )
! Value at "d"
nfld_p2 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, &
cfld(ci-1,nk,cj+2), cfld(ci+0,nk,cj+2), &
cfld(ci+1,nk,cj+2), cfld(ci+2,nk,cj+2) )
! J-direction location of "*"
ny = REAL(nj)
! J-direction location of "A", "B", "C", "D"
cym1 = nest_loc_of_cg ( cj-1 , jpos , nrj , joff )
! J-direction location of "E", "F", "G", "H"
cyp0 = nest_loc_of_cg ( cj , jpos , nrj , joff )
! J-direction location of "I", "J", "K", "L"
cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff )
! J-direction location of "M", "N", "O", "P"
cyp2 = nest_loc_of_cg ( cj+2 , jpos , nrj , joff )
! Value at "*"
nfld(ni,nk,nj) = lagrange_quad_avg ( ny, cym1, cyp0, cyp1, &
cyp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2 )
END IF
END DO i_loop
END DO k_loop
END DO j_loop
! Put nested longitude back into the -180 to 180 range.
DO nj = njts, MIN(njde-jstag,njte)
DO ni = nits, MIN(nide-istag,nite)
IF ( nfld(ni,nkts,nj) .GT. 180 ) THEN
nfld(ni,nkts,nj) = -360 + nfld(ni,nkts,nj)
END IF
END DO
END DO
END SUBROUTINE interp_fcn_lagr_ll
#endif
! End of third block of ARW-only routines