!WRF:MEDIATION_LAYER:INTERPOLATIONFUNCTION
!
#define MM5_SINT
!#define DUMBCOPY
SUBROUTINE interp_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
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
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff
#ifdef MM5_SINT
INTEGER nfx, ior
PARAMETER (ior=2)
INTEGER nf
REAL psca(cims:cime,cjms:cjme,nri*nrj)
INTEGER i,j,k
#endif
! Iterate over the ND tile and compute the values
! from the CD tile.
!write(0,'("cids:cide, ckds:ckde, cjds:cjde ",6i4)')cids,cide, ckds,ckde, cjds,cjde
!write(0,'("cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
!write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
!write(0,'("nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
!write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
#ifdef MM5_SINT
ioff = 0 ; joff = 0
IF ( xstag ) ioff = 1
IF ( ystag ) joff = 1
nfx = nri * nrj
DO k = ckts, ckte
DO nf = 1,nfx
DO j = cjms,cjme
DO i = cims,cime
psca(i,j,nf) = cfld(i,k,j)
!if (k==1.and.nf==1) write(0,*)'& ',i,j,nf,psca(i,j,nf)
ENDDO
ENDDO
ENDDO
! 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, &
cits-1, cite+1, cjts-1, cjte+1, nrj*nri )
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 ! j coord of CD point
ip = mod ( ni-1 , nri ) ! coord of ND w/i CD point
nfld( ni-ioff, nk, nj-joff ) = psca( ci+shw , cj+shw, ip+1 + (jp)*nri )
!if (nk==1) write(0,*)'+ ',ni-ioff, nk, nj-joff, nfld( ni-ioff, nk, nj-joff )
ENDDO
ENDDO
ENDDO
#endif
#ifdef DUMBCOPY
!write(0,'(") cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
!write(0,'(") nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
!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
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 )
!if (nk==1) write(0,*)'+ ',ci , ck , cj , cfld( ci , ck , cj )
ENDDO
ENDDO
ENDDO
#endif
RETURN
END SUBROUTINE interp_fcn
!==================================
! this is the default function used in feedback.
SUBROUTINE copy_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
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
! Local
INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff
! Iterate over the ND tile and compute the values
! from the CD tile.
!write(0,'(") cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
!write(0,'(") nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
!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
ioff = 0 ; joff = 0
if ( xstag ) ioff = 1
if ( ystag ) joff = 1
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
IF ((ip == nri/2 - ioff) .AND. (jp == nrj/2 - joff) ) THEN
cfld( ci+shw, ck, cj+shw ) = nfld( ni , nk , nj )
!if ( ck == 1 ) write(0,*)'>> ci cj ni nj ',ci+shw,cj+shw,ni,nj,cfld( ci+shw, ck, cj+shw )
ENDIF
ENDDO
ENDDO
ENDDO
RETURN
END SUBROUTINE copy_fcn
!==================================
SUBROUTINE bdy_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
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, & ! nest ratios
cdt, ndt, &
cbdy, nbdy, &
cbdy_t, nbdy_t &
) ! boundary arrays
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
REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t
REAL cdt, ndt
! Local
INTEGER nijds, nijde, spec_bdy_width
nijds = min(nids, njds)
nijde = max(nide, njde)
CALL get_spec_bdy_width( spec_bdy_width )
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 , spec_bdy_width , &
nids, nide, nkds, nkde, njds, njde, &
nims, nime, nkms, nkme, njms, njme, &
nits, nite, nkts, nkte, njts, njte, &
shw, &
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
cdt, ndt, &
cbdy, nbdy, &
cbdy_t, nbdy_t &
)
RETURN
END SUBROUTINE bdy_interp
SUBROUTINE bdy_interp1( cfld, & ! CD field 1,1
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, &
shw, &
xstag, ystag, & ! staggering of field
ipos, jpos, & ! Position of lower left of nest in CD
nri, nrj, &
cdt, ndt, &
cbdy, bdy, &
cbdy_t, bdy_t &
)
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, &
shw, &
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
REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy, cbdy_t ! not used
REAL :: cdt, ndt
REAL, DIMENSION ( nijds:nijde, nkms:nkme, spec_bdy_width, 4 ), INTENT(INOUT) :: bdy, bdy_t
! Local
REAL*8 rdt
INTEGER ci, cj, ck, ni, nj, nk, ip, jp
#ifdef MM5_SINT
INTEGER nfx, ior
PARAMETER (ior=2)
INTEGER nf
REAL psca(cims:cime,cjms:cjme,nri*nrj)
INTEGER i,j,k
#endif
rdt = 1.D0/cdt
! Iterate over the ND tile and compute the values
! from the CD tile.
#ifdef MM5_SINT
nfx = nri * nrj
DO k = ckts, ckte
DO nf = 1,nfx
DO j = cjms,cjme
DO i = cims,cime
psca(i,j,nf) = cfld(i,k,j)
ENDDO
ENDDO
ENDDO
! 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.
!write(0,'(")) nijds:nijde nkms:nkme spec_bdy_width",5i4)')nijds,nijde,nkms,nkme,spec_bdy_width
!write(0,'(")) cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
!write(0,'(")) nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
!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
CALL sint( psca, &
cims, cime, cjms, cjme, &
cits-1, cite+1, cjts-1, cjte+1, nrj*nri )
DO nj = njts, njte
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
ci = ipos + (ni-1) / nri ! j coord of CD point
ip = mod ( ni-1 , nri ) ! coord of ND w/i CD point
!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
!question: how bdy gets set first time through?? isn't that stored in nfld right now?
!compute the derivative using that instead?
! how to get rdt down here??
IF ( ni .ge. nids .and. ni .lt. nids + spec_bdy_width ) THEN
bdy_t( nj,k,ni, P_XSB ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy( nj,k,ni, P_XSB ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
!if (k==1) write(0,*)' P_XSB: ',nj,ni,bdy( nj,k,ni,P_XSB),psca(ci+shw,cj+shw,ip+1+(jp)*nri)
!if (k==1) write(0,*)' P_XSB: ',bdy( nj,k,ni,P_XSB),psca(ci+shw,cj+shw,ip+1+(jp)*nri),nfld(ni,k,nj)
ENDIF
IF ( nj .ge. njds .and. nj .lt. njds + spec_bdy_width ) THEN
bdy_t( ni,k,nj, P_YSB ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy( ni,k,nj, P_YSB ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
!if (k==1) write(0,*)' P_YSB: ',nj,ni,ci,cj, bdy( nj,k,ni, P_YSB )
ENDIF
#if 1
IF ( xstag ) THEN
IF ( ni .le. nide .and. ni .ge. nide - spec_bdy_width+1 ) THEN
bdy_t( nj,k,nide-ni+1, P_XEB ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy( nj,k,nide-ni+1, P_XEB ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
ENDIF
ELSE
IF ( ni .le. nide-1 .and. ni .ge. nide - spec_bdy_width ) THEN
bdy_t( nj,k,nide-ni, P_XEB ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy( nj,k,nide-ni, P_XEB ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
ENDIF
ENDIF
IF ( ystag ) THEN
IF ( nj .le. njde .and. nj .ge. njde - spec_bdy_width+1 ) THEN
bdy_t(ni,k,njde-nj+1,P_YEB ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy( ni,k,njde-nj+1,P_YEB ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
ENDIF
ELSE
IF ( nj .le. njde-1 .and. nj .ge. njde - spec_bdy_width ) THEN
bdy_t(ni,k,njde-nj,P_YEB ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
bdy( ni,k,njde-nj,P_YEB ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
ENDIF
ENDIF
#else
! write(0,*)" bdy_interp: n and e bdys commented out "
#endif
ENDDO
ENDDO
ENDDO
#endif
#ifdef DUMBCOPY
!write(0,'("cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
!write(0,'("nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
!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
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
RETURN
END SUBROUTINE bdy_interp1
SUBROUTINE interp_fcni( 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, &
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, &
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
! 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
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
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, &
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, &
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
! 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 none
END SUBROUTINE none