PageRenderTime 92ms CodeModel.GetById 21ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/share/interp_fcn.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 4745 lines | 2932 code | 628 blank | 1185 comment | 18 complexity | dc16ac86532aa48d91fa387825e5a956 MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. !WRF:MEDIATION_LAYER:INTERPOLATIONFUNCTION
    2. 

  2. !
    3. 

  3. 

  4. #if (DA_CORE != 1)
    5. 

  5. #define MM5_SINT
    6. 

  6. #endif
    7. 

  7. !#define DUMBCOPY
    8. 

  8. 

  9. ! Note, NMM-specific routines moved to end. 20080612. JM
    10. 

  10. 

  11.    SUBROUTINE interp_fcn ( cfld,                                 &  ! CD field
    12. 

  12.                            cids, cide, ckds, ckde, cjds, cjde,   &
    13. 

  13.                            cims, cime, ckms, ckme, cjms, cjme,   &
    14. 

  14.                            cits, cite, ckts, ckte, cjts, cjte,   &
    15. 

  15.                            nfld,                                 &  ! ND field
    16. 

  16.                            nids, nide, nkds, nkde, njds, njde,   &
    17. 

  17.                            nims, nime, nkms, nkme, njms, njme,   &
    18. 

  18.                            nits, nite, nkts, nkte, njts, njte,   &
    19. 

  19.                            shw,                                  &  ! stencil half width for interp
    20. 

  20.                            imask,                                &  ! interpolation mask
    21. 

  21.                            xstag, ystag,                         &  ! staggering of field
    22. 

  22.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    23. 

  23.                            nri, nrj                             )   ! nest ratios
    24. 

  24.      USE module_timing
    25. 

  25.      USE module_configure
    26. 

  26.      IMPLICIT NONE
    27. 

  27. 

  28. 

  29.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    30. 

  30.                             cims, cime, ckms, ckme, cjms, cjme,   &
    31. 

  31.                             cits, cite, ckts, ckte, cjts, cjte,   &
    32. 

  32.                             nids, nide, nkds, nkde, njds, njde,   &
    33. 

  33.                             nims, nime, nkms, nkme, njms, njme,   &
    34. 

  34.                             nits, nite, nkts, nkte, njts, njte,   &
    35. 

  35.                             shw,                                  &
    36. 

  36.                             ipos, jpos,                           &
    37. 

  37.                             nri, nrj
    38. 

  38.      LOGICAL, INTENT(IN) :: xstag, ystag
    39. 

  39. 

  40.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    41. 

  41.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    42. 

  42.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    43. 

  43. 

  44.      ! Local
    45. 

  45. 

  46. !logical first
    47. 

  47. 

  48.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, nioff, njoff
    49. 

  49. #ifdef MM5_SINT
    50. 

  50.      INTEGER nfx, ior
    51. 

  51.      PARAMETER (ior=2)
    52. 

  52.      INTEGER nf
    53. 

  53.      REAL psca(cims:cime,cjms:cjme,nri*nrj)
    54. 

  54.      LOGICAL icmask( cims:cime, cjms:cjme )
    55. 

  55.      INTEGER i,j,k
    56. 

  56.      INTEGER nrio2, nrjo2
    57. 

  57. #endif
    58. 

  58. 

  59.      ! Iterate over the ND tile and compute the values
    60. 

  60.      ! from the CD tile. 
    61. 

  61. 

  62. #ifdef MM5_SINT
    63. 

  63. 

  64.      ioff  = 0 ; joff  = 0
    65. 

  65.      nioff = 0 ; njoff = 0
    66. 

  66.      IF ( xstag ) THEN 
    67. 

  67.        ioff = (nri-1)/2
    68. 

  68.        nioff = nri 
    69. 

  69.      ENDIF
    70. 

  70.      IF ( ystag ) THEN
    71. 

  71.        joff = (nrj-1)/2
    72. 

  72.        njoff = nrj
    73. 

  73.      ENDIF
    74. 

  74. 

  75.      nrio2 = nri/2
    76. 

  76.      nrjo2 = nrj/2
    77. 

  77. 

  78.      nfx = nri * nrj
    79. 

  79.    !$OMP PARALLEL DO   &
    80. 

  80.    !$OMP PRIVATE ( i,j,k,ni,nj,ci,cj,ip,jp,nk,ck,nf,icmask,psca )
    81. 

  81.      DO k = ckts, ckte
    82. 

  82.         icmask = .FALSE.
    83. 

  83.         DO nf = 1,nfx
    84. 

  84.            DO j = cjms,cjme
    85. 

  85.               nj = (j-jpos) * nrj + ( nrjo2 + 1 )  ! j point on nest
    86. 

  86.               DO i = cims,cime
    87. 

  87.                 ni = (i-ipos) * nri + ( nrio2 + 1 )    ! i point on nest
    88. 

  88.                 if ( ni .ge. nits-nioff-nrio2 .and. &
    89. 

  89.                      ni .le. nite+nioff+nrio2 .and. &
    90. 

  90.                      nj .ge. njts-njoff-nrjo2 .and. &
    91. 

  91.                      nj .le. njte+njoff+nrjo2 ) then
    92. 

  92. !                 if ( imask(ni,nj) .eq. 1 .or. imask(ni-nioff,nj-njoff) .eq. 1 ) then
    93. 

  93. !                   icmask( i, j ) = .TRUE.
    94. 

  94. !                 endif
    95. 

  95.                  if ( ni.ge.nims.and.ni.le.nime.and.nj.ge.njms.and.nj.le.njme) then
    96. 

  96.                   if ( imask(ni,nj) .eq. 1 ) then
    97. 

  97.                     icmask( i, j ) = .TRUE.
    98. 

  98.                   endif
    99. 

  99.                  endif
    100. 

  100.                  if ( ni-nioff.ge.nims.and.ni.le.nime.and.nj-njoff.ge.njms.and.nj.le.njme) then
    101. 

  101.                   if (ni .ge. nits-nioff .and. nj .ge. njts-njoff ) then
    102. 

  102.                     if ( imask(ni-nioff,nj-njoff) .eq. 1) then
    103. 

  103.                         icmask( i, j ) = .TRUE.
    104. 

  104.                     endif
    105. 

  105.                   endif
    106. 

  106.                  endif
    107. 

  107.                 endif
    108. 

  108.                 psca(i,j,nf) = cfld(i,k,j)
    109. 

  109.               ENDDO
    110. 

  110.            ENDDO
    111. 

  111.         ENDDO
    112. 

  112. 

  113. ! tile dims in this call to sint are 1-over to account for the fact
    114. 

  114. ! that the number of cells on the nest local subdomain is not 
    115. 

  115. ! necessarily a multiple of the nest ratio in a given dim.
    116. 

  116. ! this could be a little less ham-handed.
    117. 

  117. 

  118. !call start_timing
    119. 

  119. 

  120.         CALL sint( psca,                     &
    121. 

  121.                    cims, cime, cjms, cjme, icmask,   &
    122. 

  122.                    cits-1, cite+1, cjts-1, cjte+1, nrj*nri, xstag, ystag )
    123. 

  123. 

  124. !call end_timing( ' sint ' )
    125. 

  125. 

  126.         DO nj = njts, njte+joff
    127. 

  127.            cj = jpos + (nj-1) / nrj ! j coord of CD point 
    128. 

  128.            jp = mod ( nj-1 , nrj )  ! coord of ND w/i CD point
    129. 

  129.            nk = k
    130. 

  130.            ck = nk
    131. 

  131.            DO ni = nits, nite+ioff
    132. 

  132.                ci = ipos + (ni-1) / nri      ! i coord of CD point 
    133. 

  133.                ip = mod ( ni-1 , nri )  ! coord of ND w/i CD point
    134. 

  134.                if ( imask ( ni, nj ) .eq. 1 .or. imask ( ni-ioff, nj-joff ) .eq. 1  ) then
    135. 

  135.                  nfld( ni-ioff, nk, nj-joff ) = psca( ci , cj, ip+1 + (jp)*nri )
    136. 

  136.                endif
    137. 

  137.            ENDDO
    138. 

  138.         ENDDO
    139. 

  139.      ENDDO
    140. 

  140.    !$OMP END PARALLEL DO
    141. 

  141. #endif
    142. 

  142. 

  143. #ifdef DUMBCOPY
    144. 

  144. !write(0,'(") cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
    145. 

  145. !write(0,'(") nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
    146. 

  146. !write(0,'(") cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
    147. 

  147. !write(0,'(") nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
    148. 

  148. 

  149.      DO nj = njts, njte
    150. 

  150.         cj = jpos + (nj-1) / nrj     ! j coord of CD point 
    151. 

  151.         jp = mod ( nj , nrj )  ! coord of ND w/i CD point
    152. 

  152.         DO nk = nkts, nkte
    153. 

  153.            ck = nk
    154. 

  154.            DO ni = nits, nite
    155. 

  155.               ci = ipos + (ni-1) / nri      ! j coord of CD point 
    156. 

  156.               ip = mod ( ni , nri )  ! coord of ND w/i CD point
    157. 

  157.               ! This is a trivial implementation of the interp_fcn; just copies
    158. 

  158.               ! the values from the CD into the ND
    159. 

  159.               if ( imask ( ni, nj ) .eq. 1 ) then
    160. 

  160.                 nfld( ni, nk, nj ) = cfld( ci , ck , cj )
    161. 

  161.               endif
    162. 

  162.            ENDDO
    163. 

  163.         ENDDO
    164. 

  164.      ENDDO
    165. 

  165. #endif
    166. 

  166. 

  167.      RETURN
    168. 

  168. 

  169.    END SUBROUTINE interp_fcn
    170. 

  170. 

  171. !==================================
    172. 

  172. ! this is the default function used in feedback.
    173. 

  173. 

  174.    SUBROUTINE copy_fcn ( cfld,                                 &  ! CD field
    175. 

  175.                            cids, cide, ckds, ckde, cjds, cjde,   &
    176. 

  176.                            cims, cime, ckms, ckme, cjms, cjme,   &
    177. 

  177.                            cits, cite, ckts, ckte, cjts, cjte,   &
    178. 

  178.                            nfld,                                 &  ! ND field
    179. 

  179.                            nids, nide, nkds, nkde, njds, njde,   &
    180. 

  180.                            nims, nime, nkms, nkme, njms, njme,   &
    181. 

  181.                            nits, nite, nkts, nkte, njts, njte,   &
    182. 

  182.                            shw,                                  &  ! stencil half width for interp
    183. 

  183.                            imask,                                &  ! interpolation mask
    184. 

  184.                            xstag, ystag,                         &  ! staggering of field
    185. 

  185.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    186. 

  186.                            nri, nrj                             )   ! nest ratios
    187. 

  187.      USE module_configure
    188. 

  188.      IMPLICIT NONE
    189. 

  189. 

  190. 

  191.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    192. 

  192.                             cims, cime, ckms, ckme, cjms, cjme,   &
    193. 

  193.                             cits, cite, ckts, ckte, cjts, cjte,   &
    194. 

  194.                             nids, nide, nkds, nkde, njds, njde,   &
    195. 

  195.                             nims, nime, nkms, nkme, njms, njme,   &
    196. 

  196.                             nits, nite, nkts, nkte, njts, njte,   &
    197. 

  197.                             shw,                                  &
    198. 

  198.                             ipos, jpos,                           &
    199. 

  199.                             nri, nrj
    200. 

  200.      LOGICAL, INTENT(IN) :: xstag, ystag
    201. 

  201. 

  202.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
    203. 

  203.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ),INTENT(IN)  :: nfld
    204. 

  204.      INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN)  :: imask
    205. 

  205. 

  206.      ! Local
    207. 

  207. 

  208.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
    209. 

  209.      INTEGER :: icmin,icmax,jcmin,jcmax
    210. 

  210.      INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
    211. 

  211.      INTEGER , PARAMETER :: passes = 2
    212. 

  212.      INTEGER spec_zone
    213. 

  213. 

  214.      !  Loop over the coarse grid in the area of the fine mesh.  Do not
    215. 

  215.      !  process the coarse grid values that are along the lateral BC
    216. 

  216.      !  provided to the fine grid.  Since that is in the specified zone
    217. 

  217.      !  for the fine grid, it should not be used in any feedback to the
    218. 

  218.      !  coarse grid as it should not have changed.
    219. 

  219. 

  220.      !  Due to peculiarities of staggering, it is simpler to handle the feedback
    221. 

  221.      !  for the staggerings based upon whether it is a even ratio (2::1, 4::1, etc.) or
    222. 

  222.      !  an odd staggering ratio (3::1, 5::1, etc.). 
    223. 

  223. 

  224.      !  Though there are separate grid ratios for the i and j directions, this code
    225. 

  225.      !  is not general enough to handle aspect ratios .NE. 1 for the fine grid cell.
    226. 

  226.  
    227. 

  227.      !  These are local integer increments in the looping.  Basically, istag=1 means
    228. 

  228.      !  that we will assume one less point in the i direction.  Note that ci and cj
    229. 

  229.      !  have a maximum value that is decreased by istag and jstag, respectively.  
    230. 

  230. 

  231.      !  Horizontal momentum feedback is along the face, not within the cell.  For a
    232. 

  232.      !  3::1 ratio, temperature would use 9 pts for feedback, while u and v use
    233. 

  233.      !  only 3 points for feedback from the nest to the parent.
    234. 

  234. 

  235.      CALL nl_get_spec_zone( 1 , spec_zone )
    236. 

  236.      istag = 1 ; jstag = 1
    237. 

  237.      IF ( xstag ) istag = 0
    238. 

  238.      IF ( ystag ) jstag = 0
    239. 

  239. 

  240.      IF( MOD(nrj,2) .NE. 0) THEN  ! odd refinement ratio
    241. 

  241. 

  242.         IF      ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
    243. 

  243.            DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    244. 

  244.               nj = (cj-jpos)*nrj + jstag + 1
    245. 

  245.               DO ck = ckts, ckte
    246. 

  246.                  nk = ck
    247. 

  247.                  DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    248. 

  248.                     ni = (ci-ipos)*nri + istag + 1
    249. 

  249.                     cfld( ci, ck, cj ) = 0.
    250. 

  250.                     DO ijpoints = 1 , nri * nrj
    251. 

  251.                        ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
    252. 

  252.                        jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
    253. 

  253.                        cfld( ci, ck, cj ) =  cfld( ci, ck, cj ) + &
    254. 

  254.                                              1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints )
    255. 

  255.                     END DO
    256. 

  256. !                   cfld( ci, ck, cj ) =  1./9. * &
    257. 

  257. !                                         ( nfld( ni-1, nk , nj-1) + &
    258. 

  258. !                                           nfld( ni  , nk , nj-1) + &
    259. 

  259. !                                           nfld( ni+1, nk , nj-1) + &
    260. 

  260. !                                           nfld( ni-1, nk , nj  ) + &
    261. 

  261. !                                           nfld( ni  , nk , nj  ) + &
    262. 

  262. !                                           nfld( ni+1, nk , nj  ) + &
    263. 

  263. !                                           nfld( ni-1, nk , nj+1) + &
    264. 

  264. !                                           nfld( ni  , nk , nj+1) + &
    265. 

  265. !                                           nfld( ni+1, nk , nj+1) )
    266. 

  266.                  ENDDO
    267. 

  267.               ENDDO
    268. 

  268.            ENDDO
    269. 

  269. 

  270.         ELSE IF ( (       xstag ) .AND. ( .NOT. ystag ) ) THEN
    271. 

  271.            DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    272. 

  272.               nj = (cj-jpos)*nrj + jstag + 1
    273. 

  273.               DO ck = ckts, ckte
    274. 

  274.                  nk = ck
    275. 

  275.                  DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    276. 

  276.                     ni = (ci-ipos)*nri + istag + 1
    277. 

  277.                     cfld( ci, ck, cj ) = 0.
    278. 

  278.                     DO ijpoints = (nri+1)/2 , (nri+1)/2 + nri*(nri-1) , nri
    279. 

  279.                        ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
    280. 

  280.                        jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
    281. 

  281.                        cfld( ci, ck, cj ) =  cfld( ci, ck, cj ) + &
    282. 

  282.                                              1./REAL(nri    ) * nfld( ni+ipoints , nk , nj+jpoints )
    283. 

  283.                     END DO
    284. 

  284. !                   cfld( ci, ck, cj ) =  1./3. * &
    285. 

  285. !                                         ( nfld( ni  , nk , nj-1) + &
    286. 

  286. !                                           nfld( ni  , nk , nj  ) + &
    287. 

  287. !                                           nfld( ni  , nk , nj+1) )
    288. 

  288.                  ENDDO
    289. 

  289.               ENDDO
    290. 

  290.            ENDDO
    291. 

  291. 

  292.         ELSE IF ( ( .NOT. xstag ) .AND. (       ystag ) ) THEN
    293. 

  293.            DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    294. 

  294.               nj = (cj-jpos)*nrj + jstag + 1
    295. 

  295.               DO ck = ckts, ckte
    296. 

  296.                  nk = ck
    297. 

  297.                  DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    298. 

  298.                     ni = (ci-ipos)*nri + istag + 1
    299. 

  299.                     cfld( ci, ck, cj ) = 0.
    300. 

  300.                     DO ijpoints = ( nrj*nrj +1 )/2 - nrj/2 , ( nrj*nrj +1 )/2 - nrj/2 + nrj-1
    301. 

  301.                        ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
    302. 

  302.                        jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
    303. 

  303.                        cfld( ci, ck, cj ) =  cfld( ci, ck, cj ) + &
    304. 

  304.                                              1./REAL(    nrj) * nfld( ni+ipoints , nk , nj+jpoints )
    305. 

  305.                     END DO
    306. 

  306. !                   cfld( ci, ck, cj ) =  1./3. * &
    307. 

  307. !                                         ( nfld( ni-1, nk , nj  ) + &
    308. 

  308. !                                           nfld( ni  , nk , nj  ) + &
    309. 

  309. !                                           nfld( ni+1, nk , nj  ) )
    310. 

  310.                  ENDDO
    311. 

  311.               ENDDO
    312. 

  312.            ENDDO
    313. 

  313. 

  314.         END IF
    315. 

  315. 

  316.      !  Even refinement ratio
    317. 

  317. 

  318.      ELSE IF ( MOD(nrj,2) .EQ. 0) THEN
    319. 

  319.         IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
    320. 

  320. 

  321.         !  This is a simple schematic of the feedback indexing used in the even
    322. 

  322.         !  ratio nests.  For simplicity, a 2::1 ratio is depicted.  Only the 
    323. 

  323.         !  mass variable staggering is shown. 
    324. 

  324.         !                                                                  Each of
    325. 

  325.         !  the boxes with a "T" and four small "t" represents a coarse grid (CG)
    326. 

  326.         !  cell, that is composed of four (2::1 ratio) fine grid (FG) cells.
    327. 

  327.    
    328. 

  328.         !  Shown below is the area of the CG that is in the area of the FG.   The
    329. 

  329.         !  first grid point of the depicted CG is the starting location of the nest
    330. 

  330.         !  in the parent domain (ipos,jpos - i_parent_start and j_parent_start from
    331. 

  331.         !  the namelist).  
    332. 

  332.    
    333. 

  333.         !  For each of the CG points, the feedback loop is over each of the FG points
    334. 

  334.         !  within the CG cell.  For a 2::1 ratio, there are four total points (this is 
    335. 

  335.         !  the ijpoints loop).  The feedback value to the CG is the arithmetic mean of 
    336. 

  336.         !  all of the FG values within each CG cell.
    337. 

  337. 

  338. !              |-------------||-------------|                          |-------------||-------------|
    339. 

  339. !              |  t      t   ||  t      t   |                          |  t      t   ||  t      t   |
    340. 

  340. ! jpos+        |             ||             |                          |             ||             |
    341. 

  341. ! (njde-njds)- |      T      ||      T      |                          |      T      ||      T      |
    342. 

  342. ! jstag        |             ||             |                          |             ||             |
    343. 

  343. !              |  t      t   ||  t      t   |                          |  t      t   ||  t      t   |
    344. 

  344. !              |-------------||-------------|                          |-------------||-------------|
    345. 

  345. !              |-------------||-------------|                          |-------------||-------------|
    346. 

  346. !              |  t      t   ||  t      t   |                          |  t      t   ||  t      t   |
    347. 

  347. !              |             ||             |                          |             ||             |
    348. 

  348. !              |      T      ||      T      |                          |      T      ||      T      |
    349. 

  349. !              |             ||             |                          |             ||             |
    350. 

  350. !              |  t      t   ||  t      t   |                          |  t      t   ||  t      t   |
    351. 

  351. !              |-------------||-------------|                          |-------------||-------------|
    352. 

  352. !
    353. 

  353. !                   ...
    354. 

  354. !                   ...
    355. 

  355. !                   ...
    356. 

  356. !                   ...
    357. 

  357. !                   ...
    358. 

  358. 

  359. !              |-------------||-------------|                          |-------------||-------------|
    360. 

  360. ! jpoints = 1  |  t      t   ||  t      t   |                          |  t      t   ||  t      t   |
    361. 

  361. !              |             ||             |                          |             ||             |
    362. 

  362. !              |      T      ||      T      |                          |      T      ||      T      |
    363. 

  363. !              |             ||             |                          |             ||             |
    364. 

  364. ! jpoints = 0, |  t      t   ||  t      t   |                          |  t      t   ||  t      t   |
    365. 

  365. !  nj=3        |-------------||-------------|                          |-------------||-------------|
    366. 

  366. !              |-------------||-------------|                          |-------------||-------------|
    367. 

  367. ! jpoints = 1  |  t      t   ||  t      t   |                          |  t      t   ||  t      t   |
    368. 

  368. !              |             ||             |                          |             ||             |
    369. 

  369. !    jpos      |      T      ||      T      |          ...             |      T      ||      T      |
    370. 

  370. !              |             ||             |          ...             |             ||             |
    371. 

  371. ! jpoints = 0, |  t      t   ||  t      t   |          ...             |  t      t   ||  t      t   |
    372. 

  372. !  nj=1        |-------------||-------------|                          |-------------||-------------|
    373. 

  373. !                     ^                                                                      ^
    374. 

  374. !                     |                                                                      |
    375. 

  375. !                     |                                                                      |
    376. 

  376. !                   ipos                                                                   ipos+
    377. 

  377. !     ni =        1              3                                                         (nide-nids)/nri
    378. 

  378. ! ipoints=        0      1       0      1                                                  -istag
    379. 

  379. !
    380. 

  380. 

  381.            !  For performance benefits, users can comment out the inner most loop (and cfld=0) and
    382. 

  382.            !  hardcode the loop feedback.  For example, it is set up to run a 2::1 ratio
    383. 

  383.            !  if uncommented.  This lacks generality, but is likely to gain timing benefits
    384. 

  384.            !  with compilers unable to unroll inner loops that do not have parameterized sizes.
    385. 

  385.    
    386. 

  386.            !  The extra +1 ---------/ and the extra -1 ----\  (both for ci and cj) 
    387. 

  387.            !                       /                        \   keeps the feedback out of the 
    388. 

  388.            !                      /                          \  outer row/col, since that CG data
    389. 

  389.            !                     /                            \ specified the nest boundary originally
    390. 

  390.            !                    /                              \   This
    391. 

  391.            !                   /                                \    is just
    392. 

  392.            !                  /                                  \   a sentence to not end a line
    393. 

  393.            !                 /                                    \   with a stupid backslash
    394. 

  394.            DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    395. 

  395.               nj = (cj-jpos)*nrj + jstag
    396. 

  396.               DO ck = ckts, ckte
    397. 

  397.                  nk = ck
    398. 

  398.                  DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    399. 

  399.                     ni = (ci-ipos)*nri + istag
    400. 

  400.                     cfld( ci, ck, cj ) = 0.
    401. 

  401.                     DO ijpoints = 1 , nri * nrj
    402. 

  402.                        ipoints = MOD((ijpoints-1),nri)
    403. 

  403.                        jpoints = (ijpoints-1)/nri
    404. 

  404.                        cfld( ci, ck, cj ) =  cfld( ci, ck, cj ) + &
    405. 

  405.                                              1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints )
    406. 

  406.                     END DO
    407. 

  407. !                   cfld( ci, ck, cj ) =  1./4. * &
    408. 

  408. !                                         ( nfld( ni  , nk , nj  ) + &
    409. 

  409. !                                           nfld( ni+1, nk , nj  ) + &
    410. 

  410. !                                           nfld( ni  , nk , nj+1) + &
    411. 

  411. !                                           nfld( ni+1, nk , nj+1) )
    412. 

  412.                  END DO
    413. 

  413.               END DO
    414. 

  414.            END DO
    415. 

  415. 

  416.         !  U
    417. 

  417. 

  418.         ELSE IF ( (       xstag ) .AND. ( .NOT. ystag ) ) THEN
    419. 

  419. !              |---------------|
    420. 

  420. !              |               |
    421. 

  421. ! jpoints = 1  u       u       |
    422. 

  422. !              |               |
    423. 

  423. !              U               |
    424. 

  424. !              |               |
    425. 

  425. ! jpoints = 0, u       u       |
    426. 

  426. !  nj=3        |               |
    427. 

  427. !              |---------------|
    428. 

  428. !              |---------------|
    429. 

  429. !              |               |
    430. 

  430. ! jpoints = 1  u       u       |
    431. 

  431. !              |               |
    432. 

  432. !    jpos      U               |
    433. 

  433. !              |               |
    434. 

  434. ! jpoints = 0, u       u       |
    435. 

  435. ! nj=1         |               |
    436. 

  436. !              |---------------|
    437. 

  437. ! 
    438. 

  438. !              ^               
    439. 

  439. !              |              
    440. 

  440. !              |             
    441. 

  441. !            ipos           
    442. 

  442. !     ni =     1               3
    443. 

  443. ! ipoints=     0       1       0 
    444. 

  444. !
    445. 

  445. 

  446.            DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    447. 

  447.               nj = (cj-jpos)*nrj + 1
    448. 

  448.               DO ck = ckts, ckte
    449. 

  449.                  nk = ck
    450. 

  450.                  DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    451. 

  451.                     ni = (ci-ipos)*nri + 1
    452. 

  452.                     cfld( ci, ck, cj ) = 0.
    453. 

  453.                     DO ijpoints = 1 , nri*nrj , nri
    454. 

  454.                        ipoints = MOD((ijpoints-1),nri)
    455. 

  455.                        jpoints = (ijpoints-1)/nri
    456. 

  456.                        cfld( ci, ck, cj ) =  cfld( ci, ck, cj ) + &
    457. 

  457.                                              1./REAL(nri    ) * nfld( ni+ipoints , nk , nj+jpoints )
    458. 

  458.                     END DO
    459. 

  459. !                cfld( ci, ck, cj ) =  1./2. * &
    460. 

  460. !                                      ( nfld( ni  , nk , nj  ) + &
    461. 

  461. !                                        nfld( ni  , nk , nj+1) )
    462. 

  462.                  ENDDO
    463. 

  463.               ENDDO
    464. 

  464.            ENDDO
    465. 

  465. 

  466.         !  V 
    467. 

  467. 

  468.         ELSE IF ( ( .NOT. xstag ) .AND. (       ystag ) ) THEN
    469. 

  469.            DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    470. 

  470.               nj = (cj-jpos)*nrj + 1
    471. 

  471.               DO ck = ckts, ckte
    472. 

  472.                  nk = ck
    473. 

  473.                  DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    474. 

  474.                     ni = (ci-ipos)*nri + 1
    475. 

  475.                     cfld( ci, ck, cj ) = 0.
    476. 

  476.                     DO ijpoints = 1 , nri
    477. 

  477.                        ipoints = MOD((ijpoints-1),nri)
    478. 

  478.                        jpoints = (ijpoints-1)/nri
    479. 

  479.                        cfld( ci, ck, cj ) =  cfld( ci, ck, cj ) + &
    480. 

  480.                                              1./REAL(nri    ) * nfld( ni+ipoints , nk , nj+jpoints )
    481. 

  481.                     END DO
    482. 

  482. !                cfld( ci, ck, cj ) =  1./2. * &
    483. 

  483. !                                      ( nfld( ni  , nk , nj  ) + &
    484. 

  484. !                                        nfld( ni+1, nk , nj  ) )
    485. 

  485.                  ENDDO
    486. 

  486.               ENDDO
    487. 

  487.            ENDDO
    488. 

  488.         END IF
    489. 

  489.      END IF
    490. 

  490. 

  491.      RETURN
    492. 

  492. 

  493.    END SUBROUTINE copy_fcn
    494. 

  494. 

  495. !==================================
    496. 

  496. ! this is the 1pt function used in feedback.
    497. 

  497. 

  498.    SUBROUTINE copy_fcnm (  cfld,                                 &  ! CD field
    499. 

  499.                            cids, cide, ckds, ckde, cjds, cjde,   &
    500. 

  500.                            cims, cime, ckms, ckme, cjms, cjme,   &
    501. 

  501.                            cits, cite, ckts, ckte, cjts, cjte,   &
    502. 

  502.                            nfld,                                 &  ! ND field
    503. 

  503.                            nids, nide, nkds, nkde, njds, njde,   &
    504. 

  504.                            nims, nime, nkms, nkme, njms, njme,   &
    505. 

  505.                            nits, nite, nkts, nkte, njts, njte,   &
    506. 

  506.                            shw,                                  &  ! stencil half width for interp
    507. 

  507.                            imask,                                &  ! interpolation mask
    508. 

  508.                            xstag, ystag,                         &  ! staggering of field
    509. 

  509.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    510. 

  510.                            nri, nrj                             )   ! nest ratios
    511. 

  511.      USE module_configure
    512. 

  512.      USE module_wrf_error
    513. 

  513.      IMPLICIT NONE
    514. 

  514. 

  515. 

  516.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    517. 

  517.                             cims, cime, ckms, ckme, cjms, cjme,   &
    518. 

  518.                             cits, cite, ckts, ckte, cjts, cjte,   &
    519. 

  519.                             nids, nide, nkds, nkde, njds, njde,   &
    520. 

  520.                             nims, nime, nkms, nkme, njms, njme,   &
    521. 

  521.                             nits, nite, nkts, nkte, njts, njte,   &
    522. 

  522.                             shw,                                  &
    523. 

  523.                             ipos, jpos,                           &
    524. 

  524.                             nri, nrj
    525. 

  525.      LOGICAL, INTENT(IN) :: xstag, ystag
    526. 

  526. 

  527.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
    528. 

  528.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
    529. 

  529.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
    530. 

  530. 

  531.      ! Local
    532. 

  532. 

  533.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
    534. 

  534.      INTEGER :: icmin,icmax,jcmin,jcmax
    535. 

  535.      INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
    536. 

  536.      INTEGER , PARAMETER :: passes = 2
    537. 

  537.      INTEGER spec_zone
    538. 

  538. 

  539.      CALL nl_get_spec_zone( 1, spec_zone ) 
    540. 

  540.      istag = 1 ; jstag = 1
    541. 

  541.      IF ( xstag ) istag = 0
    542. 

  542.      IF ( ystag ) jstag = 0
    543. 

  543. 

  544.      IF( MOD(nrj,2) .NE. 0) THEN  ! odd refinement ratio
    545. 

  545. 

  546.         DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    547. 

  547.            nj = (cj-jpos)*nrj + jstag + 1
    548. 

  548.            DO ck = ckts, ckte
    549. 

  549.               nk = ck
    550. 

  550.               DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    551. 

  551.                  ni = (ci-ipos)*nri + istag + 1
    552. 

  552.                  cfld( ci, ck, cj ) =  nfld( ni  , nk , nj  )
    553. 

  553.               ENDDO
    554. 

  554.            ENDDO
    555. 

  555.         ENDDO
    556. 

  556. 

  557.      ELSE  ! even refinement ratio, pick nearest neighbor on SW corner
    558. 

  558.         DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    559. 

  559.            nj = (cj-jpos)*nrj + 1
    560. 

  560.            DO ck = ckts, ckte
    561. 

  561.               nk = ck
    562. 

  562.               DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    563. 

  563.                  ni = (ci-ipos)*nri + 1
    564. 

  564.                  ipoints = nri/2 -1
    565. 

  565.                  jpoints = nrj/2 -1
    566. 

  566.                  cfld( ci, ck, cj ) =  nfld( ni+ipoints , nk , nj+jpoints )
    567. 

  567.               END DO
    568. 

  568.            END DO
    569. 

  569.         END DO
    570. 

  570. 

  571.      END IF
    572. 

  572. 

  573.      RETURN
    574. 

  574. 

  575.    END SUBROUTINE copy_fcnm
    576. 

  576. 

  577. !==================================
    578. 

  578. ! this is the 1pt function used in feedback for integers
    579. 

  579. 

  580.    SUBROUTINE copy_fcni ( cfld,                                 &  ! CD field
    581. 

  581.                            cids, cide, ckds, ckde, cjds, cjde,   &
    582. 

  582.                            cims, cime, ckms, ckme, cjms, cjme,   &
    583. 

  583.                            cits, cite, ckts, ckte, cjts, cjte,   &
    584. 

  584.                            nfld,                                 &  ! ND field
    585. 

  585.                            nids, nide, nkds, nkde, njds, njde,   &
    586. 

  586.                            nims, nime, nkms, nkme, njms, njme,   &
    587. 

  587.                            nits, nite, nkts, nkte, njts, njte,   &
    588. 

  588.                            shw,                                  &  ! stencil half width for interp
    589. 

  589.                            imask,                                &  ! interpolation mask
    590. 

  590.                            xstag, ystag,                         &  ! staggering of field
    591. 

  591.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    592. 

  592.                            nri, nrj                             )   ! nest ratios
    593. 

  593.      USE module_configure
    594. 

  594.      USE module_wrf_error
    595. 

  595.      IMPLICIT NONE
    596. 

  596. 

  597. 

  598.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    599. 

  599.                             cims, cime, ckms, ckme, cjms, cjme,   &
    600. 

  600.                             cits, cite, ckts, ckte, cjts, cjte,   &
    601. 

  601.                             nids, nide, nkds, nkde, njds, njde,   &
    602. 

  602.                             nims, nime, nkms, nkme, njms, njme,   &
    603. 

  603.                             nits, nite, nkts, nkte, njts, njte,   &
    604. 

  604.                             shw,                                  &
    605. 

  605.                             ipos, jpos,                           &
    606. 

  606.                             nri, nrj
    607. 

  607.      LOGICAL, INTENT(IN) :: xstag, ystag
    608. 

  608. 

  609.      INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
    610. 

  610.      INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
    611. 

  611.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN)  :: imask
    612. 

  612. 

  613.      ! Local
    614. 

  614. 

  615.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
    616. 

  616.      INTEGER :: icmin,icmax,jcmin,jcmax
    617. 

  617.      INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
    618. 

  618.      INTEGER , PARAMETER :: passes = 2
    619. 

  619.      INTEGER spec_zone
    620. 

  620. 

  621.      CALL nl_get_spec_zone( 1, spec_zone ) 
    622. 

  622.      istag = 1 ; jstag = 1
    623. 

  623.      IF ( xstag ) istag = 0
    624. 

  624.      IF ( ystag ) jstag = 0
    625. 

  625. 

  626.      IF( MOD(nrj,2) .NE. 0) THEN  ! odd refinement ratio
    627. 

  627. 

  628.         DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    629. 

  629.            nj = (cj-jpos)*nrj + jstag + 1
    630. 

  630.            DO ck = ckts, ckte
    631. 

  631.               nk = ck
    632. 

  632.               DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    633. 

  633.                  ni = (ci-ipos)*nri + istag + 1
    634. 

  634.                  cfld( ci, ck, cj ) =  nfld( ni  , nk , nj  )
    635. 

  635.               ENDDO
    636. 

  636.            ENDDO
    637. 

  637.         ENDDO
    638. 

  638. 

  639.      ELSE  ! even refinement ratio
    640. 

  640.         DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
    641. 

  641.            nj = (cj-jpos)*nrj + 1
    642. 

  642.            DO ck = ckts, ckte
    643. 

  643.               nk = ck
    644. 

  644.               DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
    645. 

  645.                  ni = (ci-ipos)*nri + 1
    646. 

  646.                  ipoints = nri/2 -1
    647. 

  647.                  jpoints = nrj/2 -1
    648. 

  648.                  cfld( ci, ck, cj ) =  nfld( ni+ipoints , nk , nj+jpoints )
    649. 

  649.               END DO
    650. 

  650.            END DO
    651. 

  651.         END DO
    652. 

  652. 

  653.      END IF
    654. 

  654. 

  655.      RETURN
    656. 

  656. 

  657.    END SUBROUTINE copy_fcni
    658. 

  658. 

  659. !==================================
    660. 

  660. 

  661.    SUBROUTINE p2c ( cfld,                                 &  ! CD field
    662. 

  662.                     cids, cide, ckds, ckde, cjds, cjde,   &
    663. 

  663.                     cims, cime, ckms, ckme, cjms, cjme,   &
    664. 

  664.                     cits, cite, ckts, ckte, cjts, cjte,   &
    665. 

  665.                     nfld,                                 &  ! ND field
    666. 

  666.                     nids, nide, nkds, nkde, njds, njde,   &
    667. 

  667.                     nims, nime, nkms, nkme, njms, njme,   &
    668. 

  668.                     nits, nite, nkts, nkte, njts, njte,   &
    669. 

  669.                     shw,                                  &  ! stencil half width
    670. 

  670.                     imask,                                &  ! interpolation mask
    671. 

  671.                     xstag, ystag,                         &  ! staggering of field
    672. 

  672.                     ipos, jpos,                           &  ! Position of lower left of nest in CD
    673. 

  673.                     nri, nrj                              &  ! nest ratios
    674. 

  674.                     )   
    675. 

  675.      USE module_configure
    676. 

  676.      IMPLICIT NONE
    677. 

  677. 

  678.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    679. 

  679.                             cims, cime, ckms, ckme, cjms, cjme,   &
    680. 

  680.                             cits, cite, ckts, ckte, cjts, cjte,   &
    681. 

  681.                             nids, nide, nkds, nkde, njds, njde,   &
    682. 

  682.                             nims, nime, nkms, nkme, njms, njme,   &
    683. 

  683.                             nits, nite, nkts, nkte, njts, njte,   &
    684. 

  684.                             shw,                                  &
    685. 

  685.                             ipos, jpos,                           &
    686. 

  686.                             nri, nrj
    687. 

  687. 

  688.      LOGICAL, INTENT(IN) :: xstag, ystag
    689. 

  689. 

  690.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    691. 

  691.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    692. 

  692.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    693. 

  693. 

  694.      CALL  interp_fcn  (cfld,                             &  ! CD field
    695. 

  695.                         cids, cide, ckds, ckde, cjds, cjde,   &
    696. 

  696.                         cims, cime, ckms, ckme, cjms, cjme,   &
    697. 

  697.                         cits, cite, ckts, ckte, cjts, cjte,   &
    698. 

  698.                         nfld,                             &  ! ND field
    699. 

  699.                         nids, nide, nkds, nkde, njds, njde,   &
    700. 

  700.                         nims, nime, nkms, nkme, njms, njme,   &
    701. 

  701.                         nits, nite, nkts, nkte, njts, njte,   &
    702. 

  702.                         shw,                                  &  ! stencil half width for interp
    703. 

  703.                         imask,                                &  ! interpolation mask
    704. 

  704.                         xstag, ystag,                         &  ! staggering of field
    705. 

  705.                         ipos, jpos,                           &  ! Position of lower left of nest in CD
    706. 

  706.                         nri, nrj                             )   ! nest ratios
    707. 

  707. 

  708.    END SUBROUTINE p2c
    709. 

  709. 

  710. !==================================
    711. 

  711. 

  712.    SUBROUTINE bdy_interp ( cfld,                                 &  ! CD field
    713. 

  713.                            cids, cide, ckds, ckde, cjds, cjde,   &
    714. 

  714.                            cims, cime, ckms, ckme, cjms, cjme,   &
    715. 

  715.                            cits, cite, ckts, ckte, cjts, cjte,   &
    716. 

  716.                            nfld,                                 &  ! ND field
    717. 

  717.                            nids, nide, nkds, nkde, njds, njde,   &
    718. 

  718.                            nims, nime, nkms, nkme, njms, njme,   &
    719. 

  719.                            nits, nite, nkts, nkte, njts, njte,   &
    720. 

  720.                            shw,                                  &  ! stencil half width
    721. 

  721.                            imask,                                &  ! interpolation mask
    722. 

  722.                            xstag, ystag,                         &  ! staggering of field
    723. 

  723.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    724. 

  724.                            nri, nrj,                             &  ! nest ratios
    725. 

  725.                            cbdy_xs, nbdy_xs,                           &
    726. 

  726.                            cbdy_xe, nbdy_xe,                           &
    727. 

  727.                            cbdy_ys, nbdy_ys,                           &
    728. 

  728.                            cbdy_ye, nbdy_ye,                           &
    729. 

  729.                            cbdy_txs, nbdy_txs,                       &
    730. 

  730.                            cbdy_txe, nbdy_txe,                       &
    731. 

  731.                            cbdy_tys, nbdy_tys,                       &
    732. 

  732.                            cbdy_tye, nbdy_tye,                       &
    733. 

  733.                            cdt, ndt                              &
    734. 

  734.                            )   ! boundary arrays
    735. 

  735.      USE module_configure
    736. 

  736.      IMPLICIT NONE
    737. 

  737. 

  738.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    739. 

  739.                             cims, cime, ckms, ckme, cjms, cjme,   &
    740. 

  740.                             cits, cite, ckts, ckte, cjts, cjte,   &
    741. 

  741.                             nids, nide, nkds, nkde, njds, njde,   &
    742. 

  742.                             nims, nime, nkms, nkme, njms, njme,   &
    743. 

  743.                             nits, nite, nkts, nkte, njts, njte,   &
    744. 

  744.                             shw,                                  &
    745. 

  745.                             ipos, jpos,                           &
    746. 

  746.                             nri, nrj
    747. 

  747. 

  748.      LOGICAL, INTENT(IN) :: xstag, ystag
    749. 

  749. 

  750.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    751. 

  751.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    752. 

  752.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    753. 

  753.      REAL,  DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs
    754. 

  754.      REAL,  DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe
    755. 

  755.      REAL,  DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys
    756. 

  756.      REAL,  DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye
    757. 

  757.      REAL cdt, ndt
    758. 

  758. 

  759.      ! Local
    760. 

  760. 

  761.      INTEGER nijds, nijde, spec_bdy_width
    762. 

  762. 

  763.      nijds = min(nids, njds)
    764. 

  764.      nijde = max(nide, njde)
    765. 

  765.      CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
    766. 

  766. 

  767.      CALL bdy_interp1( cfld,                                 &  ! CD field
    768. 

  768.                            cids, cide, ckds, ckde, cjds, cjde,   &
    769. 

  769.                            cims, cime, ckms, ckme, cjms, cjme,   &
    770. 

  770.                            cits, cite, ckts, ckte, cjts, cjte,   &
    771. 

  771.                            nfld,                                 &  ! ND field
    772. 

  772.                            nijds, nijde , spec_bdy_width ,       &  
    773. 

  773.                            nids, nide, nkds, nkde, njds, njde,   &
    774. 

  774.                            nims, nime, nkms, nkme, njms, njme,   &
    775. 

  775.                            nits, nite, nkts, nkte, njts, njte,   &
    776. 

  776.                            shw, imask,                           &
    777. 

  777.                            xstag, ystag,                         &  ! staggering of field
    778. 

  778.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    779. 

  779.                            nri, nrj,                             &
    780. 

  780.                            cbdy_xs, nbdy_xs,                           &
    781. 

  781.                            cbdy_xe, nbdy_xe,                           &
    782. 

  782.                            cbdy_ys, nbdy_ys,                           &
    783. 

  783.                            cbdy_ye, nbdy_ye,                           &
    784. 

  784.                            cbdy_txs, nbdy_txs,                       &
    785. 

  785.                            cbdy_txe, nbdy_txe,                       &
    786. 

  786.                            cbdy_tys, nbdy_tys,                       &
    787. 

  787.                            cbdy_tye, nbdy_tye,                       &
    788. 

  788.                            cdt, ndt                              &
    789. 

  789.                                         )
    790. 

  790. 

  791.      RETURN
    792. 

  792. 

  793.    END SUBROUTINE bdy_interp
    794. 

  794. 

  795.    SUBROUTINE bdy_interp1( cfld,                                 &  ! CD field
    796. 

  796.                            cids, cide, ckds, ckde, cjds, cjde,   &
    797. 

  797.                            cims, cime, ckms, ckme, cjms, cjme,   &
    798. 

  798.                            cits, cite, ckts, ckte, cjts, cjte,   &
    799. 

  799.                            nfld,                                 &  ! ND field
    800. 

  800.                            nijds, nijde, spec_bdy_width ,          &
    801. 

  801.                            nids, nide, nkds, nkde, njds, njde,   &
    802. 

  802.                            nims, nime, nkms, nkme, njms, njme,   &
    803. 

  803.                            nits, nite, nkts, nkte, njts, njte,   &
    804. 

  804.                            shw1,                                 &
    805. 

  805.                            imask,                                &  ! interpolation mask
    806. 

  806.                            xstag, ystag,                         &  ! staggering of field
    807. 

  807.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    808. 

  808.                            nri, nrj,                             &
    809. 

  809.                            cbdy_xs, bdy_xs,                           &
    810. 

  810.                            cbdy_xe, bdy_xe,                           &
    811. 

  811.                            cbdy_ys, bdy_ys,                           &
    812. 

  812.                            cbdy_ye, bdy_ye,                           &
    813. 

  813.                            cbdy_txs, bdy_txs,                       &
    814. 

  814.                            cbdy_txe, bdy_txe,                       &
    815. 

  815.                            cbdy_tys, bdy_tys,                       &
    816. 

  816.                            cbdy_tye, bdy_tye,                       &
    817. 

  817.                            cdt, ndt                              &
    818. 

  818.                                         )
    819. 

  819. 

  820.      USE module_configure
    821. 

  821.      use module_state_description
    822. 

  822.      IMPLICIT NONE
    823. 

  823. 

  824.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    825. 

  825.                             cims, cime, ckms, ckme, cjms, cjme,   &
    826. 

  826.                             cits, cite, ckts, ckte, cjts, cjte,   &
    827. 

  827.                             nids, nide, nkds, nkde, njds, njde,   &
    828. 

  828.                             nims, nime, nkms, nkme, njms, njme,   &
    829. 

  829.                             nits, nite, nkts, nkte, njts, njte,   &
    830. 

  830.                             shw1,                                 &  ! ignore
    831. 

  831.                             ipos, jpos,                           &
    832. 

  832.                             nri, nrj
    833. 

  833.      INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width
    834. 

  834.      LOGICAL, INTENT(IN) :: xstag, ystag
    835. 

  835. 

  836.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
    837. 

  837.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld
    838. 

  838.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    839. 

  839.      REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs   ! not used
    840. 

  840.      REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe   ! not used
    841. 

  841.      REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys   ! not used
    842. 

  842.      REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye   ! not used
    843. 

  843.      REAL                                 :: cdt, ndt
    844. 

  844.      REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs
    845. 

  845.      REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe
    846. 

  846.      REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys
    847. 

  847.      REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye
    848. 

  848. 

  849.      ! Local
    850. 

  850. 

  851.      REAL*8 rdt
    852. 

  852.      INTEGER ci, cj, ck, ni, nj, nk, ni1, nj1, nk1, ip, jp, ioff, joff
    853. 

  853. #ifdef MM5_SINT
    854. 

  854.      INTEGER nfx, ior
    855. 

  855.      PARAMETER (ior=2)
    856. 

  856.      INTEGER nf
    857. 

  857.      REAL psca1(cims:cime,cjms:cjme,nri*nrj)
    858. 

  858.      REAL psca(cims:cime,cjms:cjme,nri*nrj)
    859. 

  859.      LOGICAL icmask( cims:cime, cjms:cjme )
    860. 

  860.      INTEGER i,j,k
    861. 

  861. #endif
    862. 

  862.      INTEGER shw
    863. 

  863.      INTEGER spec_zone 
    864. 

  864.      INTEGER relax_zone
    865. 

  865.      INTEGER sz
    866. 

  866.      INTEGER n2ci,n
    867. 

  867.      INTEGER n2cj
    868. 

  868. 

  869. ! statement functions for converting a nest index to coarse
    870. 

  870.      n2ci(n) = (n+ipos*nri-1)/nri
    871. 

  871.      n2cj(n) = (n+jpos*nrj-1)/nrj
    872. 

  872. 

  873.      rdt = 1.D0/cdt
    874. 

  874. 

  875.      shw = 0
    876. 

  876. 

  877.      ioff  = 0 ; joff  = 0
    878. 

  878.      IF ( xstag ) THEN 
    879. 

  879.        ioff = (nri-1)/2
    880. 

  880.      ENDIF
    881. 

  881.      IF ( ystag ) THEN
    882. 

  882.        joff = (nrj-1)/2
    883. 

  883.      ENDIF
    884. 

  884. 

  885.      ! Iterate over the ND tile and compute the values
    886. 

  886.      ! from the CD tile. 
    887. 

  887. 

  888. #ifdef MM5_SINT
    889. 

  889.      CALL nl_get_spec_zone( 1, spec_zone )
    890. 

  890.      CALL nl_get_relax_zone( 1, relax_zone )
    891. 

  891.      sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width)
    892. 

  892. 

  893.      nfx = nri * nrj
    894. 

  894. 

  895.    !$OMP PARALLEL DO   &
    896. 

  896.    !$OMP PRIVATE ( i,j,k,ni,nj,ni1,nj1,ci,cj,ip,jp,nk,ck,nf,icmask,psca,psca1 )
    897. 

  897.      DO k = ckts, ckte
    898. 

  898. 

  899.         DO nf = 1,nfx
    900. 

  900.            DO j = cjms,cjme
    901. 

  901.               nj = (j-jpos) * nrj + ( nrj / 2 + 1 )  ! j point on nest
    902. 

  902.               DO i = cims,cime
    903. 

  903.                 ni = (i-ipos) * nri + ( nri / 2 + 1 )   ! i point on nest
    904. 

  904.                 psca1(i,j,nf) = cfld(i,k,j)
    905. 

  905.               ENDDO
    906. 

  906.            ENDDO
    907. 

  907.         ENDDO
    908. 

  908. ! hopefully less ham handed but still correct and more efficient
    909. 

  909. ! sintb ignores icmask so it does not matter that icmask is not set
    910. 

  910. !
    911. 

  911. ! SOUTH BDY
    912. 

  912.                IF   ( njts .ge. njds .and. njts .le. njds + sz + joff  ) THEN
    913. 

  913.         CALL sintb( psca1, psca,                     &
    914. 

  914.           cims, cime, cjms, cjme, icmask,  &
    915. 

  915.           n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njds)), n2cj(MIN(njte,njds+sz+joff)), nrj*nri, xstag, ystag )
    916. 

  916.                ENDIF
    917. 

  917. ! NORTH BDY
    918. 

  918.                IF   ( njte .le. njde .and. njte .ge. njde - sz - joff ) THEN
    919. 

  919.         CALL sintb( psca1, psca,                     &
    920. 

  920.           cims, cime, cjms, cjme, icmask,  &
    921. 

  921.           n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njde-sz-joff)), n2cj(MIN(njte,njde-1+joff)), nrj*nri, xstag, ystag )
    922. 

  922.                ENDIF
    923. 

  923. ! WEST BDY
    924. 

  924.                IF   ( nits .ge. nids .and. nits .le. nids + sz + ioff  ) THEN
    925. 

  925.         CALL sintb( psca1, psca,                     &
    926. 

  926.           cims, cime, cjms, cjme, icmask,  &
    927. 

  927.           n2ci(MAX(nits,nids)), n2ci(MIN(nite,nids+sz+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag )
    928. 

  928.                ENDIF
    929. 

  929. ! EAST BDY
    930. 

  930.                IF   ( nite .le. nide .and. nite .ge. nide - sz - ioff ) THEN
    931. 

  931.         CALL sintb( psca1, psca,                     &
    932. 

  932.           cims, cime, cjms, cjme, icmask,  &
    933. 

  933.           n2ci(MAX(nits,nide-sz-ioff)), n2ci(MIN(nite,nide-1+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag )
    934. 

  934.                ENDIF
    935. 

  935. 

  936.         DO nj1 = MAX(njds,njts-1), MIN(njde+joff,njte+joff+1) 
    937. 

  937.            cj = jpos + (nj1-1) / nrj     ! j coord of CD point 
    938. 

  938.            jp = mod ( nj1-1 , nrj )  ! coord of ND w/i CD point
    939. 

  939.            nk = k
    940. 

  940.            ck = nk
    941. 

  941.            DO ni1 = MAX(nids,nits-1), MIN(nide+ioff,nite+ioff+1)
    942. 

  942.                ci = ipos + (ni1-1) / nri      ! j coord of CD point 
    943. 

  943.                ip = mod ( ni1-1 , nri )  ! coord of ND w/i CD point
    944. 

  944. 

  945.                ni = ni1-ioff
    946. 

  946.                nj = nj1-joff
    947. 

  947. 

  948.                IF ( ( ni.LT.nids) .OR. (nj.LT.njds) ) THEN
    949. 

  949.                   CYCLE
    950. 

  950.                END IF
    951. 

  951. 

  952. !bdy contains the value at t-dt. psca contains the value at t
    953. 

  953. !compute dv/dt and store in bdy_t
    954. 

  954. !afterwards store the new value of v at t into bdy
    955. 

  955.         ! WEST
    956. 

  956.                IF   ( ni .ge. nids .and. ni .lt. nids + sz ) THEN
    957. 

  957.                  bdy_txs( nj,k,ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
    958. 

  958.                  bdy_xs( nj,k,ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
    959. 

  959.                ENDIF
    960. 

  960. 

  961.         ! SOUTH
    962. 

  962.                IF   ( nj .ge. njds .and. nj .lt. njds + sz ) THEN
    963. 

  963.                  bdy_tys( ni,k,nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
    964. 

  964.                  bdy_ys( ni,k,nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
    965. 

  965.                ENDIF
    966. 

  966. 

  967.         ! EAST
    968. 

  968.                IF ( xstag ) THEN
    969. 

  969.                  IF   ( ni .ge. nide - sz + 1 .AND. ni .le. nide ) THEN
    970. 

  970.                    bdy_txe( nj,k,nide-ni+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
    971. 

  971.                    bdy_xe( nj,k,nide-ni+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
    972. 

  972.                  ENDIF
    973. 

  973.                ELSE
    974. 

  974.                  IF   ( ni .ge. nide - sz .AND. ni .le. nide-1 ) THEN
    975. 

  975.                    bdy_txe( nj,k,nide-ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
    976. 

  976.                    bdy_xe( nj,k,nide-ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
    977. 

  977.                  ENDIF
    978. 

  978.                ENDIF
    979. 

  979. 

  980.         ! NORTH
    981. 

  981.                IF ( ystag ) THEN
    982. 

  982.                  IF   ( nj .ge. njde - sz + 1 .AND. nj .le. njde  ) THEN
    983. 

  983.                    bdy_tye( ni,k,njde-nj+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
    984. 

  984.                    bdy_ye( ni,k,njde-nj+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
    985. 

  985.                  ENDIF
    986. 

  986.                ELSE
    987. 

  987.                  IF   (  nj .ge. njde - sz .AND. nj .le. njde-1 ) THEN
    988. 

  988.                    bdy_tye(ni,k,njde-nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
    989. 

  989.                    bdy_ye( ni,k,njde-nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
    990. 

  990.                  ENDIF
    991. 

  991.                ENDIF
    992. 

  992. 

  993.            ENDDO
    994. 

  994.         ENDDO
    995. 

  995.      ENDDO
    996. 

  996.    !$OMP END PARALLEL DO
    997. 

  997. #endif
    998. 

  998. 

  999.      RETURN
    1000. 

  1000. 

  1001.    END SUBROUTINE bdy_interp1
    1002. 

  1002. 

  1003. 

  1004. 

  1005.    SUBROUTINE interp_fcni( cfld,                                 &  ! CD field
    1006. 

  1006.                            cids, cide, ckds, ckde, cjds, cjde,   &
    1007. 

  1007.                            cims, cime, ckms, ckme, cjms, cjme,   &
    1008. 

  1008.                            cits, cite, ckts, ckte, cjts, cjte,   &
    1009. 

  1009.                            nfld,                                 &  ! ND field
    1010. 

  1010.                            nids, nide, nkds, nkde, njds, njde,   &
    1011. 

  1011.                            nims, nime, nkms, nkme, njms, njme,   &
    1012. 

  1012.                            nits, nite, nkts, nkte, njts, njte,   &
    1013. 

  1013.                            shw,                                  &  ! stencil half width
    1014. 

  1014.                            imask,                                &  ! interpolation mask
    1015. 

  1015.                            xstag, ystag,                         &  ! staggering of field
    1016. 

  1016.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    1017. 

  1017.                            nri, nrj                             )   ! nest ratios
    1018. 

  1018.      USE module_configure
    1019. 

  1019.      IMPLICIT NONE
    1020. 

  1020. 

  1021. 

  1022.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1023. 

  1023.                             cims, cime, ckms, ckme, cjms, cjme,   &
    1024. 

  1024.                             cits, cite, ckts, ckte, cjts, cjte,   &
    1025. 

  1025.                             nids, nide, nkds, nkde, njds, njde,   &
    1026. 

  1026.                             nims, nime, nkms, nkme, njms, njme,   &
    1027. 

  1027.                             nits, nite, nkts, nkte, njts, njte,   &
    1028. 

  1028.                             shw,                                  &
    1029. 

  1029.                             ipos, jpos,                           &
    1030. 

  1030.                             nri, nrj
    1031. 

  1031.      LOGICAL, INTENT(IN) :: xstag, ystag
    1032. 

  1032. 

  1033.      INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1034. 

  1034.      INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    1035. 

  1035.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    1036. 

  1036. 

  1037.      ! Local
    1038. 

  1038. 

  1039.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp
    1040. 

  1040. 

  1041.      ! Iterate over the ND tile and compute the values
    1042. 

  1042.      ! from the CD tile. 
    1043. 

  1043. 

  1044. !write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
    1045. 

  1045. !write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
    1046. 

  1046. 

  1047.      DO nj = njts, njte
    1048. 

  1048.         cj = jpos + (nj-1) / nrj     ! j coord of CD point 
    1049. 

  1049.         jp = mod ( nj , nrj )  ! coord of ND w/i CD point
    1050. 

  1050.         DO nk = nkts, nkte
    1051. 

  1051.            ck = nk
    1052. 

  1052.            DO ni = nits, nite
    1053. 

  1053.               ci = ipos + (ni-1) / nri      ! j coord of CD point 
    1054. 

  1054.               ip = mod ( ni , nri )  ! coord of ND w/i CD point
    1055. 

  1055.               ! This is a trivial implementation of the interp_fcn; just copies
    1056. 

  1056.               ! the values from the CD into the ND
    1057. 

  1057.               nfld( ni, nk, nj ) = cfld( ci , ck , cj )
    1058. 

  1058.            ENDDO
    1059. 

  1059.         ENDDO
    1060. 

  1060.      ENDDO
    1061. 

  1061. 

  1062.      RETURN
    1063. 

  1063. 

  1064.    END SUBROUTINE interp_fcni
    1065. 

  1065. 

  1066.    SUBROUTINE interp_fcnm( cfld,                                 &  ! CD field
    1067. 

  1067.                            cids, cide, ckds, ckde, cjds, cjde,   &
    1068. 

  1068.                            cims, cime, ckms, ckme, cjms, cjme,   &
    1069. 

  1069.                            cits, cite, ckts, ckte, cjts, cjte,   &
    1070. 

  1070.                            nfld,                                 &  ! ND field
    1071. 

  1071.                            nids, nide, nkds, nkde, njds, njde,   &
    1072. 

  1072.                            nims, nime, nkms, nkme, njms, njme,   &
    1073. 

  1073.                            nits, nite, nkts, nkte, njts, njte,   &
    1074. 

  1074.                            shw,                                  &  ! stencil half width
    1075. 

  1075.                            imask,                                &  ! interpolation mask
    1076. 

  1076.                            xstag, ystag,                         &  ! staggering of field
    1077. 

  1077.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    1078. 

  1078.                            nri, nrj                             )   ! nest ratios
    1079. 

  1079.      USE module_configure
    1080. 

  1080.      IMPLICIT NONE
    1081. 

  1081. 

  1082. 

  1083.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1084. 

  1084.                             cims, cime, ckms, ckme, cjms, cjme,   &
    1085. 

  1085.                             cits, cite, ckts, ckte, cjts, cjte,   &
    1086. 

  1086.                             nids, nide, nkds, nkde, njds, njde,   &
    1087. 

  1087.                             nims, nime, nkms, nkme, njms, njme,   &
    1088. 

  1088.                             nits, nite, nkts, nkte, njts, njte,   &
    1089. 

  1089.                             shw,                                  &
    1090. 

  1090.                             ipos, jpos,                           &
    1091. 

  1091.                             nri, nrj
    1092. 

  1092.      LOGICAL, INTENT(IN) :: xstag, ystag
    1093. 

  1093. 

  1094.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1095. 

  1095.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    1096. 

  1096.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    1097. 

  1097. 

  1098.      ! Local
    1099. 

  1099. 

  1100.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp
    1101. 

  1101. 

  1102.      ! Iterate over the ND tile and compute the values
    1103. 

  1103.      ! from the CD tile. 
    1104. 

  1104. 

  1105. !write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
    1106. 

  1106. !write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
    1107. 

  1107. 

  1108.      DO nj = njts, njte
    1109. 

  1109.         cj = jpos + (nj-1) / nrj     ! j coord of CD point 
    1110. 

  1110.         jp = mod ( nj , nrj )  ! coord of ND w/i CD point
    1111. 

  1111.         DO nk = nkts, nkte
    1112. 

  1112.            ck = nk
    1113. 

  1113.            DO ni = nits, nite
    1114. 

  1114.               ci = ipos + (ni-1) / nri      ! j coord of CD point 
    1115. 

  1115.               ip = mod ( ni , nri )  ! coord of ND w/i CD point
    1116. 

  1116.               ! This is a trivial implementation of the interp_fcn; just copies
    1117. 

  1117.               ! the values from the CD into the ND
    1118. 

  1118.               nfld( ni, nk, nj ) = cfld( ci , ck , cj )
    1119. 

  1119.            ENDDO
    1120. 

  1120.         ENDDO
    1121. 

  1121.      ENDDO
    1122. 

  1122. 

  1123.      RETURN
    1124. 

  1124. 

  1125.    END SUBROUTINE interp_fcnm
    1126. 

  1126. 

  1127.    SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether to allow interpolation or just the bcasts
    1128. 

  1128.                                        cfld,                     &  ! CD field
    1129. 

  1129.                            cids, cide, ckds, ckde, cjds, cjde,   &
    1130. 

  1130.                            cims, cime, ckms, ckme, cjms, cjme,   &
    1131. 

  1131.                            cits, cite, ckts, ckte, cjts, cjte,   &
    1132. 

  1132.                            nfld,                                 &  ! ND field
    1133. 

  1133.                            nids, nide, nkds, nkde, njds, njde,   &
    1134. 

  1134.                            nims, nime, nkms, nkme, njms, njme,   &
    1135. 

  1135.                            nits, nite, nkts, nkte, njts, njte,   &
    1136. 

  1136.                            shw,                                  &  ! stencil half width
    1137. 

  1137.                            imask,                                &  ! interpolation mask
    1138. 

  1138.                            xstag, ystag,                         &  ! staggering of field
    1139. 

  1139.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    1140. 

  1140.                            nri, nrj,                             &  ! nest ratios
    1141. 

  1141.                            clu, nlu                              )
    1142. 

  1142. 

  1143.       USE module_configure
    1144. 

  1144.       USE module_wrf_error
    1145. 

  1145. 

  1146.       IMPLICIT NONE
    1147. 

  1147.    
    1148. 

  1148.    
    1149. 

  1149.       LOGICAL, INTENT(IN) :: enable
    1150. 

  1150.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1151. 

  1151.                              cims, cime, ckms, ckme, cjms, cjme,   &
    1152. 

  1152.                              cits, cite, ckts, ckte, cjts, cjte,   &
    1153. 

  1153.                              nids, nide, nkds, nkde, njds, njde,   &
    1154. 

  1154.                              nims, nime, nkms, nkme, njms, njme,   &
    1155. 

  1155.                              nits, nite, nkts, nkte, njts, njte,   &
    1156. 

  1156.                              shw,                                  &
    1157. 

  1157.                              ipos, jpos,                           &
    1158. 

  1158.                              nri, nrj
    1159. 

  1159.       LOGICAL, INTENT(IN) :: xstag, ystag
    1160. 

  1160.    
    1161. 

  1161.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1162. 

  1162.       REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    1163. 

  1163.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    1164. 

  1164.    
    1165. 

  1165.       REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
    1166. 

  1166.       REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
    1167. 

  1167.    
    1168. 

  1168.       ! Local
    1169. 

  1169.    
    1170. 

  1170.       INTEGER ci, cj, ck, ni, nj, nk, ip, jp
    1171. 

  1171.       INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater
    1172. 

  1172.       REAL :: avg , sum , dx , dy
    1173. 

  1173.       INTEGER , PARAMETER :: max_search = 5
    1174. 

  1174.       CHARACTER*120 message
    1175. 

  1175.    
    1176. 

  1176.       !  Find out what the water value is.
    1177. 

  1177.    
    1178. 

  1178.       CALL nl_get_iswater(1,iswater)
    1179. 

  1179. 

  1180.       !  Right now, only mass point locations permitted.
    1181. 

  1181.    
    1182. 

  1182.       IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
    1183. 

  1183. 

  1184.          !  Loop over each i,k,j in the nested domain.
    1185. 

  1185. 

  1186.        IF ( enable ) THEN
    1187. 

  1187. 

  1188.          DO nj = njts, njte
    1189. 

  1189.             IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1190. 

  1190.                cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1191. 

  1191.             ELSE
    1192. 

  1192.                cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1193. 

  1193.             END IF
    1194. 

  1194.             DO nk = nkts, nkte
    1195. 

  1195.                ck = nk
    1196. 

  1196.                DO ni = nits, nite
    1197. 

  1197.                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1198. 

  1198.                      ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1199. 

  1199.                   ELSE
    1200. 

  1200.                      ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1201. 

  1201.                   END IF
    1202. 

  1202.    
    1203. 

  1203. 

  1204. 

  1205. 

  1206.                   !
    1207. 

  1207.                   !                    (ci,cj+1)     (ci+1,cj+1)
    1208. 

  1208.                   !               -        -------------
    1209. 

  1209.                   !         1-dy  |        |           |
    1210. 

  1210.                   !               |        |           |
    1211. 

  1211.                   !               -        |  *        |
    1212. 

  1212.                   !          dy   |        | (ni,nj)   |
    1213. 

  1213.                   !               |        |           |
    1214. 

  1214.                   !               -        -------------
    1215. 

  1215.                   !                    (ci,cj)       (ci+1,cj)  
    1216. 

  1216.                   !
    1217. 

  1217.                   !                        |--|--------|
    1218. 

  1218.                   !                         dx  1-dx         
    1219. 

  1219. 

  1220. 

  1221.                   !  For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0
    1222. 

  1222. 

  1223.                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1224. 

  1224.                      dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) 
    1225. 

  1225.                   ELSE 
    1226. 

  1226.                      dx =   REAL ( MOD ( ni+(nri-1)/2 , nri ) )         / REAL ( nri ) 
    1227. 

  1227.                   END IF
    1228. 

  1228.                   IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1229. 

  1229.                      dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) 
    1230. 

  1230.                   ELSE 
    1231. 

  1231.                      dy =   REAL ( MOD ( nj+(nrj-1)/2 , nrj ) )         / REAL ( nrj ) 
    1232. 

  1232.                   END IF
    1233. 

  1233.    
    1234. 

  1234.                   !  This is a "land only" field.  If this is a water point, no operations required.
    1235. 

  1235. 

  1236.                   IF      ( ( NINT(nlu(ni  ,nj  )) .EQ. iswater ) ) THEN
    1237. 

  1237.                      nfld(ni,nk,nj) =  cfld(ci  ,ck,cj  )
    1238. 

  1238. 

  1239.                   !  If this is a nested land point, and the surrounding coarse values are all land points,
    1240. 

  1240.                   !  then this is a simple 4-pt interpolation.
    1241. 

  1241. 

  1242.                   ELSE IF ( ( NINT(nlu(ni  ,nj  )) .NE. iswater ) .AND. &
    1243. 

  1243.                             ( NINT(clu(ci  ,cj  )) .NE. iswater ) .AND. &
    1244. 

  1244.                             ( NINT(clu(ci+1,cj  )) .NE. iswater ) .AND. &
    1245. 

  1245.                             ( NINT(clu(ci  ,cj+1)) .NE. iswater ) .AND. &
    1246. 

  1246.                             ( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN
    1247. 

  1247.                      nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci  ,ck,cj  )   + &
    1248. 

  1248.                                                              dy   * cfld(ci  ,ck,cj+1) ) + &
    1249. 

  1249.                                              dx   * ( ( 1. - dy ) * cfld(ci+1,ck,cj  )   + &
    1250. 

  1250.                                                              dy   * cfld(ci+1,ck,cj+1) )
    1251. 

  1251. 

  1252.                   !  If this is a nested land point and there are NO coarse land values surrounding,
    1253. 

  1253.                   !  we temporarily punt.
    1254. 

  1254. 

  1255.                   ELSE IF ( ( NINT(nlu(ni  ,nj  )) .NE. iswater ) .AND. &
    1256. 

  1256.                             ( NINT(clu(ci  ,cj  )) .EQ. iswater ) .AND. &
    1257. 

  1257.                             ( NINT(clu(ci+1,cj  )) .EQ. iswater ) .AND. &
    1258. 

  1258.                             ( NINT(clu(ci  ,cj+1)) .EQ. iswater ) .AND. &
    1259. 

  1259.                             ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN
    1260. 

  1260.                      nfld(ni,nk,nj) = -1
    1261. 

  1261. 

  1262.                   !  If there are some water points and some land points, take an average. 
    1263. 

  1263.                   
    1264. 

  1264.                   ELSE IF ( NINT(nlu(ni  ,nj  )) .NE. iswater ) THEN
    1265. 

  1265.                      icount = 0
    1266. 

  1266.                      sum = 0
    1267. 

  1267.                      IF ( NINT(clu(ci  ,cj  )) .NE. iswater ) THEN
    1268. 

  1268.                         icount = icount + 1
    1269. 

  1269.                         sum = sum + cfld(ci  ,ck,cj  )
    1270. 

  1270.                      END IF
    1271. 

  1271.                      IF ( NINT(clu(ci+1,cj  )) .NE. iswater ) THEN
    1272. 

  1272.                         icount = icount + 1
    1273. 

  1273.                         sum = sum + cfld(ci+1,ck,cj  )
    1274. 

  1274.                      END IF
    1275. 

  1275.                      IF ( NINT(clu(ci  ,cj+1)) .NE. iswater ) THEN
    1276. 

  1276.                         icount = icount + 1
    1277. 

  1277.                         sum = sum + cfld(ci  ,ck,cj+1)
    1278. 

  1278.                      END IF
    1279. 

  1279.                      IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN
    1280. 

  1280.                         icount = icount + 1
    1281. 

  1281.                         sum = sum + cfld(ci+1,ck,cj+1)
    1282. 

  1282.                      END IF
    1283. 

  1283.                      nfld(ni,nk,nj) = sum / REAL ( icount ) 
    1284. 

  1284.                   END IF
    1285. 

  1285.                END DO
    1286. 

  1286.             END DO
    1287. 

  1287.          END DO
    1288. 

  1288. 

  1289. 

  1290.          !  Get an average of the whole domain for problem locations.
    1291. 

  1291. 

  1292.          sum = 0
    1293. 

  1293.          icount = 0 
    1294. 

  1294.          DO nj = njts, njte
    1295. 

  1295.             DO nk = nkts, nkte
    1296. 

  1296.                DO ni = nits, nite
    1297. 

  1297.                   IF ( nfld(ni,nk,nj) .NE. -1 ) THEN
    1298. 

  1298.                      icount = icount + 1
    1299. 

  1299.                      sum = sum + nfld(ni,nk,nj)
    1300. 

  1300.                   END IF
    1301. 

  1301.                END DO
    1302. 

  1302.             END DO
    1303. 

  1303.          END DO
    1304. 

  1304.        ELSE
    1305. 

  1305.          sum = 0.
    1306. 

  1306.          icount = 0
    1307. 

  1307.        ENDIF
    1308. 

  1308.        CALL wrf_dm_bcast_real( sum, 1 )
    1309. 

  1309.        CALL wrf_dm_bcast_integer( icount, 1 )
    1310. 

  1310.        IF ( enable ) THEN
    1311. 

  1311.          IF ( icount .GT. 0 ) THEN
    1312. 

  1312.            avg = sum / REAL ( icount ) 
    1313. 

  1313. 

  1314.          !  OK, if there were any of those island situations, we try to search a bit broader
    1315. 

  1315.          !  of an area in the coarse grid.
    1316. 

  1316. 

  1317.            DO nj = njts, njte
    1318. 

  1318.               DO nk = nkts, nkte
    1319. 

  1319.                  DO ni = nits, nite
    1320. 

  1320.                     IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
    1321. 

  1321.                        IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1322. 

  1322.                           cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1323. 

  1323.                        ELSE
    1324. 

  1324.                           cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1325. 

  1325.                        END IF
    1326. 

  1326.                        IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1327. 

  1327.                           ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1328. 

  1328.                        ELSE
    1329. 

  1329.                           ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1330. 

  1330.                        END IF
    1331. 

  1331.                        ist = MAX (ci-max_search,cits)
    1332. 

  1332.                        ien = MIN (ci+max_search,cite,cide-1)
    1333. 

  1333.                        jst = MAX (cj-max_search,cjts)
    1334. 

  1334.                        jen = MIN (cj+max_search,cjte,cjde-1)
    1335. 

  1335.                        icount = 0 
    1336. 

  1336.                        sum = 0
    1337. 

  1337.                        DO jj = jst,jen
    1338. 

  1338.                           DO ii = ist,ien
    1339. 

  1339.                              IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN
    1340. 

  1340.                                 icount = icount + 1
    1341. 

  1341.                                 sum = sum + cfld(ii,nk,jj)
    1342. 

  1342.                              END IF
    1343. 

  1343.                           END DO
    1344. 

  1344.                        END DO
    1345. 

  1345.                        IF ( icount .GT. 0 ) THEN
    1346. 

  1346.                           nfld(ni,nk,nj) = sum / REAL ( icount ) 
    1347. 

  1347.                        ELSE
    1348. 

  1348. !                         CALL wrf_error_fatal ( "horizontal interp error - island" )
    1349. 

  1349.                           write(message,*) 'horizontal interp error - island, using average ', avg
    1350. 

  1350.                           CALL wrf_message ( message )
    1351. 

  1351.                           nfld(ni,nk,nj) = avg
    1352. 

  1352.                        END IF        
    1353. 

  1353.                     END IF
    1354. 

  1354.                  END DO
    1355. 

  1355.               END DO
    1356. 

  1356.            END DO
    1357. 

  1357.          ENDIF
    1358. 

  1358.        ENDIF
    1359. 

  1359.       ELSE
    1360. 

  1360.          CALL wrf_error_fatal ( "only unstaggered fields right now" )
    1361. 

  1361.       END IF
    1362. 

  1362. 

  1363.    END SUBROUTINE interp_mask_land_field
    1364. 

  1364. 

  1365.    SUBROUTINE interp_mask_water_field ( enable,                  &  ! says whether to allow interpolation or just the bcasts
    1366. 

  1366.                                         cfld,                    &  ! CD field
    1367. 

  1367.                            cids, cide, ckds, ckde, cjds, cjde,   &
    1368. 

  1368.                            cims, cime, ckms, ckme, cjms, cjme,   &
    1369. 

  1369.                            cits, cite, ckts, ckte, cjts, cjte,   &
    1370. 

  1370.                            nfld,                                 &  ! ND field
    1371. 

  1371.                            nids, nide, nkds, nkde, njds, njde,   &
    1372. 

  1372.                            nims, nime, nkms, nkme, njms, njme,   &
    1373. 

  1373.                            nits, nite, nkts, nkte, njts, njte,   &
    1374. 

  1374.                            shw,                                  &  ! stencil half width
    1375. 

  1375.                            imask,                                &  ! interpolation mask
    1376. 

  1376.                            xstag, ystag,                         &  ! staggering of field
    1377. 

  1377.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    1378. 

  1378.                            nri, nrj,                             &  ! nest ratios
    1379. 

  1379.                            clu, nlu, cflag, nflag                )
    1380. 

  1380. 

  1381.       USE module_configure
    1382. 

  1382.       USE module_wrf_error
    1383. 

  1383. 

  1384.       IMPLICIT NONE
    1385. 

  1385.    
    1386. 

  1386.    
    1387. 

  1387.       LOGICAL, INTENT(IN) :: enable
    1388. 

  1388.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1389. 

  1389.                              cims, cime, ckms, ckme, cjms, cjme,   &
    1390. 

  1390.                              cits, cite, ckts, ckte, cjts, cjte,   &
    1391. 

  1391.                              nids, nide, nkds, nkde, njds, njde,   &
    1392. 

  1392.                              nims, nime, nkms, nkme, njms, njme,   &
    1393. 

  1393.                              nits, nite, nkts, nkte, njts, njte,   &
    1394. 

  1394.                              shw,                                  &
    1395. 

  1395.                              ipos, jpos,                           &
    1396. 

  1396.                              nri, nrj, cflag, nflag
    1397. 

  1397.       LOGICAL, INTENT(IN) :: xstag, ystag
    1398. 

  1398.    
    1399. 

  1399.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1400. 

  1400.       REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    1401. 

  1401.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    1402. 

  1402.    
    1403. 

  1403.       REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
    1404. 

  1404.       REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
    1405. 

  1405.    
    1406. 

  1406.       ! Local
    1407. 

  1407.    
    1408. 

  1408.       INTEGER ci, cj, ck, ni, nj, nk, ip, jp
    1409. 

  1409.       INTEGER :: icount , ii , jj , ist , ien , jst , jen
    1410. 

  1410.       REAL :: avg , sum , dx , dy
    1411. 

  1411.       INTEGER , PARAMETER :: max_search = 5
    1412. 

  1412. 

  1413.       !  Right now, only mass point locations permitted.
    1414. 

  1414.    
    1415. 

  1415.       IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
    1416. 

  1416. 

  1417.        IF ( enable ) THEN
    1418. 

  1418.          !  Loop over each i,k,j in the nested domain.
    1419. 

  1419. 

  1420.          DO nj = njts, njte
    1421. 

  1421.             IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1422. 

  1422.                cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1423. 

  1423.             ELSE
    1424. 

  1424.                cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1425. 

  1425.             END IF
    1426. 

  1426.             DO nk = nkts, nkte
    1427. 

  1427.                ck = nk
    1428. 

  1428.                DO ni = nits, nite
    1429. 

  1429.                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1430. 

  1430.                      ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1431. 

  1431.                   ELSE
    1432. 

  1432.                      ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1433. 

  1433.                   END IF
    1434. 

  1434.    
    1435. 

  1435. 

  1436. 

  1437. 

  1438.                   !
    1439. 

  1439.                   !                    (ci,cj+1)     (ci+1,cj+1)
    1440. 

  1440.                   !               -        -------------
    1441. 

  1441.                   !         1-dy  |        |           |
    1442. 

  1442.                   !               |        |           |
    1443. 

  1443.                   !               -        |  *        |
    1444. 

  1444.                   !          dy   |        | (ni,nj)   |
    1445. 

  1445.                   !               |        |           |
    1446. 

  1446.                   !               -        -------------
    1447. 

  1447.                   !                    (ci,cj)       (ci+1,cj)  
    1448. 

  1448.                   !
    1449. 

  1449.                   !                        |--|--------|
    1450. 

  1450.                   !                         dx  1-dx         
    1451. 

  1451. 

  1452. 

  1453.                   !  At ni=2, we are on the coarse grid point, so dx = 0
    1454. 

  1454. 

  1455.                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1456. 

  1456.                      dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) 
    1457. 

  1457.                   ELSE 
    1458. 

  1458.                      dx =   REAL ( MOD ( ni+(nri-1)/2 , nri ) )         / REAL ( nri ) 
    1459. 

  1459.                   END IF
    1460. 

  1460.                   IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1461. 

  1461.                      dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) 
    1462. 

  1462.                   ELSE 
    1463. 

  1463.                      dy =   REAL ( MOD ( nj+(nrj-1)/2 , nrj ) )         / REAL ( nrj ) 
    1464. 

  1464.                   END IF
    1465. 

  1465.    
    1466. 

  1466.                   !  This is a "water only" field.  If this is a land point, no operations required.
    1467. 

  1467. 

  1468.                   IF      ( ( NINT(nlu(ni  ,nj  )) .NE. nflag ) ) THEN
    1469. 

  1469.                      nfld(ni,nk,nj) = cfld(ci  ,ck,cj  )
    1470. 

  1470. 

  1471.                   !  If this is a nested water point, and the surrounding coarse values are all water points,
    1472. 

  1472.                   !  then this is a simple 4-pt interpolation.
    1473. 

  1473. 

  1474.                   ELSE IF ( ( NINT(nlu(ni  ,nj  )) .EQ. nflag ) .AND. &
    1475. 

  1475.                             ( NINT(clu(ci  ,cj  )) .EQ. nflag ) .AND. &
    1476. 

  1476.                             ( NINT(clu(ci+1,cj  )) .EQ. nflag ) .AND. &
    1477. 

  1477.                             ( NINT(clu(ci  ,cj+1)) .EQ. nflag ) .AND. &
    1478. 

  1478.                             ( NINT(clu(ci+1,cj+1)) .EQ. nflag ) ) THEN
    1479. 

  1479.                      nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci  ,ck,cj  )   + &
    1480. 

  1480.                                                              dy   * cfld(ci  ,ck,cj+1) ) + &
    1481. 

  1481.                                              dx   * ( ( 1. - dy ) * cfld(ci+1,ck,cj  )   + &
    1482. 

  1482.                                                              dy   * cfld(ci+1,ck,cj+1) )
    1483. 

  1483. 

  1484.                   !  If this is a nested water point and there are NO coarse water values surrounding,
    1485. 

  1485.                   !  we temporarily punt.
    1486. 

  1486. 

  1487.                   ELSE IF ( ( NINT(nlu(ni  ,nj  )) .EQ. nflag ) .AND. &
    1488. 

  1488.                             ( NINT(clu(ci  ,cj  )) .NE. nflag ) .AND. &
    1489. 

  1489.                             ( NINT(clu(ci+1,cj  )) .NE. nflag ) .AND. &
    1490. 

  1490.                             ( NINT(clu(ci  ,cj+1)) .NE. nflag ) .AND. &
    1491. 

  1491.                             ( NINT(clu(ci+1,cj+1)) .NE. nflag ) ) THEN
    1492. 

  1492.                      nfld(ni,nk,nj) = -1
    1493. 

  1493. 

  1494.                   !  If there are some land points and some water points, take an average. 
    1495. 

  1495.                   
    1496. 

  1496.                   ELSE IF ( NINT(nlu(ni  ,nj  )) .EQ. nflag ) THEN
    1497. 

  1497.                      icount = 0
    1498. 

  1498.                      sum = 0
    1499. 

  1499.                      IF ( NINT(clu(ci  ,cj  )) .EQ. nflag ) THEN
    1500. 

  1500.                         icount = icount + 1
    1501. 

  1501.                         sum = sum + cfld(ci  ,ck,cj  )
    1502. 

  1502.                      END IF
    1503. 

  1503.                      IF ( NINT(clu(ci+1,cj  )) .EQ. nflag ) THEN
    1504. 

  1504.                         icount = icount + 1
    1505. 

  1505.                         sum = sum + cfld(ci+1,ck,cj  )
    1506. 

  1506.                      END IF
    1507. 

  1507.                      IF ( NINT(clu(ci  ,cj+1)) .EQ. nflag ) THEN
    1508. 

  1508.                         icount = icount + 1
    1509. 

  1509.                         sum = sum + cfld(ci  ,ck,cj+1)
    1510. 

  1510.                      END IF
    1511. 

  1511.                      IF ( NINT(clu(ci+1,cj+1)) .EQ. nflag ) THEN
    1512. 

  1512.                         icount = icount + 1
    1513. 

  1513.                         sum = sum + cfld(ci+1,ck,cj+1)
    1514. 

  1514.                      END IF
    1515. 

  1515.                      nfld(ni,nk,nj) = sum / REAL ( icount ) 
    1516. 

  1516.                   END IF
    1517. 

  1517.                END DO
    1518. 

  1518.             END DO
    1519. 

  1519.          END DO
    1520. 

  1520. 

  1521.          !  Get an average of the whole domain for problem locations.
    1522. 

  1522. 

  1523.          sum = 0
    1524. 

  1524.          icount = 0 
    1525. 

  1525.          DO nj = njts, njte
    1526. 

  1526.             DO nk = nkts, nkte
    1527. 

  1527.                DO ni = nits, nite
    1528. 

  1528.                   IF ( nfld(ni,nk,nj) .NE. -1 ) THEN
    1529. 

  1529.                      icount = icount + 1
    1530. 

  1530.                      sum = sum + nfld(ni,nk,nj)
    1531. 

  1531.                   END IF
    1532. 

  1532.                END DO
    1533. 

  1533.             END DO
    1534. 

  1534.          END DO
    1535. 

  1535.        ELSE
    1536. 

  1536.          sum = 0.
    1537. 

  1537.          icount = 0
    1538. 

  1538.        ENDIF
    1539. 

  1539.        CALL wrf_dm_bcast_real( sum, 1 )
    1540. 

  1540.        CALL wrf_dm_bcast_integer( icount, 1 )
    1541. 

  1541.        IF ( enable ) THEN
    1542. 

  1542.          IF ( icount .NE. 0 ) THEN
    1543. 

  1543.            avg = sum / REAL ( icount ) 
    1544. 

  1544. 

  1545. 

  1546.            !  OK, if there were any of those lake situations, we try to search a bit broader
    1547. 

  1547.            !  of an area in the coarse grid.
    1548. 

  1548. 

  1549.            DO nj = njts, njte
    1550. 

  1550.               DO nk = nkts, nkte
    1551. 

  1551.                  DO ni = nits, nite
    1552. 

  1552.                     IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
    1553. 

  1553.                        IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1554. 

  1554.                           cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1555. 

  1555.                        ELSE
    1556. 

  1556.                           cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1557. 

  1557.                        END IF
    1558. 

  1558.                        IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1559. 

  1559.                           ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1560. 

  1560.                        ELSE
    1561. 

  1561.                           ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1562. 

  1562.                        END IF
    1563. 

  1563.                        ist = MAX (ci-max_search,cits)
    1564. 

  1564.                        ien = MIN (ci+max_search,cite,cide-1)
    1565. 

  1565.                        jst = MAX (cj-max_search,cjts)
    1566. 

  1566.                        jen = MIN (cj+max_search,cjte,cjde-1)
    1567. 

  1567.                        icount = 0 
    1568. 

  1568.                        sum = 0
    1569. 

  1569.                        DO jj = jst,jen
    1570. 

  1570.                           DO ii = ist,ien
    1571. 

  1571.                              IF ( NINT(clu(ii,jj)) .EQ. nflag ) THEN
    1572. 

  1572.                                 icount = icount + 1
    1573. 

  1573.                                 sum = sum + cfld(ii,nk,jj)
    1574. 

  1574.                              END IF
    1575. 

  1575.                           END DO
    1576. 

  1576.                        END DO
    1577. 

  1577.                        IF ( icount .GT. 0 ) THEN
    1578. 

  1578.                           nfld(ni,nk,nj) = sum / REAL ( icount ) 
    1579. 

  1579.                        ELSE
    1580. 

  1580.   !                       CALL wrf_error_fatal ( "horizontal interp error - lake" )
    1581. 

  1581.                           print *,'horizontal interp error - lake, using average ',avg
    1582. 

  1582.                           nfld(ni,nk,nj) = avg
    1583. 

  1583.                        END IF        
    1584. 

  1584.                     END IF
    1585. 

  1585.                  END DO
    1586. 

  1586.               END DO
    1587. 

  1587.            END DO
    1588. 

  1588.          ENDIF
    1589. 

  1589.        ENDIF
    1590. 

  1590.       ELSE
    1591. 

  1591.          CALL wrf_error_fatal ( "only unstaggered fields right now" )
    1592. 

  1592.       END IF
    1593. 

  1593. 

  1594.    END SUBROUTINE interp_mask_water_field
    1595. 

  1595. 

  1596.    SUBROUTINE p2c_mask (   cfld,                                 &  ! CD field
    1597. 

  1597.                            cids, cide, ckds, ckde, cjds, cjde,   &
    1598. 

  1598.                            cims, cime, ckms, ckme, cjms, cjme,   &
    1599. 

  1599.                            cits, cite, ckts, ckte, cjts, cjte,   &
    1600. 

  1600.                            nfld,                                 &  ! ND field
    1601. 

  1601.                            nids, nide, nkds, nkde, njds, njde,   &
    1602. 

  1602.                            nims, nime, nkms, nkme, njms, njme,   &
    1603. 

  1603.                            nits, nite, nkts, nkte, njts, njte,   &
    1604. 

  1604.                            shw,                                  &  ! stencil half width
    1605. 

  1605.                            imask,                                &  ! interpolation mask
    1606. 

  1606.                            xstag, ystag,                         &  ! staggering of field
    1607. 

  1607.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    1608. 

  1608.                            nri, nrj,                             &  ! nest ratios
    1609. 

  1609.                            clu, nlu,                             &  ! land use categories
    1610. 

  1610.                            ctslb,ntslb,                          &  ! soil temps
    1611. 

  1611.                            cnum_soil_layers,nnum_soil_layers,    &  ! number of soil layers for tslb
    1612. 

  1612.                            ciswater, niswater                    )  ! iswater category
    1613. 

  1613. 

  1614.       USE module_configure
    1615. 

  1615.       USE module_wrf_error
    1616. 

  1616. 

  1617.       IMPLICIT NONE
    1618. 

  1618.    
    1619. 

  1619.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1620. 

  1620.                              cims, cime, ckms, ckme, cjms, cjme,   &
    1621. 

  1621.                              cits, cite, ckts, ckte, cjts, cjte,   &
    1622. 

  1622.                              nids, nide, nkds, nkde, njds, njde,   &
    1623. 

  1623.                              nims, nime, nkms, nkme, njms, njme,   &
    1624. 

  1624.                              nits, nite, nkts, nkte, njts, njte,   &
    1625. 

  1625.                              shw,                                  &
    1626. 

  1626.                              ipos, jpos,                           &
    1627. 

  1627.                              nri, nrj,                             &
    1628. 

  1628.                              cnum_soil_layers, nnum_soil_layers,   &
    1629. 

  1629.                              ciswater, niswater 
    1630. 

  1630. 

  1631.       LOGICAL, INTENT(IN) :: xstag, ystag
    1632. 

  1632.    
    1633. 

  1633.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1634. 

  1634.       REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    1635. 

  1635.       INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    1636. 

  1636.    
    1637. 

  1637.       REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
    1638. 

  1638.       REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
    1639. 

  1639. 

  1640.       REAL, DIMENSION ( cims:cime, 1:cnum_soil_layers, cjms:cjme ) :: ctslb
    1641. 

  1641.       REAL, DIMENSION ( nims:nime, 1:nnum_soil_layers, njms:njme ) :: ntslb
    1642. 

  1642. 

  1643.       ! Local
    1644. 

  1644.    
    1645. 

  1645.       INTEGER ci, cj, ck, ni, nj, nk
    1646. 

  1646.       INTEGER :: icount 
    1647. 

  1647.       REAL :: sum , dx , dy
    1648. 

  1648. 

  1649.       !  Right now, only mass point locations permitted.
    1650. 

  1650.    
    1651. 

  1651.       IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
    1652. 

  1652. 

  1653.          !  Loop over each i,k,j in the nested domain.
    1654. 

  1654. 

  1655.          DO nj = njts, MIN(njde-1,njte)
    1656. 

  1656.             IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1657. 

  1657.                cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1658. 

  1658.             ELSE
    1659. 

  1659.                cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
    1660. 

  1660.             END IF
    1661. 

  1661.             DO nk = nkts, nkte
    1662. 

  1662.                ck = nk
    1663. 

  1663.                DO ni = nits, MIN(nide-1,nite)
    1664. 

  1664.                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1665. 

  1665.                      ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1666. 

  1666.                   ELSE
    1667. 

  1667.                      ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
    1668. 

  1668.                   END IF
    1669. 

  1669. 

  1670.                   !
    1671. 

  1671.                   !                    (ci,cj+1)     (ci+1,cj+1)
    1672. 

  1672.                   !               -        -------------
    1673. 

  1673.                   !         1-dy  |        |           |
    1674. 

  1674.                   !               |        |           |
    1675. 

  1675.                   !               -        |  *        |
    1676. 

  1676.                   !          dy   |        | (ni,nj)   |
    1677. 

  1677.                   !               |        |           |
    1678. 

  1678.                   !               -        -------------
    1679. 

  1679.                   !                    (ci,cj)       (ci+1,cj)  
    1680. 

  1680.                   !
    1681. 

  1681.                   !                        |--|--------|
    1682. 

  1682.                   !                         dx  1-dx         
    1683. 

  1683. 

  1684. 

  1685.                   !  At ni=2, we are on the coarse grid point, so dx = 0
    1686. 

  1686. 

  1687.                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
    1688. 

  1688.                      dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) 
    1689. 

  1689.                   ELSE 
    1690. 

  1690.                      dx =   REAL ( MOD ( ni+(nri-1)/2 , nri ) )         / REAL ( nri ) 
    1691. 

  1691.                   END IF
    1692. 

  1692.                   IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
    1693. 

  1693.                      dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) 
    1694. 

  1694.                   ELSE 
    1695. 

  1695.                      dy =   REAL ( MOD ( nj+(nrj-1)/2 , nrj ) )         / REAL ( nrj ) 
    1696. 

  1696.                   END IF
    1697. 

  1697.    
    1698. 

  1698.                   !  This is a "water only" field.  If this is a land point, no operations required.
    1699. 

  1699. 

  1700.                   IF      ( ( NINT(nlu(ni  ,nj  )) .NE. niswater ) ) THEN
    1701. 

  1701.                      nfld(ni,nk,nj) = 273.18
    1702. 

  1702. 

  1703.                   !  If this is a nested water point, and the surrounding coarse values are all water points,
    1704. 

  1704.                   !  then this is a simple 4-pt interpolation.
    1705. 

  1705. 

  1706.                   ELSE IF ( ( NINT(nlu(ni  ,nj  )) .EQ. niswater ) .AND. &
    1707. 

  1707.                             ( NINT(clu(ci  ,cj  )) .EQ. niswater ) .AND. &
    1708. 

  1708.                             ( NINT(clu(ci+1,cj  )) .EQ. niswater ) .AND. &
    1709. 

  1709.                             ( NINT(clu(ci  ,cj+1)) .EQ. niswater ) .AND. &
    1710. 

  1710.                             ( NINT(clu(ci+1,cj+1)) .EQ. niswater ) ) THEN
    1711. 

  1711.                      nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci  ,ck,cj  )   + &
    1712. 

  1712.                                                              dy   * cfld(ci  ,ck,cj+1) ) + &
    1713. 

  1713.                                              dx   * ( ( 1. - dy ) * cfld(ci+1,ck,cj  )   + &
    1714. 

  1714.                                                              dy   * cfld(ci+1,ck,cj+1) )
    1715. 

  1715. 

  1716.                   !  If this is a nested water point and there are NO coarse water values surrounding,
    1717. 

  1717.                   !  we manufacture something from the deepest CG soil temp.
    1718. 

  1718. 

  1719.                   ELSE IF ( ( NINT(nlu(ni  ,nj  )) .EQ. niswater ) .AND. &
    1720. 

  1720.                             ( NINT(clu(ci  ,cj  )) .NE. niswater ) .AND. &
    1721. 

  1721.                             ( NINT(clu(ci+1,cj  )) .NE. niswater ) .AND. &
    1722. 

  1722.                             ( NINT(clu(ci  ,cj+1)) .NE. niswater ) .AND. &
    1723. 

  1723.                             ( NINT(clu(ci+1,cj+1)) .NE. niswater ) ) THEN
    1724. 

  1724.                      nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * ctslb(ci  ,cnum_soil_layers,cj  )   + &
    1725. 

  1725.                                                              dy   * ctslb(ci  ,cnum_soil_layers,cj+1) ) + &
    1726. 

  1726.                                              dx   * ( ( 1. - dy ) * ctslb(ci+1,cnum_soil_layers,cj  )   + &
    1727. 

  1727.                                                              dy   * ctslb(ci+1,cnum_soil_layers,cj+1) )
    1728. 

  1728. 

  1729.                   !  If there are some land points and some water points, take an average of the water points.
    1730. 

  1730.                   
    1731. 

  1731.                   ELSE IF ( NINT(nlu(ni  ,nj  )) .EQ. niswater ) THEN
    1732. 

  1732.                      icount = 0
    1733. 

  1733.                      sum = 0
    1734. 

  1734.                      IF ( NINT(clu(ci  ,cj  )) .EQ. niswater ) THEN
    1735. 

  1735.                         icount = icount + 1
    1736. 

  1736.                         sum = sum + cfld(ci  ,ck,cj  )
    1737. 

  1737.                      END IF
    1738. 

  1738.                      IF ( NINT(clu(ci+1,cj  )) .EQ. niswater ) THEN
    1739. 

  1739.                         icount = icount + 1
    1740. 

  1740.                         sum = sum + cfld(ci+1,ck,cj  )
    1741. 

  1741.                      END IF
    1742. 

  1742.                      IF ( NINT(clu(ci  ,cj+1)) .EQ. niswater ) THEN
    1743. 

  1743.                         icount = icount + 1
    1744. 

  1744.                         sum = sum + cfld(ci  ,ck,cj+1)
    1745. 

  1745.                      END IF
    1746. 

  1746.                      IF ( NINT(clu(ci+1,cj+1)) .EQ. niswater ) THEN
    1747. 

  1747.                         icount = icount + 1
    1748. 

  1748.                         sum = sum + cfld(ci+1,ck,cj+1)
    1749. 

  1749.                      END IF
    1750. 

  1750.                      nfld(ni,nk,nj) = sum / REAL ( icount ) 
    1751. 

  1751.                   END IF
    1752. 

  1752.                END DO
    1753. 

  1753.             END DO
    1754. 

  1754.          END DO
    1755. 

  1755. 

  1756.       ELSE
    1757. 

  1757.          CALL wrf_error_fatal ( "only unstaggered fields right now" )
    1758. 

  1758.       END IF
    1759. 

  1759. 

  1760.    END SUBROUTINE p2c_mask
    1761. 

  1761. 

  1762.    SUBROUTINE none
    1763. 

  1763.    END SUBROUTINE none
    1764. 

  1764. 

  1765.    SUBROUTINE smoother ( cfld , &
    1766. 

  1766.                       cids, cide, ckds, ckde, cjds, cjde,   &
    1767. 

  1767.                       cims, cime, ckms, ckme, cjms, cjme,   &
    1768. 

  1768.                       cits, cite, ckts, ckte, cjts, cjte,   &
    1769. 

  1769.                       nids, nide, nkds, nkde, njds, njde,   &
    1770. 

  1770.                       nims, nime, nkms, nkme, njms, njme,   &
    1771. 

  1771.                       nits, nite, nkts, nkte, njts, njte,   &
    1772. 

  1772.                       xstag, ystag,                         &  ! staggering of field
    1773. 

  1773.                       ipos, jpos,                           &  ! Position of lower left of nest in
    1774. 

  1774.                       nri, nrj                              &
    1775. 

  1775.                       )
    1776. 

  1776.  
    1777. 

  1777.       USE module_configure
    1778. 

  1778.       IMPLICIT NONE
    1779. 

  1779.    
    1780. 

  1780.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1781. 

  1781.                              cims, cime, ckms, ckme, cjms, cjme,   &
    1782. 

  1782.                              cits, cite, ckts, ckte, cjts, cjte,   &
    1783. 

  1783.                              nids, nide, nkds, nkde, njds, njde,   &
    1784. 

  1784.                              nims, nime, nkms, nkme, njms, njme,   &
    1785. 

  1785.                              nits, nite, nkts, nkte, njts, njte,   &
    1786. 

  1786.                              nri, nrj,                             &  
    1787. 

  1787.                              ipos, jpos
    1788. 

  1788.       LOGICAL, INTENT(IN) :: xstag, ystag
    1789. 

  1789.       INTEGER             :: smooth_option, feedback , spec_zone
    1790. 

  1790.    
    1791. 

  1791.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1792. 

  1792. 

  1793.       !  If there is no feedback, there can be no smoothing.
    1794. 

  1794. 

  1795.       CALL nl_get_feedback       ( 1, feedback  )
    1796. 

  1796.       IF ( feedback == 0 ) RETURN
    1797. 

  1797.       CALL nl_get_spec_zone ( 1, spec_zone )
    1798. 

  1798. 

  1799.       !  These are the 2d smoothers used on the fedback data.  These filters
    1800. 

  1800.       !  are run on the coarse grid data (after the nested info has been
    1801. 

  1801.       !  fedback).  Only the area of the nest in the coarse grid is filtered.
    1802. 

  1802. 

  1803.       CALL nl_get_smooth_option  ( 1, smooth_option  )
    1804. 

  1804. 

  1805.       IF      ( smooth_option == 0 ) THEN
    1806. 

  1806. ! no op
    1807. 

  1807.       ELSE IF ( smooth_option == 1 ) THEN
    1808. 

  1808.          CALL sm121 ( cfld , &
    1809. 

  1809.                       cids, cide, ckds, ckde, cjds, cjde,   &
    1810. 

  1810.                       cims, cime, ckms, ckme, cjms, cjme,   &
    1811. 

  1811.                       cits, cite, ckts, ckte, cjts, cjte,   &
    1812. 

  1812.                       xstag, ystag,                         &  ! staggering of field
    1813. 

  1813.                       nids, nide, nkds, nkde, njds, njde,   &
    1814. 

  1814.                       nims, nime, nkms, nkme, njms, njme,   &
    1815. 

  1815.                       nits, nite, nkts, nkte, njts, njte,   &
    1816. 

  1816.                       nri, nrj,                             &  
    1817. 

  1817.                       ipos, jpos                            &  ! Position of lower left of nest in 
    1818. 

  1818.                       )
    1819. 

  1819.       ELSE IF ( smooth_option == 2 ) THEN
    1820. 

  1820.          CALL smdsm ( cfld , &
    1821. 

  1821.                       cids, cide, ckds, ckde, cjds, cjde,   &
    1822. 

  1822.                       cims, cime, ckms, ckme, cjms, cjme,   &
    1823. 

  1823.                       cits, cite, ckts, ckte, cjts, cjte,   &
    1824. 

  1824.                       xstag, ystag,                         &  ! staggering of field
    1825. 

  1825.                       nids, nide, nkds, nkde, njds, njde,   &
    1826. 

  1826.                       nims, nime, nkms, nkme, njms, njme,   &
    1827. 

  1827.                       nits, nite, nkts, nkte, njts, njte,   &
    1828. 

  1828.                       nri, nrj,                             &  
    1829. 

  1829.                       ipos, jpos                            &  ! Position of lower left of nest in 
    1830. 

  1830.                       )
    1831. 

  1831.       END IF
    1832. 

  1832. 

  1833.    END SUBROUTINE smoother 
    1834. 

  1834. 

  1835.    SUBROUTINE sm121 ( cfld , &
    1836. 

  1836.                       cids, cide, ckds, ckde, cjds, cjde,   &
    1837. 

  1837.                       cims, cime, ckms, ckme, cjms, cjme,   &
    1838. 

  1838.                       cits, cite, ckts, ckte, cjts, cjte,   &
    1839. 

  1839.                       xstag, ystag,                         &  ! staggering of field
    1840. 

  1840.                       nids, nide, nkds, nkde, njds, njde,   &
    1841. 

  1841.                       nims, nime, nkms, nkme, njms, njme,   &
    1842. 

  1842.                       nits, nite, nkts, nkte, njts, njte,   &
    1843. 

  1843.                       nri, nrj,                             &  
    1844. 

  1844.                       ipos, jpos                            &  ! Position of lower left of nest in 
    1845. 

  1845.                       )
    1846. 

  1846.    
    1847. 

  1847.       USE module_configure
    1848. 

  1848.       IMPLICIT NONE
    1849. 

  1849.    
    1850. 

  1850.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1851. 

  1851.                              cims, cime, ckms, ckme, cjms, cjme,   &
    1852. 

  1852.                              cits, cite, ckts, ckte, cjts, cjte,   &
    1853. 

  1853.                              nids, nide, nkds, nkde, njds, njde,   &
    1854. 

  1854.                              nims, nime, nkms, nkme, njms, njme,   &
    1855. 

  1855.                              nits, nite, nkts, nkte, njts, njte,   &
    1856. 

  1856.                              nri, nrj,                             &  
    1857. 

  1857.                              ipos, jpos
    1858. 

  1858.       LOGICAL, INTENT(IN) :: xstag, ystag
    1859. 

  1859.    
    1860. 

  1860.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1861. 

  1861.       REAL, DIMENSION ( cims:cime,            cjms:cjme ) :: cfldnew
    1862. 

  1862.    
    1863. 

  1863.       INTEGER                        :: i , j , k , loop
    1864. 

  1864.       INTEGER :: istag,jstag
    1865. 

  1865. 

  1866.       INTEGER, PARAMETER  :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt)
    1867. 

  1867. 

  1868.       istag = 1 ; jstag = 1
    1869. 

  1869.       IF ( xstag ) istag = 0
    1870. 

  1870.       IF ( ystag ) jstag = 0
    1871. 

  1871.    
    1872. 

  1872.       !  Simple 1-2-1 smoother.
    1873. 

  1873.    
    1874. 

  1874.       smoothing_passes : DO loop = 1 , smooth_passes
    1875. 

  1875.    
    1876. 

  1876.          DO k = ckts , ckte
    1877. 

  1877.    
    1878. 

  1878.             !  Initialize dummy cfldnew
    1879. 

  1879. 

  1880.             DO i = MAX(ipos,cits-3) , MIN(ipos+(nide-nids)/nri,cite+3)
    1881. 

  1881.                DO j = MAX(jpos,cjts-3) , MIN(jpos+(njde-njds)/nrj,cjte+3)
    1882. 

  1882.                   cfldnew(i,j) = cfld(i,k,j) 
    1883. 

  1883.                END DO
    1884. 

  1884.             END DO
    1885. 

  1885. 

  1886.             !  1-2-1 smoothing in the j direction first, 
    1887. 

  1887.    
    1888. 

  1888.             DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
    1889. 

  1889.             DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
    1890. 

  1890.                   cfldnew(i,j) = 0.25 * ( cfld(i,k,j+1) + 2.*cfld(i,k,j) + cfld(i,k,j-1) )
    1891. 

  1891.                END DO
    1892. 

  1892.             END DO
    1893. 

  1893. 

  1894.             !  then 1-2-1 smoothing in the i direction last
    1895. 

  1895.        
    1896. 

  1896.             DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
    1897. 

  1897.             DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
    1898. 

  1898.                   cfld(i,k,j) =  0.25 * ( cfldnew(i+1,j) + 2.*cfldnew(i,j) + cfldnew(i-1,j) )
    1899. 

  1899.                END DO
    1900. 

  1900.             END DO
    1901. 

  1901.        
    1902. 

  1902.          END DO
    1903. 

  1903.     
    1904. 

  1904.       END DO smoothing_passes
    1905. 

  1905.    
    1906. 

  1906.    END SUBROUTINE sm121
    1907. 

  1907. 

  1908.    SUBROUTINE smdsm ( cfld , &
    1909. 

  1909.                       cids, cide, ckds, ckde, cjds, cjde,   &
    1910. 

  1910.                       cims, cime, ckms, ckme, cjms, cjme,   &
    1911. 

  1911.                       cits, cite, ckts, ckte, cjts, cjte,   &
    1912. 

  1912.                       xstag, ystag,                         &  ! staggering of field
    1913. 

  1913.                       nids, nide, nkds, nkde, njds, njde,   &
    1914. 

  1914.                       nims, nime, nkms, nkme, njms, njme,   &
    1915. 

  1915.                       nits, nite, nkts, nkte, njts, njte,   &
    1916. 

  1916.                       nri, nrj,                             &  
    1917. 

  1917.                       ipos, jpos                            &  ! Position of lower left of nest in 
    1918. 

  1918.                       )
    1919. 

  1919.    
    1920. 

  1920.       USE module_configure
    1921. 

  1921.       IMPLICIT NONE
    1922. 

  1922.    
    1923. 

  1923.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    1924. 

  1924.                              cims, cime, ckms, ckme, cjms, cjme,   &
    1925. 

  1925.                              cits, cite, ckts, ckte, cjts, cjte,   &
    1926. 

  1926.                              nids, nide, nkds, nkde, njds, njde,   &
    1927. 

  1927.                              nims, nime, nkms, nkme, njms, njme,   &
    1928. 

  1928.                              nits, nite, nkts, nkte, njts, njte,   &
    1929. 

  1929.                              nri, nrj,                             &  
    1930. 

  1930.                              ipos, jpos
    1931. 

  1931.       LOGICAL, INTENT(IN) :: xstag, ystag
    1932. 

  1932.    
    1933. 

  1933.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    1934. 

  1934.       REAL, DIMENSION ( cims:cime,            cjms:cjme ) :: cfldnew
    1935. 

  1935.    
    1936. 

  1936.       REAL , DIMENSION ( 2 )         :: xnu
    1937. 

  1937.       INTEGER                        :: i , j , k , loop , n 
    1938. 

  1938.       INTEGER :: istag,jstag
    1939. 

  1939. 

  1940.       INTEGER, PARAMETER  :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt)
    1941. 

  1941. 

  1942.       xnu  =  (/ 0.50 , -0.52 /)
    1943. 

  1943.     
    1944. 

  1944.       istag = 1 ; jstag = 1
    1945. 

  1945.       IF ( xstag ) istag = 0
    1946. 

  1946.       IF ( ystag ) jstag = 0
    1947. 

  1947.    
    1948. 

  1948.       !  The odd number passes of this are the "smoother", the even
    1949. 

  1949.       !  number passes are the "de-smoother" (note the different signs on xnu).
    1950. 

  1950.    
    1951. 

  1951.       smoothing_passes : DO loop = 1 , smooth_passes * 2
    1952. 

  1952.    
    1953. 

  1953.          n  =  2 - MOD ( loop , 2 )
    1954. 

  1954.     
    1955. 

  1955.          DO k = ckts , ckte
    1956. 

  1956.    
    1957. 

  1957.             DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
    1958. 

  1958.                DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
    1959. 

  1959.                   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))
    1960. 

  1960.                END DO
    1961. 

  1961.             END DO
    1962. 

  1962.        
    1963. 

  1963.             DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
    1964. 

  1964.                DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
    1965. 

  1965.                   cfld(i,k,j) = cfldnew(i,j)
    1966. 

  1966.                END DO
    1967. 

  1967.             END DO
    1968. 

  1968.        
    1969. 

  1969.             DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
    1970. 

  1970.                DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
    1971. 

  1971.                   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))
    1972. 

  1972.                END DO
    1973. 

  1973.             END DO
    1974. 

  1974.        
    1975. 

  1975.             DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2)
    1976. 

  1976.                DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2)
    1977. 

  1977.                   cfld(i,k,j) = cfldnew(i,j)
    1978. 

  1978.                END DO
    1979. 

  1979.             END DO
    1980. 

  1980.    
    1981. 

  1981.          END DO
    1982. 

  1982.     
    1983. 

  1983.       END DO smoothing_passes
    1984. 

  1984.    
    1985. 

  1985.    END SUBROUTINE smdsm
    1986. 

  1986. 

  1987. !==================================
    1988. 

  1988. ! this is used to modify a field over the nest so we can see where the nest is
    1989. 

  1989. 

  1990.    SUBROUTINE mark_domain (  cfld,                                 &  ! CD field
    1991. 

  1991.                            cids, cide, ckds, ckde, cjds, cjde,   &
    1992. 

  1992.                            cims, cime, ckms, ckme, cjms, cjme,   &
    1993. 

  1993.                            cits, cite, ckts, ckte, cjts, cjte,   &
    1994. 

  1994.                            nfld,                                 &  ! ND field
    1995. 

  1995.                            nids, nide, nkds, nkde, njds, njde,   &
    1996. 

  1996.                            nims, nime, nkms, nkme, njms, njme,   &
    1997. 

  1997.                            nits, nite, nkts, nkte, njts, njte,   &
    1998. 

  1998.                            shw,                                  &  ! stencil half width for interp
    1999. 

  1999.                            imask,                                &  ! interpolation mask
    2000. 

  2000.                            xstag, ystag,                         &  ! staggering of field
    2001. 

  2001.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    2002. 

  2002.                            nri, nrj                             )   ! nest ratios
    2003. 

  2003.      USE module_configure
    2004. 

  2004.      USE module_wrf_error
    2005. 

  2005.      IMPLICIT NONE
    2006. 

  2006. 

  2007. 

  2008.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    2009. 

  2009.                             cims, cime, ckms, ckme, cjms, cjme,   &
    2010. 

  2010.                             cits, cite, ckts, ckte, cjts, cjte,   &
    2011. 

  2011.                             nids, nide, nkds, nkde, njds, njde,   &
    2012. 

  2012.                             nims, nime, nkms, nkme, njms, njme,   &
    2013. 

  2013.                             nits, nite, nkts, nkte, njts, njte,   &
    2014. 

  2014.                             shw,                                  &
    2015. 

  2015.                             ipos, jpos,                           &
    2016. 

  2016.                             nri, nrj
    2017. 

  2017.      LOGICAL, INTENT(IN) :: xstag, ystag
    2018. 

  2018. 

  2019.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
    2020. 

  2020.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
    2021. 

  2021.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
    2022. 

  2022. 

  2023.      ! Local
    2024. 

  2024. 

  2025.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
    2026. 

  2026.      INTEGER :: icmin,icmax,jcmin,jcmax
    2027. 

  2027.      INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
    2028. 

  2028. 

  2029.      istag = 1 ; jstag = 1
    2030. 

  2030.      IF ( xstag ) istag = 0
    2031. 

  2031.      IF ( ystag ) jstag = 0
    2032. 

  2032. 

  2033.      DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-jstag-1,cjte)
    2034. 

  2034.         nj = (cj-jpos)*nrj + jstag + 1
    2035. 

  2035.         DO ck = ckts, ckte
    2036. 

  2036.            nk = ck
    2037. 

  2037.            DO ci = MAX(ipos+1,cits),MIN(ipos+(nide-nids)/nri-istag-1,cite)
    2038. 

  2038.               ni = (ci-ipos)*nri + istag + 1
    2039. 

  2039.               cfld( ci, ck, cj ) =  9021000.  !magic number: Beverly Hills * 100.
    2040. 

  2040.            ENDDO
    2041. 

  2041.         ENDDO
    2042. 

  2042.      ENDDO
    2043. 

  2043. 

  2044.    END SUBROUTINE mark_domain
    2045. 

  2045. 

  2046. #if ( NMM_CORE == 1 )
    2047. 

  2047. !=======================================================================================
    2048. 

  2048. !  E grid interpolation for mass with addition of terrain adjustments. First routine
    2049. 

  2049. !  pertains to initial conditions and the next one corresponds to boundary conditions 
    2050. 

  2050. !  This is gopal's doing
    2051. 

  2051. !=======================================================================================
    2052. 

  2052. 

  2053.  SUBROUTINE interp_mass_nmm (cfld,                                 &  ! CD field
    2054. 

  2054.                              cids, cide, ckds, ckde, cjds, cjde,   &
    2055. 

  2055.                              cims, cime, ckms, ckme, cjms, cjme,   &
    2056. 

  2056.                              cits, cite, ckts, ckte, cjts, cjte,   &
    2057. 

  2057.                              nfld,                                 &  ! ND field
    2058. 

  2058.                              nids, nide, nkds, nkde, njds, njde,   &
    2059. 

  2059.                              nims, nime, nkms, nkme, njms, njme,   &
    2060. 

  2060.                              nits, nite, nkts, nkte, njts, njte,   &
    2061. 

  2061.                              shw,                                  &  ! stencil half width for interp
    2062. 

  2062.                              imask,                                &  ! interpolation mask
    2063. 

  2063.                              xstag, ystag,                         &  ! staggering of field
    2064. 

  2064.                              ipos, jpos,                           &  ! Position of lower left of nest in CD
    2065. 

  2065.                              nri, nrj,                             &  ! nest ratios                         
    2066. 

  2066.                              CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! south-western grid locs and weights 
    2067. 

  2067.                              CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    2068. 

  2068.                              CBWGT4, HBWGT4,                       &  ! dummys for weights
    2069. 

  2069.                              CZ3d, Z3d,                            &  ! Z3d interpolated from CZ3d
    2070. 

  2070.                              CFIS,FIS,                             &  ! CFIS dummy on fine domain
    2071. 

  2071.                              CSM,SM,                               &  ! CSM is dummy
    2072. 

  2072.                              CPDTOP,PDTOP,                         &
    2073. 

  2073.                              CPTOP,PTOP,                           &
    2074. 

  2074.                              CPSTD,PSTD,                           &
    2075. 

  2075.                              CKZMAX,KZMAX                          )
    2076. 

  2076. 

  2077.    USE MODULE_MODEL_CONSTANTS
    2078. 

  2078.    USE module_timing
    2079. 

  2079.    IMPLICIT NONE
    2080. 

  2080. 

  2081.    LOGICAL,INTENT(IN) :: xstag, ystag
    2082. 

  2082.    INTEGER,INTENT(IN) :: ckzmax,kzmax
    2083. 

  2083.    INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    2084. 

  2084.                          cims, cime, ckms, ckme, cjms, cjme,   &
    2085. 

  2085.                          cits, cite, ckts, ckte, cjts, cjte,   &
    2086. 

  2086.                          nids, nide, nkds, nkde, njds, njde,   &
    2087. 

  2087.                          nims, nime, nkms, nkme, njms, njme,   &
    2088. 

  2088.                          nits, nite, nkts, nkte, njts, njte,   &
    2089. 

  2089.                          shw,ipos,jpos,nri,nrj
    2090. 

  2090. 

  2091.    INTEGER,DIMENSION(nims:nime,njms:njme),          INTENT(IN)           :: IMASK
    2092. 

  2092. 

  2093. !  parent domain
    2094. 

  2094. 

  2095.    INTEGER,DIMENSION(cims:cime,cjms:cjme),          INTENT(IN)           :: CII,CJJ     ! dummy
    2096. 

  2096.    REAL,DIMENSION(cims:cime,cjms:cjme),             INTENT(IN)           :: CBWGT1,CBWGT2,CBWGT3
    2097. 

  2097.    REAL,DIMENSION(cims:cime,cjms:cjme),             INTENT(IN)           :: CBWGT4,CFIS,CSM
    2098. 

  2098.    REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme),   INTENT(IN)           :: CFLD
    2099. 

  2099.    REAL,DIMENSION(cims:cime,cjms:cjme,1:KZMAX),     INTENT(IN)           :: CZ3d
    2100. 

  2100.    REAL,DIMENSION(1:KZMAX),                         INTENT(IN)           :: CPSTD
    2101. 

  2101.    REAL,INTENT(IN)                                                       :: CPDTOP,CPTOP
    2102. 

  2102. 

  2103. !  nested domain
    2104. 

  2104. 

  2105.    INTEGER,DIMENSION(nims:nime,njms:njme),          INTENT(IN)           :: IIH,JJH
    2106. 

  2106.    REAL,DIMENSION(nims:nime,njms:njme),             INTENT(IN)           :: HBWGT1,HBWGT2,HBWGT3
    2107. 

  2107.    REAL,DIMENSION(nims:nime,njms:njme),             INTENT(IN)           :: HBWGT4
    2108. 

  2108.    REAL,DIMENSION(nims:nime,njms:njme),             INTENT(IN)           :: FIS,SM
    2109. 

  2109.    REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme),   INTENT(INOUT)        :: NFLD
    2110. 

  2110.    REAL,DIMENSION(1:KZMAX),                         INTENT(IN)           :: PSTD
    2111. 

  2111.    REAL,DIMENSION(nims:nime,njms:njme,1:KZMAX),     INTENT(OUT)          :: Z3d
    2112. 

  2112.    REAL,INTENT(IN)                                                       :: PDTOP,PTOP
    2113. 

  2113. 

  2114. !  local
    2115. 

  2115. 

  2116.    INTEGER,PARAMETER                                          :: JTB=134
    2117. 

  2117.    REAL, PARAMETER                                            :: LAPSR=6.5E-3,GI=1./G, D608=0.608
    2118. 

  2118.    REAL, PARAMETER                                            :: COEF3=R_D*GI*LAPSR
    2119. 

  2119.    INTEGER                                                    :: I,J,K,IDUM
    2120. 

  2120.    REAL                                                       :: dlnpdz,tvout,pmo
    2121. 

  2121.    REAL,DIMENSION(nims:nime,njms:njme)                        :: ZS,DUM2d
    2122. 

  2122.    REAL,DIMENSION(JTB)                                        :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
    2123. 

  2123. !-----------------------------------------------------------------------------------------------------
    2124. 

  2124. !
    2125. 

  2125. !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
    2126. 

  2126. !
    2127. 

  2127.      DO J=NJTS,MIN(NJTE,NJDE-1)
    2128. 

  2128.      DO I=NITS,MIN(NITE,NIDE-1)
    2129. 

  2129.        IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) &
    2130. 

  2130.            CALL wrf_error_fatal ('mass points:check domain bounds along x' )
    2131. 

  2131.        IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) &
    2132. 

  2132.            CALL wrf_error_fatal ('mass points:check domain bounds along y' )
    2133. 

  2133.      ENDDO
    2134. 

  2134.     ENDDO
    2135. 

  2135. 

  2136.     IF(KZMAX .GT. (JTB-10)) &
    2137. 

  2137.         CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
    2138. 

  2138. 

  2139. !    WRITE(21,*)'------------- MED NEST INITIAL 1 ----------------'
    2140. 

  2140. !    DO J=NJTS,MIN(NJTE,NJDE-1)
    2141. 

  2141. !      DO I=NITS,MIN(NITE,NIDE-1)
    2142. 

  2142. !         WRITE(21,*)I,J,IMASK(I,J),NFLD(I,1,J)
    2143. 

  2143. !      ENDDO
    2144. 

  2144. !    ENDDO
    2145. 

  2145. !    WRITE(21,*)
    2146. 

  2146. 

  2147. !
    2148. 

  2148. !*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ALSO CHECK IF SM IS LAND (SM=0) OVER TOPO
    2149. 

  2149. !*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES! 
    2150. 

  2150. !
    2151. 

  2151. 

  2152.     DO J=NJTS,MIN(NJTE,NJDE-1)
    2153. 

  2153.       DO I=NITS,MIN(NITE,NIDE-1)
    2154. 

  2154.          ZS(I,J)=FIS(I,J)/G
    2155. 

  2155.       ENDDO
    2156. 

  2156.     ENDDO
    2157. 

  2157. 

  2158. !
    2159. 

  2159. !*** Interpolate GPMs DERIVED FROM STANDARD ATMOSPHERIC LAPSE RATE FROM THE PARENT TO
    2160. 

  2160. !*** THE NESTED DOMAIN
    2161. 

  2161. !
    2162. 

  2162. !*** INDEX CONVENTIONS
    2163. 

  2163. !***                     HBWGT4
    2164. 

  2164. !***                      4
    2165. 

  2165. !***
    2166. 

  2166. !***
    2167. 

  2167. !***
    2168. 

  2168. !***                   h
    2169. 

  2169. !***             1                 2
    2170. 

  2170. !***            HBWGT1             HBWGT2
    2171. 

  2171. !***
    2172. 

  2172. !***
    2173. 

  2173. !***                      3
    2174. 

  2174. !***                     HBWGT3
    2175. 

  2175. 

  2176.     Z3d=0.0
    2177. 

  2177.     DO K=NKTS,KZMAX                ! Please note that we are still in isobaric surfaces 
    2178. 

  2178.       DO J=NJTS,MIN(NJTE,NJDE-1)
    2179. 

  2179.         DO I=NITS,MIN(NITE,NIDE-1)
    2180. 

  2180. !
    2181. 

  2181.            IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    2182. 

  2182.                Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2183. 

  2183.                           + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2184. 

  2184.                           + HBWGT3(I,J)*CZ3d(IIH(I,J),  JJH(I,J)-1,K) &
    2185. 

  2185.                           + HBWGT4(I,J)*CZ3d(IIH(I,J),  JJH(I,J)+1,K)
    2186. 

  2186.            ELSE
    2187. 

  2187.                Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2188. 

  2188.                           + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2189. 

  2189.                           + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2190. 

  2190.                           + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2191. 

  2191. 

  2192.            ENDIF
    2193. 

  2193. !
    2194. 

  2194.         ENDDO
    2195. 

  2195.       ENDDO
    2196. 

  2196.     ENDDO
    2197. 

  2197. 

  2198. !  RECONSTRUCT PDs ON THE BASIS OF TOPOGRAPHY AND THE INTERPOLATED HEIGHTS
    2199. 

  2199. 

  2200.     DO J=NJTS,MIN(NJTE,NJDE-1)
    2201. 

  2201.       DO I=NITS,MIN(NITE,NIDE-1)
    2202. 

  2202. !
    2203. 

  2203.           IF (ZS(I,J) .LT. Z3d(I,J,1)) THEN
    2204. 

  2204.             dlnpdz     = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,j,1)-Z3d(i,j,2))
    2205. 

  2205.             dum2d(i,j) = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,j,1)))
    2206. 

  2206.             dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP
    2207. 

  2207.           ELSE                                           ! target level bounded by input levels
    2208. 

  2208.             DO K =NKTS,KZMAX-1                           ! still in the isobaric surfaces
    2209. 

  2209.              IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN
    2210. 

  2210.                dlnpdz     = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1))
    2211. 

  2211.                dum2d(i,j) = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K)))
    2212. 

  2212.                dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP
    2213. 

  2213.              ENDIF
    2214. 

  2214.             ENDDO
    2215. 

  2215.           ENDIF
    2216. 

  2216.           IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
    2217. 

  2217.              WRITE(0,*)'I=',I,'J=',J,'K=',KZMAX,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
    2218. 

  2218.              CALL wrf_error_fatal3 ( "interp_fcn.b" , 176 , "MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
    2219. 

  2219.           ENDIF
    2220. 

  2220. !       
    2221. 

  2221.       ENDDO
    2222. 

  2222.     ENDDO
    2223. 

  2223. 

  2224.     DO K=NKDS,NKDE                       ! NKTE is 1, nevertheless let us pretend religious 
    2225. 

  2225.       DO J=NJTS,MIN(NJTE,NJDE-1)
    2226. 

  2226.        DO I=NITS,MIN(NITE,NIDE-1)
    2227. 

  2227.          IF(IMASK(I,J) .NE. 1)THEN
    2228. 

  2228.            NFLD(I,J,K)= dum2d(i,j)         ! PD defined in the nested domain
    2229. 

  2229.          ENDIF
    2230. 

  2230.        ENDDO
    2231. 

  2231.       ENDDO
    2232. 

  2232.     ENDDO
    2233. 

  2233. 

  2234. !
    2235. 

  2235.   END SUBROUTINE interp_mass_nmm
    2236. 

  2236. !
    2237. 

  2237. !--------------------------------------------------------------------------------------
    2238. 

  2238. 

  2239.  SUBROUTINE nmm_bdymass_hinterp ( cfld,                              &  ! CD field
    2240. 

  2240.                                cids, cide, ckds, ckde, cjds, cjde,   &
    2241. 

  2241.                                cims, cime, ckms, ckme, cjms, cjme,   &
    2242. 

  2242.                                cits, cite, ckts, ckte, cjts, cjte,   &
    2243. 

  2243.                                nfld,                                 &  ! ND field
    2244. 

  2244.                                nids, nide, nkds, nkde, njds, njde,   &
    2245. 

  2245.                                nims, nime, nkms, nkme, njms, njme,   &
    2246. 

  2246.                                nits, nite, nkts, nkte, njts, njte,   &
    2247. 

  2247.                                shw,                                  &  ! stencil half width
    2248. 

  2248.                                imask,                                &  ! interpolation mask
    2249. 

  2249.                                xstag, ystag,                         &  ! staggering of field
    2250. 

  2250.                                ipos, jpos,                           &  ! Position of lower left of nest in CD
    2251. 

  2251.                                nri, nrj,                             &  ! nest ratios
    2252. 

  2252.                                c_bxs,n_bxs,                          &
    2253. 

  2253.                                c_bxe,n_bxe,                          &
    2254. 

  2254.                                c_bys,n_bys,                          &
    2255. 

  2255.                                c_bye,n_bye,                          &
    2256. 

  2256.                                c_btxs,n_btxs,                        &
    2257. 

  2257.                                c_btxe,n_btxe,                        &
    2258. 

  2258.                                c_btys,n_btys,                        &
    2259. 

  2259.                                c_btye,n_btye,                        &
    2260. 

  2260.                                CTEMP_B,NTEMP_B,                      &  ! These temp arrays should be removed
    2261. 

  2261.                                CTEMP_BT,NTEMP_BT,                    &  ! later on
    2262. 

  2262.                                CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! south-western grid locs and weights
    2263. 

  2263.                                CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    2264. 

  2264.                                CBWGT4, HBWGT4,                       &  ! dummys
    2265. 

  2265.                                CZ3d, Z3d,                            &  ! Z3d dummy on nested domain
    2266. 

  2266.                                CFIS,FIS,                             &  ! CFIS dummy on fine domain
    2267. 

  2267.                                CSM,SM,                               &  ! CSM is dummy
    2268. 

  2268.                                CPDTOP,PDTOP,                         &
    2269. 

  2269.                                CPTOP,PTOP,                           &
    2270. 

  2270.                                CPSTD,PSTD,                           &
    2271. 

  2271.                                CKZMAX,KZMAX                          )
    2272. 

  2272. 

  2273. 

  2274.      USE MODULE_MODEL_CONSTANTS
    2275. 

  2275.      USE module_configure
    2276. 

  2276.      USE module_wrf_error
    2277. 

  2277. 

  2278.      IMPLICIT NONE
    2279. 

  2279. 

  2280. 

  2281.      INTEGER, INTENT(IN) :: ckzmax,kzmax
    2282. 

  2282.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    2283. 

  2283.                             cims, cime, ckms, ckme, cjms, cjme,   &
    2284. 

  2284.                             cits, cite, ckts, ckte, cjts, cjte,   &
    2285. 

  2285.                             nids, nide, nkds, nkde, njds, njde,   &
    2286. 

  2286.                             nims, nime, nkms, nkme, njms, njme,   &
    2287. 

  2287.                             nits, nite, nkts, nkte, njts, njte,   &
    2288. 

  2288.                             shw,                                  &
    2289. 

  2289.                             ipos, jpos,                           &
    2290. 

  2290.                             nri, nrj
    2291. 

  2291. 

  2292. 

  2293.    REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: ctemp_b,ctemp_bt
    2294. 

  2294.    REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(OUT) :: ntemp_b,ntemp_bt
    2295. 

  2295.    LOGICAL, INTENT(IN) :: xstag, ystag
    2296. 

  2296.    REAL,  DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye
    2297. 

  2297.    REAL,  DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
    2298. 

  2298. 

  2299. !  parent domain
    2300. 

  2300. 

  2301.    INTEGER,DIMENSION(nims:nime,njms:njme),          INTENT(IN)           :: IMASK
    2302. 

  2302.    INTEGER,DIMENSION(cims:cime,cjms:cjme),          INTENT(IN)           :: CII,CJJ     ! dummy
    2303. 

  2303.    REAL,DIMENSION(cims:cime,cjms:cjme),             INTENT(IN)           :: CBWGT1,CBWGT2,CBWGT3
    2304. 

  2304.    REAL,DIMENSION(cims:cime,cjms:cjme),             INTENT(IN)           :: CBWGT4,CFIS,CSM
    2305. 

  2305.    REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme),   INTENT(IN)           :: CFLD
    2306. 

  2306.    REAL,DIMENSION(cims:cime,cjms:cjme,1:KZMAX),     INTENT(IN)           :: CZ3d
    2307. 

  2307.    REAL,DIMENSION(1:KZMAX),                         INTENT(IN)           :: CPSTD
    2308. 

  2308.    REAL,INTENT(IN)                                                       :: CPDTOP,CPTOP
    2309. 

  2309. 

  2310. !  nested domain
    2311. 

  2311. 

  2312.    INTEGER,DIMENSION(nims:nime,njms:njme),          INTENT(IN)           :: IIH,JJH
    2313. 

  2313.    REAL,DIMENSION(nims:nime,njms:njme),             INTENT(IN)           :: HBWGT1,HBWGT2,HBWGT3
    2314. 

  2314.    REAL,DIMENSION(nims:nime,njms:njme),             INTENT(IN)           :: HBWGT4
    2315. 

  2315.    REAL,DIMENSION(nims:nime,njms:njme),             INTENT(IN)           :: FIS,SM
    2316. 

  2316.    REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme),   INTENT(INOUT)        :: NFLD
    2317. 

  2317.    REAL,DIMENSION(1:KZMAX),                         INTENT(IN)           :: PSTD
    2318. 

  2318.    REAL,DIMENSION(nims:nime,njms:njme,1:KZMAX),     INTENT(OUT)          :: Z3d
    2319. 

  2319.    REAL,INTENT(IN)                                                       :: PDTOP,PTOP
    2320. 

  2320. 

  2321. ! Local
    2322. 

  2322. 

  2323.      INTEGER                                     :: nijds, nijde, spec_bdy_width,i,j,k
    2324. 

  2324.      REAL                                        :: dlnpdz,dum2d
    2325. 

  2325.      REAL,DIMENSION(nims:nime,njms:njme)         :: zs
    2326. 

  2326. 

  2327.   INTEGER,PARAMETER                                                :: JTB=134
    2328. 

  2328.   INTEGER                                                          :: ii,jj
    2329. 

  2329.   REAL, DIMENSION (nims:nime,njms:njme)                            :: CWK1,CWK2,CWK3,CWK4
    2330. 

  2330. 

  2331.      nijds = min(nids, njds)
    2332. 

  2332.      nijde = max(nide, njde)
    2333. 

  2333.      CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
    2334. 

  2334. 

  2335. !
    2336. 

  2336. !*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ASLO CHECK IF SM IS LAND (SM=0) OVER TOPO
    2337. 

  2337. !*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES!
    2338. 

  2338. !
    2339. 

  2339.     DO J=NJTS,MIN(NJTE,NJDE-1)
    2340. 

  2340.       DO I=NITS,MIN(NITE,NIDE-1)
    2341. 

  2341.          ZS(I,J)=FIS(I,J)/G
    2342. 

  2342.       ENDDO
    2343. 

  2343.     ENDDO
    2344. 

  2344. 

  2345. !    X start boundary
    2346. 

  2346. 

  2347.        NMM_XS: IF(NITS .EQ. NIDS)THEN
    2348. 

  2348. !      WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
    2349. 

  2349.         I = NIDS
    2350. 

  2350. 

  2351.         DO K=NKTS,KZMAX
    2352. 

  2352.           DO J = NJTS,MIN(NJTE,NJDE-1)
    2353. 

  2353.             IF(MOD(JJH(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    2354. 

  2354.               Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2355. 

  2355.                          + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2356. 

  2356.                          + HBWGT3(I,J)*CZ3d(IIH(I,J),  JJH(I,J)-1,K) &
    2357. 

  2357.                          + HBWGT4(I,J)*CZ3d(IIH(I,J),  JJH(I,J)+1,K)
    2358. 

  2358.             ELSE
    2359. 

  2359.               Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2360. 

  2360.                          + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2361. 

  2361.                          + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2362. 

  2362.                          + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2363. 

  2363.             ENDIF
    2364. 

  2364.           END DO
    2365. 

  2365.         END DO
    2366. 

  2366. 

  2367.         DO J = NJTS,MIN(NJTE,NJDE-1)
    2368. 

  2368.           IF(MOD(J,2) .NE. 0)THEN
    2369. 

  2369.             IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN              ! level 2 has to be changed
    2370. 

  2370.                dlnpdz     = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2))
    2371. 

  2371.                dum2d      = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1)))
    2372. 

  2372.                CWK1(I,J)  = dum2d -PDTOP -PTOP
    2373. 

  2373.             ELSE ! target level bounded by input levels
    2374. 

  2374.               DO K =NKTS,KZMAX-1
    2375. 

  2375.                IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN
    2376. 

  2376.                  dlnpdz     = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1))
    2377. 

  2377.                  dum2d      = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K)))
    2378. 

  2378.                  CWK1(I,J)  = dum2d -PDTOP -PTOP
    2379. 

  2379.                ENDIF
    2380. 

  2380.               ENDDO
    2381. 

  2381.             ENDIF
    2382. 

  2382.             IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
    2383. 

  2383.                WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
    2384. 

  2384.                CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
    2385. 

  2385.             ENDIF
    2386. 

  2386.           ELSE
    2387. 

  2387.            CWK1(I,J)=0.
    2388. 

  2388.           ENDIF
    2389. 

  2389.         ENDDO
    2390. 

  2390. 

  2391.         DO J = NJTS,MIN(NJTE,NJDE-1)
    2392. 

  2392.          DO K = NKDS,NKDE
    2393. 

  2393.            ntemp_b(i,j,k)     = CWK1(I,J)
    2394. 

  2394.            ntemp_bt(i,j,k)    = 0.0
    2395. 

  2395.          END DO
    2396. 

  2396.         END DO
    2397. 

  2397.        ENDIF NMM_XS
    2398. 

  2398. 

  2399. !    X end boundary
    2400. 

  2400. 

  2401.        NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
    2402. 

  2402. !       WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
    2403. 

  2403.        I = NIDE-1
    2404. 

  2404.        II = NIDE - I
    2405. 

  2405. 

  2406.        DO K=NKTS,KZMAX
    2407. 

  2407.          DO J=NJTS,MIN(NJTE,NJDE-1)
    2408. 

  2408.              IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    2409. 

  2409.                  Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2410. 

  2410.                             + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2411. 

  2411.                             + HBWGT3(I,J)*CZ3d(IIH(I,J),  JJH(I,J)-1,K) &
    2412. 

  2412.                             + HBWGT4(I,J)*CZ3d(IIH(I,J),  JJH(I,J)+1,K)
    2413. 

  2413.              ELSE
    2414. 

  2414.                  Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2415. 

  2415.                             + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2416. 

  2416.                             + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2417. 

  2417.                             + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2418. 

  2418.              ENDIF
    2419. 

  2419.          ENDDO
    2420. 

  2420.        ENDDO
    2421. 

  2421. 

  2422.         DO J = NJTS,MIN(NJTE,NJDE-1)
    2423. 

  2423.           IF(MOD(J,2) .NE.0)THEN                ! 1,3,5,7 of nested domain
    2424. 

  2424.             IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN              ! level 2 has to be changed
    2425. 

  2425.                dlnpdz     = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2))
    2426. 

  2426.                dum2d      = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1)))
    2427. 

  2427.                CWK2(I,J)  = dum2d -PDTOP -PTOP
    2428. 

  2428.             ELSE ! target level bounded by input levels
    2429. 

  2429.               DO K =NKTS,KZMAX-1
    2430. 

  2430.                IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN
    2431. 

  2431.                  dlnpdz     = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1))
    2432. 

  2432.                  dum2d      = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K)))
    2433. 

  2433.                  CWK2(I,J)  = dum2d -PDTOP -PTOP
    2434. 

  2434.                ENDIF
    2435. 

  2435.               ENDDO
    2436. 

  2436.             ENDIF
    2437. 

  2437.             IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
    2438. 

  2438.                WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
    2439. 

  2439.                CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
    2440. 

  2440.             ENDIF
    2441. 

  2441.           ELSE
    2442. 

  2442.               CWK2(I,J) = 0.0
    2443. 

  2443.           ENDIF
    2444. 

  2444.         ENDDO
    2445. 

  2445. 

  2446.         DO J = NJTS,MIN(NJTE,NJDE-1)
    2447. 

  2447.          DO K = NKDS,NKDE
    2448. 

  2448.            ntemp_b(i,j,k)     = CWK2(I,J)
    2449. 

  2449.            ntemp_bt(i,j,k)    = 0.0
    2450. 

  2450.          END DO
    2451. 

  2451.         END DO
    2452. 

  2452.        ENDIF NMM_XE
    2453. 

  2453. 

  2454. !  Y start boundary
    2455. 

  2455. 

  2456.        NMM_YS: IF(NJTS .EQ. NJDS)THEN
    2457. 

  2457. !       WRITE(20,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
    2458. 

  2458.         J = NJDS
    2459. 

  2459.         DO K=NKTS,KZMAX
    2460. 

  2460.          DO I = NITS,MIN(NITE,NIDE-1)
    2461. 

  2461.             IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    2462. 

  2462.                 Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2463. 

  2463.                            + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2464. 

  2464.                            + HBWGT3(I,J)*CZ3d(IIH(I,J),  JJH(I,J)-1,K) &
    2465. 

  2465.                            + HBWGT4(I,J)*CZ3d(IIH(I,J),  JJH(I,J)+1,K)
    2466. 

  2466.             ELSE
    2467. 

  2467.                 Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2468. 

  2468.                            + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2469. 

  2469.                            + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2470. 

  2470.                            + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2471. 

  2471.             ENDIF
    2472. 

  2472.          END DO
    2473. 

  2473.         END DO
    2474. 

  2474. 

  2475.         DO I = NITS,MIN(NITE,NIDE-1)
    2476. 

  2476.           IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN              ! level 2 has to be changed
    2477. 

  2477.                dlnpdz     = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2))
    2478. 

  2478.                dum2d      = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1)))
    2479. 

  2479.                CWK3(I,J)  = dum2d -PDTOP -PTOP
    2480. 

  2480.           ELSE ! target level bounded by input levels
    2481. 

  2481.               DO K =NKTS,KZMAX-1
    2482. 

  2482.                IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN
    2483. 

  2483.                  dlnpdz     = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1))
    2484. 

  2484.                  dum2d      = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K)))
    2485. 

  2485.                  CWK3(I,J)  = dum2d -PDTOP -PTOP
    2486. 

  2486.                ENDIF
    2487. 

  2487.               ENDDO
    2488. 

  2488.           ENDIF
    2489. 

  2489.           IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
    2490. 

  2490.              WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
    2491. 

  2491.              CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
    2492. 

  2492.           ENDIF
    2493. 

  2493.         ENDDO
    2494. 

  2494. 

  2495.         DO K = NKDS, NKDE
    2496. 

  2496.          DO I = NITS,MIN(NITE,NIDE-1)
    2497. 

  2497.            ntemp_b(i,j,k)     = CWK3(I,J)
    2498. 

  2498.            ntemp_bt(i,j,k)    = 0.0
    2499. 

  2499.          END DO
    2500. 

  2500.         END DO
    2501. 

  2501.        END IF NMM_YS
    2502. 

  2502. 

  2503. ! Y end boundary
    2504. 

  2504. 

  2505.        NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
    2506. 

  2506. !        WRITE(20,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
    2507. 

  2507.         J = NJDE-1
    2508. 

  2508.         JJ = NJDE - J
    2509. 

  2509.         DO K=NKTS,KZMAX
    2510. 

  2510.          DO I = NITS,MIN(NITE,NIDE-1)
    2511. 

  2511.              IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    2512. 

  2512.                  Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2513. 

  2513.                             + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2514. 

  2514.                             + HBWGT3(I,J)*CZ3d(IIH(I,J),  JJH(I,J)-1,K) &
    2515. 

  2515.                             + HBWGT4(I,J)*CZ3d(IIH(I,J),  JJH(I,J)+1,K)
    2516. 

  2516.              ELSE
    2517. 

  2517.                  Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J),  JJH(I,J)  ,K) &
    2518. 

  2518.                             + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2519. 

  2519.                             + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2520. 

  2520.                             + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2521. 

  2521.              ENDIF
    2522. 

  2522.          END DO
    2523. 

  2523.         END DO
    2524. 

  2524. 

  2525.         DO I = NITS,MIN(NITE,NIDE-1)
    2526. 

  2526.           IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN              ! level 2 has to be changed
    2527. 

  2527.                dlnpdz     = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2))
    2528. 

  2528.                dum2d      = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1)))
    2529. 

  2529.                CWK4(I,J)  = dum2d -PDTOP -PTOP
    2530. 

  2530.           ELSE ! target level bounded by input levels
    2531. 

  2531.               DO K =NKTS,KZMAX-1
    2532. 

  2532.                IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN
    2533. 

  2533.                  dlnpdz     = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1))
    2534. 

  2534.                  dum2d      = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K)))
    2535. 

  2535.                  CWK4(I,J)  = dum2d -PDTOP -PTOP
    2536. 

  2536.                ENDIF
    2537. 

  2537.               ENDDO
    2538. 

  2538.           ENDIF
    2539. 

  2539.           IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
    2540. 

  2540.              WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
    2541. 

  2541.              CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
    2542. 

  2542.           ENDIF
    2543. 

  2543.         ENDDO
    2544. 

  2544. 

  2545.         DO K = NKDS,NKDE
    2546. 

  2546.          DO I = NITS,MIN(NITE,NIDE-1)
    2547. 

  2547.               ntemp_b(i,j,k)     = CWK4(I,J)
    2548. 

  2548.               ntemp_bt(i,j,k)    = 0.0
    2549. 

  2549.          END DO
    2550. 

  2550.         END DO
    2551. 

  2551.        END IF NMM_YE
    2552. 

  2552. 

  2553.      RETURN
    2554. 

  2554. 

  2555.    END SUBROUTINE nmm_bdymass_hinterp
    2556. 

  2556. !
    2557. 

  2557. !=======================================================================================
    2558. 

  2558. !
    2559. 

  2559. !  ADDED FOR INCLUDING MOISTURE AND THERMODYNAMIC ENERGY BALANCE
    2560. 

  2560. !
    2561. 

  2561. !=======================================================================================
    2562. 

  2562. 

  2563.  SUBROUTINE interp_scalar_nmm (cfld,                               &  ! CD field
    2564. 

  2564.                                cids,cide,ckds,ckde,cjds,cjde,      &
    2565. 

  2565.                                cims,cime,ckms,ckme,cjms,cjme,      &
    2566. 

  2566.                                cits,cite,ckts,ckte,cjts,cjte,      &
    2567. 

  2567.                                nfld,                               &  ! ND field
    2568. 

  2568.                                nids,nide,nkds,nkde,njds,njde,      &
    2569. 

  2569.                                nims,nime,nkms,nkme,njms,njme,      &
    2570. 

  2570.                                nits,nite,nkts,nkte,njts,njte,      &
    2571. 

  2571.                                shw,                                &  ! stencil half width for interp
    2572. 

  2572.                                imask,                              &  ! interpolation mask
    2573. 

  2573.                                xstag,ystag,                        &  ! staggering of field
    2574. 

  2574.                                ipos,jpos,                          &  ! Position of lower left of nest in CD
    2575. 

  2575.                                nri,nrj,                            &  ! nest ratios
    2576. 

  2576.                                CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, &  ! south-western grid locs and weights
    2577. 

  2577.                                CBWGT2, HBWGT2, CBWGT3, HBWGT3,     &  ! note that "C"ourse grid ones are
    2578. 

  2578.                                CBWGT4, HBWGT4,                     &  ! dummys for weights
    2579. 

  2579.                                CC3d,C3d,                           &
    2580. 

  2580.                                CPD,PD,                             &
    2581. 

  2581.                                CPSTD,PSTD,                         &
    2582. 

  2582.                                CPDTOP,PDTOP,                       &
    2583. 

  2583.                                CPTOP,PTOP,                         &
    2584. 

  2584.                                CETA1,ETA1,CETA2,ETA2               )
    2585. 

  2585. 

  2586.    USE MODULE_MODEL_CONSTANTS
    2587. 

  2587.    USE module_timing
    2588. 

  2588.    IMPLICIT NONE
    2589. 

  2589. 

  2590.    LOGICAL,INTENT(IN) :: xstag, ystag
    2591. 

  2591.    INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    2592. 

  2592.                          cims, cime, ckms, ckme, cjms, cjme,   &
    2593. 

  2593.                          cits, cite, ckts, ckte, cjts, cjte,   &
    2594. 

  2594.                          nids, nide, nkds, nkde, njds, njde,   &
    2595. 

  2595.                          nims, nime, nkms, nkme, njms, njme,   &
    2596. 

  2596.                          nits, nite, nkts, nkte, njts, njte,   &
    2597. 

  2597.                          shw,ipos,jpos,nri,nrj
    2598. 

  2598. 

  2599.    INTEGER,DIMENSION(nims:nime,njms:njme),   INTENT(IN)      :: IMASK
    2600. 

  2600. 

  2601. !  parent domain
    2602. 

  2602. 

  2603.    INTEGER,DIMENSION(cims:cime,cjms:cjme),        INTENT(IN) :: CII,CJJ   ! dummy
    2604. 

  2604.    REAL,DIMENSION(cims:cime,cjms:cjme),           INTENT(IN) :: CBWGT1,CBWGT2
    2605. 

  2605.    REAL,DIMENSION(cims:cime,cjms:cjme),           INTENT(IN) :: CBWGT3,CBWGT4
    2606. 

  2606. 

  2607.    REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD
    2608. 

  2608.    REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CC3d  ! scalar input on constant pressure levels
    2609. 

  2609.    REAL,DIMENSION(ckms:ckme),                     INTENT(IN) :: CPSTD
    2610. 

  2610.    REAL,DIMENSION(cims:cime,cjms:cjme),           INTENT(IN) :: CPD
    2611. 

  2611.    REAL,DIMENSION(ckms:ckme),                     INTENT(IN) :: CETA1,CETA2
    2612. 

  2612.    REAL,                                          INTENT(IN) :: CPDTOP,CPTOP
    2613. 

  2613. 

  2614. !  nested domain
    2615. 

  2615. 

  2616.    INTEGER,DIMENSION(nims:nime,njms:njme),        INTENT(IN) :: IIH,JJH
    2617. 

  2617.    REAL,DIMENSION(nims:nime,njms:njme),           INTENT(IN) :: HBWGT1,HBWGT2
    2618. 

  2618.    REAL,DIMENSION(nims:nime,njms:njme),           INTENT(IN) :: HBWGT3,HBWGT4
    2619. 

  2619. 

  2620.    REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: NFLD  ! This is scalar on hybrid levels
    2621. 

  2621.    REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: C3d   ! Scalar on constant pressure levels
    2622. 

  2622.    REAL,DIMENSION(nkms:nkme),                     INTENT(IN) :: PSTD
    2623. 

  2623.    REAL,DIMENSION(nims:nime,njms:njme),           INTENT(IN) :: PD
    2624. 

  2624.    REAL,DIMENSION(nkms:nkme),                     INTENT(IN) :: ETA1,ETA2
    2625. 

  2625.    REAL,INTENT(IN)                                           :: PDTOP,PTOP
    2626. 

  2626. 

  2627. !  local
    2628. 

  2628. 

  2629.    INTEGER,PARAMETER                                         :: JTB=134
    2630. 

  2630.    INTEGER                                                   :: I,J,K
    2631. 

  2631.    REAL,DIMENSION(JTB)                                       :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2
    2632. 

  2632. 

  2633. !-----------------------------------------------------------------------------------------------------
    2634. 

  2634. !
    2635. 

  2635. !
    2636. 

  2636. !   *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE OR LINEAR INTERPOLATION
    2637. 

  2637. !
    2638. 

  2638.     IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) &
    2639. 

  2639.       CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
    2640. 

  2640. 

  2641. !
    2642. 

  2642. !   FIRST, HORIZONTALLY INTERPOLATE MOISTURE NOW AVAILABLE ON CONSTANT PRESSURE SURFACE (LEVELS) FROM THE
    2643. 

  2643. !   PARENT TO THE NESTED DOMAIN
    2644. 

  2644. !
    2645. 

  2645. !*** INDEX CONVENTIONS
    2646. 

  2646. !***                     HBWGT4
    2647. 

  2647. !***                      4
    2648. 

  2648. !***
    2649. 

  2649. !***
    2650. 

  2650. !***
    2651. 

  2651. !***                   h
    2652. 

  2652. !***             1                 2
    2653. 

  2653. !***            HBWGT1             HBWGT2
    2654. 

  2654. !***
    2655. 

  2655. !***
    2656. 

  2656. !***                      3
    2657. 

  2657. !***                     HBWGT3
    2658. 

  2658. 

  2659.     C3d=0.0
    2660. 

  2660.     DO K=NKDS,NKDE-1                ! Please note that we are still in isobaric surfaces
    2661. 

  2661.       DO J=NJTS,MIN(NJTE,NJDE-1)
    2662. 

  2662.         DO I=NITS,MIN(NITE,NIDE-1)
    2663. 

  2663.          IF(IMASK(I,J) .NE. 1)THEN
    2664. 

  2664.            IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    2665. 

  2665.                C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2666. 

  2666.                           + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2667. 

  2667.                           + HBWGT3(I,J)*CC3d(IIH(I,J),  JJH(I,J)-1,K) &
    2668. 

  2668.                           + HBWGT4(I,J)*CC3d(IIH(I,J),  JJH(I,J)+1,K)
    2669. 

  2669. 

  2670.            ELSE
    2671. 

  2671.                C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2672. 

  2672.                           + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2673. 

  2673.                           + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2674. 

  2674.                           + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2675. 

  2675. 

  2676.            ENDIF
    2677. 

  2677.          ENDIF
    2678. 

  2678.         ENDDO
    2679. 

  2679.       ENDDO
    2680. 

  2680.     ENDDO
    2681. 

  2681. 

  2682. !
    2683. 

  2683. !   RECOVER THE SCALARS FROM CONSTANT PRESSURE SURFACES (LEVELS) ON TO HYBRID SURFACES
    2684. 

  2684. !
    2685. 

  2685.     DO J=NJTS,MIN(NJTE,NJDE-1)
    2686. 

  2686.      DO I=NITS,MIN(NITE,NIDE-1)
    2687. 

  2687.       IF(IMASK(I,J) .NE. 1)THEN
    2688. 

  2688. 

  2689. !        clean local array before use of spline or linear interpolation
    2690. 

  2690. 

  2691.          CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0.
    2692. 

  2692. 

  2693.          DO K=NKDS+1,NKDE                    ! inputs at standard  levels
    2694. 

  2694.            PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
    2695. 

  2695.            CIN(K-1) = C3d(I,J,NKDE-K+1)
    2696. 

  2696.          ENDDO
    2697. 

  2697. 

  2698.          Y2(1   )=0.
    2699. 

  2699.          Y2(NKDE-1)=0.
    2700. 

  2700. 

  2701.          DO K=NKDS,NKDE                         ! target points in model interface levels (pint)
    2702. 

  2702.            PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
    2703. 

  2703.          ENDDO
    2704. 

  2704. 

  2705.          DO K=NKDS,NKDE-1                        ! target points in model levels
    2706. 

  2706.            PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
    2707. 

  2707.          ENDDO
    2708. 

  2708. 

  2709.          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
    2710. 

  2710.            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
    2711. 

  2711.            WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
    2712. 

  2712.            WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
    2713. 

  2713.          ENDIF
    2714. 

  2714. 

  2715.          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
    2716. 

  2716. 

  2717.          DO K=1,NKDE-1
    2718. 

  2718.            NFLD(I,J,K)= COUT(K)  ! scalar in the nested domain
    2719. 

  2719.          ENDDO
    2720. 

  2720. 

  2721.       ENDIF
    2722. 

  2722.      ENDDO
    2723. 

  2723.     ENDDO
    2724. 

  2724. 

  2725.  END SUBROUTINE interp_scalar_nmm
    2726. 

  2726. !
    2727. 

  2727. !===========================================================================================
    2728. 

  2728. !
    2729. 

  2729.  SUBROUTINE  nmm_bdy_scalar (cfld,                               &  ! CD field
    2730. 

  2730.                              cids,cide,ckds,ckde,cjds,cjde,      &
    2731. 

  2731.                              cims,cime,ckms,ckme,cjms,cjme,      &
    2732. 

  2732.                              cits,cite,ckts,ckte,cjts,cjte,      &
    2733. 

  2733.                              nfld,                               &  ! ND field
    2734. 

  2734.                              nids,nide,nkds,nkde,njds,njde,      &
    2735. 

  2735.                              nims,nime,nkms,nkme,njms,njme,      &
    2736. 

  2736.                              nits,nite,nkts,nkte,njts,njte,      &
    2737. 

  2737.                              shw,                                &  ! stencil half width for interp
    2738. 

  2738.                              imask,                              &  ! interpolation mask
    2739. 

  2739.                              xstag,ystag,                        &  ! staggering of field
    2740. 

  2740.                              ipos,jpos,                          &  ! Position of lower left of nest in CD
    2741. 

  2741.                              nri,nrj,                            &  ! nest ratios
    2742. 

  2742.                                c_bxs,n_bxs,                          &
    2743. 

  2743.                                c_bxe,n_bxe,                          &
    2744. 

  2744.                                c_bys,n_bys,                          &
    2745. 

  2745.                                c_bye,n_bye,                          &
    2746. 

  2746.                                c_btxs,n_btxs,                        &
    2747. 

  2747.                                c_btxe,n_btxe,                        &
    2748. 

  2748.                                c_btys,n_btys,                        &
    2749. 

  2749.                                c_btye,n_btye,                        &
    2750. 

  2750.                              cdt, ndt,                           &
    2751. 

  2751.                              CTEMP_B,NTEMP_B,                    &  ! to be removed
    2752. 

  2752.                              CTEMP_BT,NTEMP_BT,                  &
    2753. 

  2753.                              CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, &  ! south-western grid locs and weights
    2754. 

  2754.                              CBWGT2, HBWGT2, CBWGT3, HBWGT3,     &  ! note that "C"ourse grid ones are
    2755. 

  2755.                              CBWGT4, HBWGT4,                     &  ! dummys for weights
    2756. 

  2756.                              CC3d,C3d,                           &
    2757. 

  2757.                              CPD,PD,                             &
    2758. 

  2758.                              CPSTD,PSTD,                         &
    2759. 

  2759.                              CPDTOP,PDTOP,                       &
    2760. 

  2760.                              CPTOP,PTOP,                         &
    2761. 

  2761.                              CETA1,ETA1,CETA2,ETA2               )
    2762. 

  2762.    USE MODULE_MODEL_CONSTANTS
    2763. 

  2763.    USE module_timing
    2764. 

  2764.    IMPLICIT NONE
    2765. 

  2765. 

  2766.    LOGICAL,INTENT(IN)                                               :: xstag, ystag
    2767. 

  2767.    REAL, INTENT(INOUT)                                              :: cdt, ndt
    2768. 

  2768.    INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    2769. 

  2769.                          cims, cime, ckms, ckme, cjms, cjme,   &
    2770. 

  2770.                          cits, cite, ckts, ckte, cjts, cjte,   &
    2771. 

  2771.                          nids, nide, nkds, nkde, njds, njde,   &
    2772. 

  2772.                          nims, nime, nkms, nkme, njms, njme,   &
    2773. 

  2773.                          nits, nite, nkts, nkte, njts, njte,   &
    2774. 

  2774.                          shw,ipos,jpos,nri,nrj
    2775. 

  2775.    REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: ctemp_b,ctemp_bt
    2776. 

  2776.    REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(OUT) :: ntemp_b,ntemp_bt
    2777. 

  2777.    REAL,  DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye
    2778. 

  2778.    REAL,  DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
    2779. 

  2779. 

  2780. 

  2781.    INTEGER,DIMENSION(nims:nime,njms:njme),        INTENT(IN) :: IMASK
    2782. 

  2782. 

  2783. !  parent domain
    2784. 

  2784. 

  2785.    INTEGER,DIMENSION(cims:cime,cjms:cjme),        INTENT(IN) :: CII,CJJ   ! dummy
    2786. 

  2786.    REAL,DIMENSION(cims:cime,cjms:cjme),           INTENT(IN) :: CBWGT1,CBWGT2
    2787. 

  2787.    REAL,DIMENSION(cims:cime,cjms:cjme),           INTENT(IN) :: CBWGT3,CBWGT4
    2788. 

  2788.    REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD
    2789. 

  2789.    REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CC3d ! scalar input on constant pressure levels
    2790. 

  2790.    REAL,DIMENSION(ckms:ckme),                     INTENT(IN) :: CPSTD
    2791. 

  2791.    REAL,DIMENSION(cims:cime,cjms:cjme),           INTENT(IN) :: CPD
    2792. 

  2792.    REAL,DIMENSION(ckms:ckme),                     INTENT(IN) :: CETA1,CETA2
    2793. 

  2793.    REAL,                                          INTENT(IN) :: CPDTOP,CPTOP
    2794. 

  2794. 

  2795. !  nested domain
    2796. 

  2796. 

  2797.    INTEGER,DIMENSION(nims:nime,njms:njme),        INTENT(IN) :: IIH,JJH
    2798. 

  2798.    REAL,DIMENSION(nims:nime,njms:njme),           INTENT(IN) :: HBWGT1,HBWGT2
    2799. 

  2799.    REAL,DIMENSION(nims:nime,njms:njme),           INTENT(IN) :: HBWGT3,HBWGT4
    2800. 

  2800.    REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: NFLD 
    2801. 

  2801.    REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: C3d   !Scalar on constant pressure levels
    2802. 

  2802.    REAL,DIMENSION(nkms:nkme),                     INTENT(IN) :: PSTD
    2803. 

  2803.    REAL,DIMENSION(nims:nime,njms:njme),           INTENT(IN) :: PD
    2804. 

  2804.    REAL,DIMENSION(nkms:nkme),                     INTENT(IN) :: ETA1,ETA2
    2805. 

  2805.    REAL,INTENT(IN)                                           :: PDTOP,PTOP
    2806. 

  2806. 

  2807. !  local
    2808. 

  2808. 

  2809.    INTEGER,PARAMETER                                       :: JTB=134
    2810. 

  2810.    INTEGER                                                 :: I,J,K,II,JJ
    2811. 

  2811.    REAL,DIMENSION(JTB)                                     :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2
    2812. 

  2812.    REAL, DIMENSION (nims:nime,njms:njme,nkms:nkme)         :: CWK1,CWK2,CWK3,CWK4
    2813. 

  2813. !-----------------------------------------------------------------------------------------------------
    2814. 

  2814. !
    2815. 

  2815. !
    2816. 

  2816. !   *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION 
    2817. 

  2817. !
    2818. 

  2818.     IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) &
    2819. 

  2819.       CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
    2820. 

  2820. 

  2821. !   X start boundary
    2822. 

  2822. 

  2823.     NMM_XS: IF(NITS .EQ. NIDS)THEN
    2824. 

  2824. !     WRITE(0,*)'ENTERING X1 START BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1)
    2825. 

  2825.       I = NIDS
    2826. 

  2826.       DO K=NKDS,NKDE-1                ! Please note that we are still in isobaric surfaces
    2827. 

  2827.         DO J = NJTS,MIN(NJTE,NJDE-1)
    2828. 

  2828.           IF(MOD(JJH(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    2829. 

  2829.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2830. 

  2830.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2831. 

  2831.                        + HBWGT3(I,J)*CC3d(IIH(I,J),  JJH(I,J)-1,K) &
    2832. 

  2832.                        + HBWGT4(I,J)*CC3d(IIH(I,J),  JJH(I,J)+1,K)
    2833. 

  2833.           ELSE
    2834. 

  2834.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2835. 

  2835.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2836. 

  2836.                        + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2837. 

  2837.                        + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2838. 

  2838.           ENDIF
    2839. 

  2839.         ENDDO
    2840. 

  2840.       ENDDO
    2841. 

  2841. !
    2842. 

  2842.       DO J=NJTS,MIN(NJTE,NJDE-1)
    2843. 

  2843.        IF(MOD(J,2) .NE. 0)THEN
    2844. 

  2844.          CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
    2845. 

  2845.          DO K=NKDS+1,NKDE                    ! inputs at standard  levels
    2846. 

  2846.            PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
    2847. 

  2847.            CIN(K-1) = C3d(I,J,NKDE-K+1)
    2848. 

  2848.          ENDDO
    2849. 

  2849.          Y2(1   )=0.
    2850. 

  2850.          Y2(NKDE-1)=0.
    2851. 

  2851.          DO K=NKDS,NKDE                         ! target points in model interface levels (pint)
    2852. 

  2852.            PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
    2853. 

  2853.          ENDDO
    2854. 

  2854.          DO K=NKDS,NKDE-1                        ! target points in model levels
    2855. 

  2855.            PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
    2856. 

  2856.          ENDDO
    2857. 

  2857.          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
    2858. 

  2858.            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
    2859. 

  2859.            WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
    2860. 

  2860.            WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
    2861. 

  2861.          ENDIF
    2862. 

  2862. 

  2863.          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
    2864. 

  2864. 

  2865.          DO K=1,NKDE-1
    2866. 

  2866.            CWK1(I,J,K)= COUT(K)  ! scalar in the nested domain
    2867. 

  2867.          ENDDO
    2868. 

  2868.        ELSE
    2869. 

  2869.          DO K=NKDS,NKDE-1
    2870. 

  2870.           CWK1(I,J,K)=0.0
    2871. 

  2871.          ENDDO
    2872. 

  2872.        ENDIF
    2873. 

  2873.       ENDDO
    2874. 

  2874. 

  2875.       DO J = NJTS,MIN(NJTE,NJDE-1)
    2876. 

  2876.        DO K = NKDS,NKDE-1
    2877. 

  2877.          ntemp_b(i,j,k)     = CWK1(I,J,K)
    2878. 

  2878.          ntemp_bt(i,j,k)    = 0.0
    2879. 

  2879.        END DO
    2880. 

  2880.       END DO
    2881. 

  2881. 

  2882.     ENDIF NMM_XS
    2883. 

  2883. 

  2884. 

  2885. !   X end boundary
    2886. 

  2886. 

  2887.     NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
    2888. 

  2888. !    WRITE(0,*)'ENTERING X END BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1)
    2889. 

  2889.      I = NIDE-1
    2890. 

  2890.       DO K=NKDS,NKDE-1                ! Please note that we are still in isobaric surfaces
    2891. 

  2891.         DO J = NJTS,MIN(NJTE,NJDE-1)
    2892. 

  2892.           IF(MOD(JJH(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    2893. 

  2893.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2894. 

  2894.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2895. 

  2895.                        + HBWGT3(I,J)*CC3d(IIH(I,J),  JJH(I,J)-1,K) &
    2896. 

  2896.                        + HBWGT4(I,J)*CC3d(IIH(I,J),  JJH(I,J)+1,K)
    2897. 

  2897.           ELSE
    2898. 

  2898.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2899. 

  2899.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2900. 

  2900.                        + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2901. 

  2901.                        + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2902. 

  2902.           ENDIF
    2903. 

  2903.         ENDDO
    2904. 

  2904.       ENDDO
    2905. 

  2905. 

  2906.      DO J=NJTS,MIN(NJTE,NJDE-1)
    2907. 

  2907.       IF(MOD(J,2) .NE. 0)THEN
    2908. 

  2908.          CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
    2909. 

  2909.          DO K=NKDS+1,NKDE                    ! inputs at standard  levels
    2910. 

  2910.            PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
    2911. 

  2911.            CIN(K-1) = C3d(I,J,NKDE-K+1)
    2912. 

  2912.          ENDDO
    2913. 

  2913.          Y2(1   )=0.
    2914. 

  2914.          Y2(NKDE-1)=0.
    2915. 

  2915.          DO K=NKDS,NKDE                         ! target points in model interface levels (pint)
    2916. 

  2916.            PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
    2917. 

  2917.          ENDDO
    2918. 

  2918.          DO K=NKDS,NKDE-1                        ! target points in model levels
    2919. 

  2919.            PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
    2920. 

  2920.          ENDDO
    2921. 

  2921.          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
    2922. 

  2922.            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
    2923. 

  2923.            WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
    2924. 

  2924.            WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
    2925. 

  2925.          ENDIF
    2926. 

  2926. 

  2927.          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
    2928. 

  2928. 

  2929.          DO K=1,NKDE-1
    2930. 

  2930.            CWK2(I,J,K)= COUT(K)  ! scalar in the nested domain
    2931. 

  2931.          ENDDO
    2932. 

  2932.       ELSE
    2933. 

  2933.          DO K=NKDS,NKDE-1
    2934. 

  2934.            CWK2(I,J,K)=0.0
    2935. 

  2935.          ENDDO
    2936. 

  2936.       ENDIF
    2937. 

  2937.      ENDDO
    2938. 

  2938. 

  2939.        DO J = NJTS,MIN(NJTE,NJDE-1)
    2940. 

  2940.         DO K = NKDS,MIN(NKTE,NKDE-1)
    2941. 

  2941.           ntemp_b(i,j,k)     = CWK2(I,J,K)
    2942. 

  2942.           ntemp_bt(i,j,k)    = 0.0
    2943. 

  2943.         END DO
    2944. 

  2944.        END DO
    2945. 

  2945. 

  2946.     ENDIF NMM_XE
    2947. 

  2947. 

  2948. !  Y start boundary
    2949. 

  2949. 

  2950.     NMM_YS: IF(NJTS .EQ. NJDS)THEN
    2951. 

  2951. !    WRITE(0,*)'ENTERING Y START BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1)
    2952. 

  2952.      J = NJDS
    2953. 

  2953.       DO K=NKDS,NKDE-1
    2954. 

  2954.        DO I = NITS,MIN(NITE,NIDE-1)
    2955. 

  2955.           IF(MOD(JJH(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    2956. 

  2956.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2957. 

  2957.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2958. 

  2958.                        + HBWGT3(I,J)*CC3d(IIH(I,J),  JJH(I,J)-1,K) &
    2959. 

  2959.                        + HBWGT4(I,J)*CC3d(IIH(I,J),  JJH(I,J)+1,K)
    2960. 

  2960.           ELSE
    2961. 

  2961.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    2962. 

  2962.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    2963. 

  2963.                        + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    2964. 

  2964.                        + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K)
    2965. 

  2965. 

  2966.           ENDIF
    2967. 

  2967.         ENDDO
    2968. 

  2968.       ENDDO
    2969. 

  2969. !
    2970. 

  2970.      DO I=NITS,MIN(NITE,NIDE-1)
    2971. 

  2971.          CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
    2972. 

  2972.          DO K=NKDS+1,NKDE                    ! inputs at standard  levels
    2973. 

  2973.            PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
    2974. 

  2974.            CIN(K-1) = C3d(I,J,NKDE-K+1)
    2975. 

  2975.          ENDDO
    2976. 

  2976.          Y2(1   )=0.
    2977. 

  2977.          Y2(NKDE-1)=0.
    2978. 

  2978.          DO K=NKDS,NKDE                         ! target points in model interface levels (pint)
    2979. 

  2979.            PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
    2980. 

  2980.          ENDDO
    2981. 

  2981.          DO K=NKDS,NKDE-1                        ! target points in model levels
    2982. 

  2982.            PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
    2983. 

  2983.          ENDDO
    2984. 

  2984.          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
    2985. 

  2985.            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
    2986. 

  2986.            WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
    2987. 

  2987.            WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
    2988. 

  2988.          ENDIF
    2989. 

  2989. 

  2990.          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
    2991. 

  2991. 

  2992.          DO K=1,NKDE-1
    2993. 

  2993.            CWK3(I,J,K)= COUT(K)  ! scalar in the nested domain
    2994. 

  2994.          ENDDO
    2995. 

  2995.      ENDDO
    2996. 

  2996. 

  2997.      DO K = NKDS,NKDE-1
    2998. 

  2998.       DO I = NITS,MIN(NITE,NIDE-1)
    2999. 

  2999.         ntemp_b(i,J,K)     = CWK3(I,J,K)
    3000. 

  3000.         ntemp_bt(i,J,K)    = 0.0
    3001. 

  3001.       ENDDO
    3002. 

  3002.       ENDDO
    3003. 

  3003. 

  3004.     ENDIF NMM_YS
    3005. 

  3005. 

  3006. ! Y end boundary
    3007. 

  3007. 

  3008.     NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
    3009. 

  3009. !    WRITE(0,*)'ENTERING Y END BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1)
    3010. 

  3010.      J = NJDE-1
    3011. 

  3011.       DO K=NKDS,NKDE-1
    3012. 

  3012.         DO I = NITS,MIN(NITE,NIDE-1)
    3013. 

  3013.           IF(MOD(JJH(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    3014. 

  3014.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    3015. 

  3015.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    3016. 

  3016.                        + HBWGT3(I,J)*CC3d(IIH(I,J),  JJH(I,J)-1,K) &
    3017. 

  3017.                        + HBWGT4(I,J)*CC3d(IIH(I,J),  JJH(I,J)+1,K)
    3018. 

  3018.           ELSE
    3019. 

  3019.             C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J),  JJH(I,J)  ,K) &
    3020. 

  3020.                        + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)  ,K) &
    3021. 

  3021.                        + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) &
    3022. 

  3022.                        + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K)
    3023. 

  3023. 

  3024.           ENDIF
    3025. 

  3025.         ENDDO
    3026. 

  3026.       ENDDO
    3027. 

  3027. 

  3028.      DO I=NITS,MIN(NITE,NIDE-1)
    3029. 

  3029.          CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
    3030. 

  3030.          DO K=NKDS+1,NKDE                    ! inputs at standard  levels
    3031. 

  3031.            PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
    3032. 

  3032.            CIN(K-1) = C3d(I,J,NKDE-K+1)
    3033. 

  3033.          ENDDO
    3034. 

  3034.          Y2(1   )=0.
    3035. 

  3035.          Y2(NKDE-1)=0.
    3036. 

  3036.          DO K=NKDS,NKDE                         ! target points in model interface levels (pint)
    3037. 

  3037.            PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
    3038. 

  3038.          ENDDO
    3039. 

  3039.          DO K=NKDS,NKDE-1                        ! target points in model levels
    3040. 

  3040.            PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
    3041. 

  3041.          ENDDO
    3042. 

  3042.          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
    3043. 

  3043.            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
    3044. 

  3044.            WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
    3045. 

  3045.            WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
    3046. 

  3046.          ENDIF
    3047. 

  3047. 

  3048.          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
    3049. 

  3049. 

  3050.          DO K=1,NKDE-1
    3051. 

  3051.            CWK4(I,J,K)= COUT(K)  ! scalar in the nested domain
    3052. 

  3052.          ENDDO
    3053. 

  3053.      ENDDO
    3054. 

  3054. 

  3055.      DO K = NKDS,NKDE-1
    3056. 

  3056.       DO I = NITS,MIN(NITE,NIDE-1)
    3057. 

  3057.         ntemp_b(i,J,K)     = CWK4(I,J,K)
    3058. 

  3058.         ntemp_bt(i,J,K)    = 0.0
    3059. 

  3059.       END DO
    3060. 

  3060.       END DO
    3061. 

  3061. 

  3062.     ENDIF NMM_YE
    3063. 

  3063. 

  3064.   END SUBROUTINE nmm_bdy_scalar
    3065. 

  3065. !
    3066. 

  3066. !
    3067. 

  3067. !=======================================================================================
    3068. 

  3068.  SUBROUTINE SPLINE2(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q)
    3069. 

  3069. !
    3070. 

  3070. !   ******************************************************************
    3071. 

  3071. !   *                                                                *
    3072. 

  3072. !   *  THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE        *
    3073. 

  3073. !   *  PROGRAMED FOR A SMALL SCALAR MACHINE.                         *
    3074. 

  3074. !   *                                                                *
    3075. 

  3075. !   *  PROGRAMER Z. JANJIC                                           *
    3076. 

  3076. !   *                                                                *
    3077. 

  3077. !   *  NOLD - NUMBER OF GIVEN VALUES OF THE FUNCTION.  MUST BE GE 3. *
    3078. 

  3078. !   *  XOLD - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE     *
    3079. 

  3079. !   *         FUNCTION ARE GIVEN.  MUST BE IN ASCENDING ORDER.       *
    3080. 

  3080. !   *  YOLD - THE GIVEN VALUES OF THE FUNCTION AT THE POINTS XOLD.   *
    3081. 

  3081. !   *  Y2   - THE SECOND DERIVATIVES AT THE POINTS XOLD.  IF NATURAL *
    3082. 

  3082. !   *         SPLINE IS FITTED Y2(1)=0. AND Y2(NOLD)=0. MUST BE      *
    3083. 

  3083. !   *         SPECIFIED.                                             *
    3084. 

  3084. !   *  NNEW - NUMBER OF VALUES OF THE FUNCTION TO BE CALCULATED.     *
    3085. 

  3085. !   *  XNEW - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE     *
    3086. 

  3086. !   *         FUNCTION ARE CALCULATED.  XNEW(K) MUST BE GE XOLD(1)   *
    3087. 

  3087. !   *         AND LE XOLD(NOLD).                                     *
    3088. 

  3088. !   *  YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED.           *
    3089. 

  3089. !   *  P, Q - AUXILIARY VECTORS OF THE LENGTH NOLD-2.                *
    3090. 

  3090. !   *                                                                *
    3091. 

  3091. !   ******************************************************************
    3092. 

  3092. !---------------------------------------------------------------------
    3093. 

  3093.       IMPLICIT NONE
    3094. 

  3094. !---------------------------------------------------------------------
    3095. 

  3095.       INTEGER,INTENT(IN) :: I,J,JTBX,NNEW,NOLD
    3096. 

  3096.       REAL,DIMENSION(JTBX),INTENT(IN) :: XNEW,XOLD,YOLD
    3097. 

  3097.       REAL,DIMENSION(JTBX),INTENT(INOUT) :: P,Q,Y2
    3098. 

  3098.       REAL,DIMENSION(JTBX),INTENT(OUT) :: YNEW
    3099. 

  3099. !
    3100. 

  3100.       INTEGER :: II,JJ,K,K1,K2,KOLD,NOLDM1
    3101. 

  3101.       REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR                 &
    3102. 

  3102.              ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
    3103. 

  3103. !---------------------------------------------------------------------
    3104. 

  3104. 

  3105. !     debug
    3106. 

  3106. 

  3107.       II=9999
    3108. 

  3108.       JJ=9999
    3109. 

  3109.       IF(I.eq.II.and.J.eq.JJ)THEN
    3110. 

  3110.         WRITE(0,*)'DEBUG in SPLINE2: I,J',I,J
    3111. 

  3111.         WRITE(0,*)'DEBUG in SPLINE2:HSO= ',xnew(1:nold)
    3112. 

  3112.         DO K=1,NOLD
    3113. 

  3113.          WRITE(0,*)'DEBUG in SPLINE2:L,ZETAI,PINTI= ' &
    3114. 

  3114.                         ,K,YOLD(K),XOLD(K)
    3115. 

  3115.         ENDDO
    3116. 

  3116.       ENDIF
    3117. 

  3117. !
    3118. 

  3118.       NOLDM1=NOLD-1
    3119. 

  3119. !
    3120. 

  3120.       DXL=XOLD(2)-XOLD(1)
    3121. 

  3121.       DXR=XOLD(3)-XOLD(2)
    3122. 

  3122.       DYDXL=(YOLD(2)-YOLD(1))/DXL
    3123. 

  3123.       DYDXR=(YOLD(3)-YOLD(2))/DXR
    3124. 

  3124.       RTDXC=0.5/(DXL+DXR)
    3125. 

  3125. !
    3126. 

  3126.       P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1))
    3127. 

  3127.       Q(1)=-RTDXC*DXR
    3128. 

  3128. !
    3129. 

  3129.       IF(NOLD.EQ.3)GO TO 150
    3130. 

  3130. !---------------------------------------------------------------------
    3131. 

  3131.       K=3
    3132. 

  3132. !
    3133. 

  3133.   100 DXL=DXR
    3134. 

  3134.       DYDXL=DYDXR
    3135. 

  3135.       DXR=XOLD(K+1)-XOLD(K)
    3136. 

  3136.       DYDXR=(YOLD(K+1)-YOLD(K))/DXR
    3137. 

  3137.       DXC=DXL+DXR
    3138. 

  3138.       DEN=1./(DXL*Q(K-2)+DXC+DXC)
    3139. 

  3139. !
    3140. 

  3140.       P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2))
    3141. 

  3141.       Q(K-1)=-DEN*DXR
    3142. 

  3142. !
    3143. 

  3143.       K=K+1
    3144. 

  3144.       IF(K.LT.NOLD)GO TO 100
    3145. 

  3145. !-----------------------------------------------------------------------
    3146. 

  3146.   150 K=NOLDM1
    3147. 

  3147. !
    3148. 

  3148.   200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1)
    3149. 

  3149. !
    3150. 

  3150.       K=K-1
    3151. 

  3151.       IF(K.GT.1)GO TO 200
    3152. 

  3152. !-----------------------------------------------------------------------
    3153. 

  3153.       K1=1
    3154. 

  3154. !
    3155. 

  3155.   300 XK=XNEW(K1)
    3156. 

  3156. !
    3157. 

  3157.       DO 400 K2=2,NOLD
    3158. 

  3158. !
    3159. 

  3159.       IF(XOLD(K2).GT.XK)THEN
    3160. 

  3160.         KOLD=K2-1
    3161. 

  3161.         GO TO 450
    3162. 

  3162.       ENDIF
    3163. 

  3163. !
    3164. 

  3164.   400 CONTINUE
    3165. 

  3165. !
    3166. 

  3166.       YNEW(K1)=YOLD(NOLD)
    3167. 

  3167.       GO TO 600
    3168. 

  3168. !
    3169. 

  3169.   450 IF(K1.EQ.1)GO TO 500
    3170. 

  3170.       IF(K.EQ.KOLD)GO TO 550
    3171. 

  3171. !
    3172. 

  3172.   500 K=KOLD
    3173. 

  3173. !
    3174. 

  3174.       Y2K=Y2(K)
    3175. 

  3175.       Y2KP1=Y2(K+1)
    3176. 

  3176.       DX=XOLD(K+1)-XOLD(K)
    3177. 

  3177.       RDX=1./DX
    3178. 

  3178. !
    3179. 

  3179.       AK=.1666667*RDX*(Y2KP1-Y2K)
    3180. 

  3180.       BK=0.5*Y2K
    3181. 

  3181.       CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K)
    3182. 

  3182. !
    3183. 

  3183.   550 X=XK-XOLD(K)
    3184. 

  3184.       XSQ=X*X
    3185. 

  3185. !
    3186. 

  3186.       YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K)
    3187. 

  3187. 

  3188. !  debug
    3189. 

  3189. 

  3190.       IF(I.eq.II.and.J.eq.JJ)THEN
    3191. 

  3191.         WRITE(0,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', K1,XNEW(k1),YNEW(k1)
    3192. 

  3192.       ENDIF 
    3193. 

  3193. 

  3194. !
    3195. 

  3195.   600 K1=K1+1
    3196. 

  3196.       IF(K1.LE.NNEW)GO TO 300
    3197. 

  3197. 

  3198.       RETURN
    3199. 

  3199. 

  3200.       END SUBROUTINE SPLINE2
    3201. 

  3201. 

  3202. !=======================================================================================
    3203. 

  3203. !  E grid interpolation for H and V points 
    3204. 

  3204. !=======================================================================================
    3205. 

  3205. 

  3206.   SUBROUTINE interp_h_nmm (cfld,                                 &  ! CD field
    3207. 

  3207.                            cids, cide, ckds, ckde, cjds, cjde,   &
    3208. 

  3208.                            cims, cime, ckms, ckme, cjms, cjme,   &
    3209. 

  3209.                            cits, cite, ckts, ckte, cjts, cjte,   &
    3210. 

  3210.                            nfld,                                 &  ! ND field
    3211. 

  3211.                            nids, nide, nkds, nkde, njds, njde,   &
    3212. 

  3212.                            nims, nime, nkms, nkme, njms, njme,   &
    3213. 

  3213.                            nits, nite, nkts, nkte, njts, njte,   &
    3214. 

  3214.                            shw,                                  &  ! stencil half width for interp
    3215. 

  3215.                            imask,                                &  ! interpolation mask
    3216. 

  3216.                            xstag, ystag,                         &  ! staggering of field
    3217. 

  3217.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    3218. 

  3218.                            nri, nrj,                             &  ! nest ratios                           
    3219. 

  3219.                            CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! south-western grid locs and weights 
    3220. 

  3220.                            CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    3221. 

  3221.                            CBWGT4, HBWGT4                        )  ! dummys for weights
    3222. 

  3222.      USE module_timing
    3223. 

  3223.      IMPLICIT NONE
    3224. 

  3224. 

  3225.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    3226. 

  3226.                             cims, cime, ckms, ckme, cjms, cjme,   &
    3227. 

  3227.                             cits, cite, ckts, ckte, cjts, cjte,   &
    3228. 

  3228.                             nids, nide, nkds, nkde, njds, njde,   &
    3229. 

  3229.                             nims, nime, nkms, nkme, njms, njme,   &
    3230. 

  3230.                             nits, nite, nkts, nkte, njts, njte,   &
    3231. 

  3231.                             shw,                                  &
    3232. 

  3232.                             ipos, jpos,                           &
    3233. 

  3233.                             nri, nrj
    3234. 

  3234.      LOGICAL, INTENT(IN) :: xstag, ystag
    3235. 

  3235. 

  3236.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
    3237. 

  3237.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
    3238. 

  3238.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    3239. 

  3239.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    3240. 

  3240.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    3241. 

  3241.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    3242. 

  3242.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    3243. 

  3243. 

  3244. !    local
    3245. 

  3245.      INTEGER i,j,k
    3246. 

  3246. !
    3247. 

  3247. !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
    3248. 

  3248. !
    3249. 

  3249.     DO J=NJTS,MIN(NJTE,NJDE-1)
    3250. 

  3250.      DO I=NITS,MIN(NITE,NIDE-1)
    3251. 

  3251.        IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) &
    3252. 

  3252.            CALL wrf_error_fatal ('hpoints:check domain bounds along x' )
    3253. 

  3253.        IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) &
    3254. 

  3254.            CALL wrf_error_fatal ('hpoints:check domain bounds along y' )
    3255. 

  3255.      ENDDO
    3256. 

  3256.     ENDDO
    3257. 

  3257. !
    3258. 

  3258. !*** INDEX CONVENTIONS
    3259. 

  3259. !***                     HBWGT4
    3260. 

  3260. !***                      4
    3261. 

  3261. !***
    3262. 

  3262. !***
    3263. 

  3263. !***
    3264. 

  3264. !***                   h
    3265. 

  3265. !***             1                 2
    3266. 

  3266. !***            HBWGT1             HBWGT2
    3267. 

  3267. !***
    3268. 

  3268. !***
    3269. 

  3269. !***                      3
    3270. 

  3270. !***                     HBWGT3
    3271. 

  3271. 

  3272.      DO K=NKDS,NKDE
    3273. 

  3273.        DO J=NJTS,MIN(NJTE,NJDE-1)
    3274. 

  3274.         DO I=NITS,MIN(NITE,NIDE-1)
    3275. 

  3275.          IF(IMASK(I,J) .NE. 1)THEN
    3276. 

  3276. !
    3277. 

  3277.            IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7 
    3278. 

  3278.                NFLD(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3279. 

  3279.                            + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3280. 

  3280.                            + HBWGT3(I,J)*CFLD(IIH(I,J),  JJH(I,J)-1,K) &
    3281. 

  3281.                            + HBWGT4(I,J)*CFLD(IIH(I,J),  JJH(I,J)+1,K)
    3282. 

  3282.            ELSE
    3283. 

  3283.                NFLD(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3284. 

  3284.                            + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3285. 

  3285.                            + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) &
    3286. 

  3286.                            + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K)
    3287. 

  3287.            ENDIF
    3288. 

  3288. !     
    3289. 

  3289.          ENDIF
    3290. 

  3290.         ENDDO
    3291. 

  3291.        ENDDO
    3292. 

  3292.      ENDDO
    3293. 

  3293. 

  3294.   END SUBROUTINE interp_h_nmm
    3295. 

  3295. !
    3296. 

  3296.   SUBROUTINE interp_v_nmm (cfld,                                 &  ! CD field
    3297. 

  3297.                            cids, cide, ckds, ckde, cjds, cjde,   &
    3298. 

  3298.                            cims, cime, ckms, ckme, cjms, cjme,   &
    3299. 

  3299.                            cits, cite, ckts, ckte, cjts, cjte,   &
    3300. 

  3300.                            nfld,                                 &  ! ND field
    3301. 

  3301.                            nids, nide, nkds, nkde, njds, njde,   &
    3302. 

  3302.                            nims, nime, nkms, nkme, njms, njme,   &
    3303. 

  3303.                            nits, nite, nkts, nkte, njts, njte,   &
    3304. 

  3304.                            shw,                                  &  ! stencil half width for interp
    3305. 

  3305.                            imask,                                &  ! interpolation mask
    3306. 

  3306.                            xstag, ystag,                         &  ! staggering of field
    3307. 

  3307.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    3308. 

  3308.                            nri, nrj,                             &  ! nest ratios
    3309. 

  3309.                            CII, IIV, CJJ, JJV, CBWGT1, VBWGT1,   &  ! south-western grid locs and weights
    3310. 

  3310.                            CBWGT2, VBWGT2, CBWGT3, VBWGT3,       &  ! note that "C"ourse grid ones are
    3311. 

  3311.                            CBWGT4, VBWGT4                        )  ! dummys
    3312. 

  3312.      USE module_timing
    3313. 

  3313.      IMPLICIT NONE
    3314. 

  3314. 

  3315.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    3316. 

  3316.                             cims, cime, ckms, ckme, cjms, cjme,   &
    3317. 

  3317.                             cits, cite, ckts, ckte, cjts, cjte,   &
    3318. 

  3318.                             nids, nide, nkds, nkde, njds, njde,   &
    3319. 

  3319.                             nims, nime, nkms, nkme, njms, njme,   &
    3320. 

  3320.                             nits, nite, nkts, nkte, njts, njte,   &
    3321. 

  3321.                             shw,                                  &
    3322. 

  3322.                             ipos, jpos,                           &
    3323. 

  3323.                             nri, nrj
    3324. 

  3324.      LOGICAL, INTENT(IN) :: xstag, ystag
    3325. 

  3325. 

  3326.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
    3327. 

  3327.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
    3328. 

  3328.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    3329. 

  3329.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    3330. 

  3330.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    3331. 

  3331.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV
    3332. 

  3332.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    3333. 

  3333. 

  3334. !    local
    3335. 

  3335.      INTEGER i,j,k
    3336. 

  3336. 

  3337. 

  3338. !
    3339. 

  3339. !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
    3340. 

  3340. !
    3341. 

  3341.     DO J=NJTS,MIN(NJTE,NJDE-1)
    3342. 

  3342.      DO I=NITS,MIN(NITE,NIDE-1)
    3343. 

  3343.        IF(IIV(i,j).LT.(CIDS-shw) .OR. IIV(i,j).GT.(CIDE+shw)) &
    3344. 

  3344.            CALL wrf_error_fatal ('vpoints:check domain bounds along x' )
    3345. 

  3345.        IF(JJV(i,j).LT.(CJDS-shw) .OR. JJV(i,j).GT.(CJDE+shw)) &
    3346. 

  3346.            CALL wrf_error_fatal ('vpoints:check domain bounds along y' )
    3347. 

  3347.      ENDDO
    3348. 

  3348.     ENDDO
    3349. 

  3349. !
    3350. 

  3350. !*** INDEX CONVENTIONS
    3351. 

  3351. !***                     VBWGT4
    3352. 

  3352. !***                      4
    3353. 

  3353. !***
    3354. 

  3354. !***
    3355. 

  3355. !***
    3356. 

  3356. !***                   h
    3357. 

  3357. !***             1                 2
    3358. 

  3358. !***            VBWGT1             VBWGT2
    3359. 

  3359. !***
    3360. 

  3360. !***
    3361. 

  3361. !***                      3
    3362. 

  3362. !***                     VBWGT3
    3363. 

  3363. 

  3364.      DO K=NKDS,NKDE
    3365. 

  3365.        DO J=NJTS,MIN(NJTE,NJDE-1)
    3366. 

  3366.         DO I=NITS,MIN(NITE,NIDE-1)
    3367. 

  3367.          IF(IMASK(I,J) .NE. 1)THEN
    3368. 

  3368. 

  3369.             IF(MOD(JJV(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    3370. 

  3370.                 NFLD(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    3371. 

  3371.                             + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    3372. 

  3372.                             + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) &
    3373. 

  3373.                             + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K)
    3374. 

  3374.             ELSE
    3375. 

  3375.                 NFLD(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    3376. 

  3376.                             + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    3377. 

  3377.                             + VBWGT3(I,J)*CFLD(IIV(I,J),  JJV(I,J)-1,K) &
    3378. 

  3378.                             + VBWGT4(I,J)*CFLD(IIV(I,J),  JJV(I,J)+1,K)
    3379. 

  3379.             ENDIF
    3380. 

  3380. 

  3381.          ENDIF
    3382. 

  3382.         ENDDO
    3383. 

  3383.        ENDDO
    3384. 

  3384.      ENDDO
    3385. 

  3385. 

  3386.   END SUBROUTINE interp_v_nmm
    3387. 

  3387. !
    3388. 

  3388. !=======================================================================================
    3389. 

  3389. !  E grid nearest neighbour interpolation for H points.
    3390. 

  3390. !  This routine assumes cfld and nfld are in IJK
    3391. 

  3391. !=======================================================================================
    3392. 

  3392. !
    3393. 

  3393.   SUBROUTINE interp_hnear_nmm (cfld,                                 &  ! CD field
    3394. 

  3394.                                cids, cide, ckds, ckde, cjds, cjde,   &
    3395. 

  3395.                                cims, cime, ckms, ckme, cjms, cjme,   &
    3396. 

  3396.                                cits, cite, ckts, ckte, cjts, cjte,   &
    3397. 

  3397.                                nfld,                                 &  ! ND field
    3398. 

  3398.                                nids, nide, nkds, nkde, njds, njde,   &
    3399. 

  3399.                                nims, nime, nkms, nkme, njms, njme,   &
    3400. 

  3400.                                nits, nite, nkts, nkte, njts, njte,   &
    3401. 

  3401.                                shw,                                  &  ! stencil half width for interp
    3402. 

  3402.                                imask,                                &  ! interpolation mask
    3403. 

  3403.                                xstag, ystag,                         &  ! staggering of field
    3404. 

  3404.                                ipos, jpos,                           &  ! Position of lower left of nest in CD
    3405. 

  3405.                                nri, nrj,                             &  ! nest ratios                         
    3406. 

  3406.                                CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! south-western grid locs and weights 
    3407. 

  3407.                                CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    3408. 

  3408.                                CBWGT4, HBWGT4                        )  ! just dummys
    3409. 

  3409.      USE module_timing
    3410. 

  3410.      IMPLICIT NONE
    3411. 

  3411. 

  3412.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    3413. 

  3413.                             cims, cime, ckms, ckme, cjms, cjme,   &
    3414. 

  3414.                             cits, cite, ckts, ckte, cjts, cjte,   &
    3415. 

  3415.                             nids, nide, nkds, nkde, njds, njde,   &
    3416. 

  3416.                             nims, nime, nkms, nkme, njms, njme,   &
    3417. 

  3417.                             nits, nite, nkts, nkte, njts, njte,   &
    3418. 

  3418.                             shw,                                  &
    3419. 

  3419.                             ipos, jpos,                           &
    3420. 

  3420.                             nri, nrj
    3421. 

  3421.      LOGICAL, INTENT(IN) :: xstag, ystag
    3422. 

  3422. 

  3423.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
    3424. 

  3424.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
    3425. 

  3425.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    3426. 

  3426.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    3427. 

  3427.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    3428. 

  3428.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    3429. 

  3429.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    3430. 

  3430. 

  3431. !    local
    3432. 

  3432. 

  3433.      LOGICAL  FLIP
    3434. 

  3434.      INTEGER  i,j,k,n
    3435. 

  3435.      REAL     SUM,AMAXVAL
    3436. 

  3436.      REAL,    DIMENSION (4, nims:nime, njms:njme ) :: NBWGT
    3437. 

  3437. 

  3438. !
    3439. 

  3439. !*** INDEX CONVENTIONS
    3440. 

  3440. !***                     NBWGT4=0
    3441. 

  3441. !***                      4
    3442. 

  3442. !***
    3443. 

  3443. !***
    3444. 

  3444. !***
    3445. 

  3445. !***                   h
    3446. 

  3446. !***             1                 2
    3447. 

  3447. !***            NBWGT1=1           NBWGT2=0
    3448. 

  3448. !***
    3449. 

  3449. !***
    3450. 

  3450. !***                      3
    3451. 

  3451. !***                     NBWGT3=0
    3452. 

  3452. 

  3453.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3454. 

  3454.       DO I=NITS,MIN(NITE,NIDE-1)
    3455. 

  3455.        IF(IMASK(I,J) .NE. 1)THEN
    3456. 

  3456.          NBWGT(1,I,J)=HBWGT1(I,J)
    3457. 

  3457.          NBWGT(2,I,J)=HBWGT2(I,J)
    3458. 

  3458.          NBWGT(3,I,J)=HBWGT3(I,J)
    3459. 

  3459.          NBWGT(4,I,J)=HBWGT4(I,J)
    3460. 

  3460.        ENDIF
    3461. 

  3461.       ENDDO
    3462. 

  3462.      ENDDO
    3463. 

  3463. 

  3464.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3465. 

  3465.       DO I=NITS,MIN(NITE,NIDE-1)
    3466. 

  3466.        IF(IMASK(I,J) .NE. 1)THEN
    3467. 

  3467. 

  3468.           AMAXVAL=0.
    3469. 

  3469.           DO N=1,4
    3470. 

  3470.             AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
    3471. 

  3471.           ENDDO
    3472. 

  3472. 

  3473.           FLIP=.TRUE.
    3474. 

  3474.           SUM=0.0
    3475. 

  3475.           DO N=1,4
    3476. 

  3476.              IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
    3477. 

  3477.                NBWGT(N,I,J)=1.0
    3478. 

  3478.                FLIP=.FALSE.
    3479. 

  3479.              ELSE
    3480. 

  3480.                NBWGT(N,I,J)=0.0
    3481. 

  3481.              ENDIF
    3482. 

  3482.              SUM=SUM+NBWGT(N,I,J)
    3483. 

  3483.              IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
    3484. 

  3484.           ENDDO
    3485. 

  3485. 

  3486.        ENDIF
    3487. 

  3487.       ENDDO
    3488. 

  3488.      ENDDO
    3489. 

  3489. 

  3490.      DO K=NKDS,NKDE
    3491. 

  3491.        DO J=NJTS,MIN(NJTE,NJDE-1)
    3492. 

  3492.         DO I=NITS,MIN(NITE,NIDE-1)
    3493. 

  3493.          IF(IMASK(I,J) .NE. 1)THEN
    3494. 

  3494.             IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7 
    3495. 

  3495.                 NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3496. 

  3496.                             + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3497. 

  3497.                             + NBWGT(3,I,J)*CFLD(IIH(I,J),  JJH(I,J)-1,K) &
    3498. 

  3498.                             + NBWGT(4,I,J)*CFLD(IIH(I,J),  JJH(I,J)+1,K)
    3499. 

  3499.             ELSE
    3500. 

  3500.                 NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3501. 

  3501.                             + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3502. 

  3502.                             + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) &
    3503. 

  3503.                             + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K)
    3504. 

  3504.             ENDIF
    3505. 

  3505.          ENDIF
    3506. 

  3506.         ENDDO
    3507. 

  3507.        ENDDO
    3508. 

  3508.      ENDDO
    3509. 

  3509. 

  3510.   END SUBROUTINE interp_hnear_nmm
    3511. 

  3511.   SUBROUTINE force_sst_nmm    (cfld,                                 &  ! CD field
    3512. 

  3512.                                cids, cide, ckds, ckde, cjds, cjde,   &
    3513. 

  3513.                                cims, cime, ckms, ckme, cjms, cjme,   &
    3514. 

  3514.                                cits, cite, ckts, ckte, cjts, cjte,   &
    3515. 

  3515.                                nfld,                                 &  ! ND field
    3516. 

  3516.                                nids, nide, nkds, nkde, njds, njde,   &
    3517. 

  3517.                                nims, nime, nkms, nkme, njms, njme,   &
    3518. 

  3518.                                nits, nite, nkts, nkte, njts, njte,   &
    3519. 

  3519.                                shw,                                  &  ! stencil half width for interp
    3520. 

  3520.                                imask,                                &  ! interpolation mask
    3521. 

  3521.                                xstag, ystag,                         &  ! staggering of field
    3522. 

  3522.                                ipos, jpos,                           &  ! Position of lower left of nest in CD
    3523. 

  3523.                                nri, nrj,                             &  ! nest ratios                         
    3524. 

  3524.                                CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! south-western grid locs and weights 
    3525. 

  3525.                                CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    3526. 

  3526.                                CBWGT4, HBWGT4, CCSST, CSST           )  ! just dummys
    3527. 

  3527.      USE module_timing
    3528. 

  3528.      IMPLICIT NONE
    3529. 

  3529. 

  3530.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    3531. 

  3531.                             cims, cime, ckms, ckme, cjms, cjme,   &
    3532. 

  3532.                             cits, cite, ckts, ckte, cjts, cjte,   &
    3533. 

  3533.                             nids, nide, nkds, nkde, njds, njde,   &
    3534. 

  3534.                             nims, nime, nkms, nkme, njms, njme,   &
    3535. 

  3535.                             nits, nite, nkts, nkte, njts, njte,   &
    3536. 

  3536.                             shw,                                  &
    3537. 

  3537.                             ipos, jpos,                           &
    3538. 

  3538.                             nri, nrj
    3539. 

  3539.      LOGICAL, INTENT(IN) :: xstag, ystag
    3540. 

  3540. 

  3541.      REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfld
    3542. 

  3542.      REAL, DIMENSION ( nims:nime, njms:njme ) :: nfld
    3543. 

  3543.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    3544. 

  3544.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    3545. 

  3545.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    3546. 

  3546.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    3547. 

  3547.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    3548. 

  3548.      INTEGER , INTENT(IN) :: csst(*), ccsst(*)
    3549. 

  3549. !    local
    3550. 

  3550. 

  3551.      LOGICAL  FLIP
    3552. 

  3552.      INTEGER  i,j,k,n
    3553. 

  3553.      REAL     SUM,AMAXVAL
    3554. 

  3554.      REAL,    DIMENSION (4, nims:nime, njms:njme ) :: NBWGT
    3555. 

  3555. 

  3556.      if(csst(1) /= 1) return
    3557. 

  3557. 

  3558. !
    3559. 

  3559. !*** INDEX CONVENTIONS
    3560. 

  3560. !***                     NBWGT4=0
    3561. 

  3561. !***                      4
    3562. 

  3562. !***
    3563. 

  3563. !***
    3564. 

  3564. !***
    3565. 

  3565. !***                   h
    3566. 

  3566. !***             1                 2
    3567. 

  3567. !***            NBWGT1=1           NBWGT2=0
    3568. 

  3568. !***
    3569. 

  3569. !***
    3570. 

  3570. !***                      3
    3571. 

  3571. !***                     NBWGT3=0
    3572. 

  3572. 

  3573.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3574. 

  3574.       DO I=NITS,MIN(NITE,NIDE-1)
    3575. 

  3575.             NBWGT(1,I,J)=HBWGT1(I,J)
    3576. 

  3576.             NBWGT(2,I,J)=HBWGT2(I,J)
    3577. 

  3577.             NBWGT(3,I,J)=HBWGT3(I,J)
    3578. 

  3578.             NBWGT(4,I,J)=HBWGT4(I,J)
    3579. 

  3579.       ENDDO
    3580. 

  3580.      ENDDO
    3581. 

  3581. 

  3582.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3583. 

  3583.       DO I=NITS,MIN(NITE,NIDE-1)
    3584. 

  3584.           AMAXVAL=0.
    3585. 

  3585.           DO N=1,4
    3586. 

  3586.             AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
    3587. 

  3587.           ENDDO
    3588. 

  3588. 

  3589.           FLIP=.TRUE.
    3590. 

  3590.           SUM=0.0
    3591. 

  3591.           DO N=1,4
    3592. 

  3592.              IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
    3593. 

  3593.                NBWGT(N,I,J)=1.0
    3594. 

  3594.                FLIP=.FALSE.
    3595. 

  3595.              ELSE
    3596. 

  3596.                NBWGT(N,I,J)=0.0
    3597. 

  3597.              ENDIF
    3598. 

  3598.              SUM=SUM+NBWGT(N,I,J)
    3599. 

  3599.              IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
    3600. 

  3600.           ENDDO
    3601. 

  3601.       ENDDO
    3602. 

  3602.      ENDDO
    3603. 

  3603. 

  3604.        DO J=NJTS,MIN(NJTE,NJDE-1)
    3605. 

  3605.         DO I=NITS,MIN(NITE,NIDE-1)
    3606. 

  3606.             IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7 
    3607. 

  3607.                 NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J),  JJH(I,J)  ) &
    3608. 

  3608.                           + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ) &
    3609. 

  3609.                           + NBWGT(3,I,J)*CFLD(IIH(I,J),  JJH(I,J)-1) &
    3610. 

  3610.                           + NBWGT(4,I,J)*CFLD(IIH(I,J),  JJH(I,J)+1)
    3611. 

  3611.             ELSE
    3612. 

  3612.                 NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J),  JJH(I,J)  ) &
    3613. 

  3613.                           + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ) &
    3614. 

  3614.                           + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1) &
    3615. 

  3615.                           + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1)
    3616. 

  3616.             ENDIF
    3617. 

  3617.         ENDDO
    3618. 

  3618.        ENDDO
    3619. 

  3619. 

  3620. 

  3621.      END SUBROUTINE force_sst_nmm
    3622. 

  3622. !=======================================================================================
    3623. 

  3623. !  E grid nearest neighbour interpolation for H points.
    3624. 

  3624. !  This routine assumes cfld and nfld are in IKJ or ILJ
    3625. 

  3625. !=======================================================================================
    3626. 

  3626. !
    3627. 

  3627.   SUBROUTINE interp_hnear_ikj_nmm (cfld,                                 &  ! CD field
    3628. 

  3628.                                cids, cide, ckds, ckde, cjds, cjde,   &
    3629. 

  3629.                                cims, cime, ckms, ckme, cjms, cjme,   &
    3630. 

  3630.                                cits, cite, ckts, ckte, cjts, cjte,   &
    3631. 

  3631.                                nfld,                                 &  ! ND field
    3632. 

  3632.                                nids, nide, nkds, nkde, njds, njde,   &
    3633. 

  3633.                                nims, nime, nkms, nkme, njms, njme,   &
    3634. 

  3634.                                nits, nite, nkts, nkte, njts, njte,   &
    3635. 

  3635.                                shw,                                  &  ! stencil half width for interp
    3636. 

  3636.                                imask,                                &  ! interpolation mask
    3637. 

  3637.                                xstag, ystag,                         &  ! staggering of field
    3638. 

  3638.                                ipos, jpos,                           &  ! Position of lower left of nest in CD
    3639. 

  3639.                                nri, nrj,                             &  ! nest ratios
    3640. 

  3640.                                CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! south-western grid locs and weights
    3641. 

  3641.                                CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    3642. 

  3642.                                CBWGT4, HBWGT4                        )  ! just dummys
    3643. 

  3643.      USE module_timing
    3644. 

  3644.      IMPLICIT NONE
    3645. 

  3645. 

  3646.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    3647. 

  3647.                             cims, cime, ckms, ckme, cjms, cjme,   &
    3648. 

  3648.                             cits, cite, ckts, ckte, cjts, cjte,   &
    3649. 

  3649.                             nids, nide, nkds, nkde, njds, njde,   &
    3650. 

  3650.                             nims, nime, nkms, nkme, njms, njme,   &
    3651. 

  3651.                             nits, nite, nkts, nkte, njts, njte,   &
    3652. 

  3652.                             shw,                                  &
    3653. 

  3653.                             ipos, jpos,                           &
    3654. 

  3654.                             nri, nrj
    3655. 

  3655.      LOGICAL, INTENT(IN) :: xstag, ystag
    3656. 

  3656. 

  3657.      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
    3658. 

  3658.      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
    3659. 

  3659.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    3660. 

  3660.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    3661. 

  3661.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    3662. 

  3662.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    3663. 

  3663.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    3664. 

  3664. 

  3665. !    local
    3666. 

  3666. 

  3667.      LOGICAL  FLIP
    3668. 

  3668.      INTEGER  i,j,k,n
    3669. 

  3669.      REAL     SUM,AMAXVAL
    3670. 

  3670.      REAL,    DIMENSION (4, nims:nime, njms:njme ) :: NBWGT
    3671. 

  3671. 

  3672. !
    3673. 

  3673. !*** INDEX CONVENTIONS
    3674. 

  3674. !***                     NBWGT4=0
    3675. 

  3675. !***                      4
    3676. 

  3676. !***
    3677. 

  3677. !***
    3678. 

  3678. !***
    3679. 

  3679. !***                   h
    3680. 

  3680. !***             1                 2
    3681. 

  3681. !***            NBWGT1=1           NBWGT2=0
    3682. 

  3682. !***
    3683. 

  3683. !***
    3684. 

  3684. !***                      3
    3685. 

  3685. !***                     NBWGT3=0
    3686. 

  3686. 

  3687.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3688. 

  3688.       DO I=NITS,MIN(NITE,NIDE-1)
    3689. 

  3689.        IF(IMASK(I,J) .NE. 1)THEN
    3690. 

  3690.          NBWGT(1,I,J)=HBWGT1(I,J)
    3691. 

  3691.          NBWGT(2,I,J)=HBWGT2(I,J)
    3692. 

  3692.          NBWGT(3,I,J)=HBWGT3(I,J)
    3693. 

  3693.          NBWGT(4,I,J)=HBWGT4(I,J)
    3694. 

  3694.        ENDIF
    3695. 

  3695.       ENDDO
    3696. 

  3696.      ENDDO
    3697. 

  3697. 

  3698.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3699. 

  3699.       DO I=NITS,MIN(NITE,NIDE-1)
    3700. 

  3700.        IF(IMASK(I,J) .NE. 1)THEN
    3701. 

  3701. 

  3702.           AMAXVAL=0.
    3703. 

  3703.           DO N=1,4
    3704. 

  3704.             AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
    3705. 

  3705.           ENDDO
    3706. 

  3706. 

  3707.           FLIP=.TRUE.
    3708. 

  3708.           SUM=0.0
    3709. 

  3709.           DO N=1,4
    3710. 

  3710.              IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
    3711. 

  3711.                NBWGT(N,I,J)=1.0
    3712. 

  3712.                FLIP=.FALSE.
    3713. 

  3713.              ELSE
    3714. 

  3714.                NBWGT(N,I,J)=0.0
    3715. 

  3715.              ENDIF
    3716. 

  3716.              SUM=SUM+NBWGT(N,I,J)
    3717. 

  3717.              IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
    3718. 

  3718.           ENDDO
    3719. 

  3719. 

  3720.        ENDIF
    3721. 

  3721.       ENDDO
    3722. 

  3722.      ENDDO
    3723. 

  3723. 

  3724.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3725. 

  3725.        DO K=NKDS,NKDE
    3726. 

  3726.         DO I=NITS,MIN(NITE,NIDE-1)
    3727. 

  3727.          IF(IMASK(I,J) .NE. 1)THEN
    3728. 

  3728.             IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    3729. 

  3729.                 NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J),  K,JJH(I,J)  ) &
    3730. 

  3730.                             + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J)  ) &
    3731. 

  3731.                             + NBWGT(3,I,J)*CFLD(IIH(I,J),  K,JJH(I,J)-1) &
    3732. 

  3732.                             + NBWGT(4,I,J)*CFLD(IIH(I,J),  K,JJH(I,J)+1)
    3733. 

  3733.             ELSE
    3734. 

  3734.                 NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J),  K,JJH(I,J)  ) &
    3735. 

  3735.                             + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J)  ) &
    3736. 

  3736.                             + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J)-1) &
    3737. 

  3737.                             + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J)+1)
    3738. 

  3738.             ENDIF
    3739. 

  3739.          ENDIF
    3740. 

  3740.         ENDDO
    3741. 

  3741.        ENDDO
    3742. 

  3742.      ENDDO
    3743. 

  3743. 

  3744.   END SUBROUTINE interp_hnear_ikj_nmm
    3745. 

  3745. !
    3746. 

  3746. !=======================================================================================
    3747. 

  3747. !  E grid nearest neighbour interpolation for integer H points
    3748. 

  3748. !=======================================================================================
    3749. 

  3749. !
    3750. 

  3750.   SUBROUTINE interp_int_hnear_nmm (cfld,                                 &  ! CD field; integers
    3751. 

  3751.                                    cids, cide, ckds, ckde, cjds, cjde,   &
    3752. 

  3752.                                    cims, cime, ckms, ckme, cjms, cjme,   &
    3753. 

  3753.                                    cits, cite, ckts, ckte, cjts, cjte,   &
    3754. 

  3754.                                    nfld,                                 &  ! ND field; integers
    3755. 

  3755.                                    nids, nide, nkds, nkde, njds, njde,   &
    3756. 

  3756.                                    nims, nime, nkms, nkme, njms, njme,   &
    3757. 

  3757.                                    nits, nite, nkts, nkte, njts, njte,   &
    3758. 

  3758.                                    shw,                                  &  ! stencil half width for interp
    3759. 

  3759.                                    imask,                                &  ! interpolation mask
    3760. 

  3760.                                    xstag, ystag,                         &  ! staggering of field
    3761. 

  3761.                                    ipos, jpos,                           &  ! lower left of nest in CD
    3762. 

  3762.                                    nri, nrj,                             &  ! nest ratios                      
    3763. 

  3763.                                    CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! s-w grid locs and weights 
    3764. 

  3764.                                    CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    3765. 

  3765.                                    CBWGT4, HBWGT4                        )  ! just dummys
    3766. 

  3766.      USE module_timing
    3767. 

  3767.      IMPLICIT NONE
    3768. 

  3768. 

  3769.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    3770. 

  3770.                             cims, cime, ckms, ckme, cjms, cjme,   &
    3771. 

  3771.                             cits, cite, ckts, ckte, cjts, cjte,   &
    3772. 

  3772.                             nids, nide, nkds, nkde, njds, njde,   &
    3773. 

  3773.                             nims, nime, nkms, nkme, njms, njme,   &
    3774. 

  3774.                             nits, nite, nkts, nkte, njts, njte,   &
    3775. 

  3775.                             shw,                                  &
    3776. 

  3776.                             ipos, jpos,                           &
    3777. 

  3777.                             nri, nrj
    3778. 

  3778.      LOGICAL, INTENT(IN) :: xstag, ystag
    3779. 

  3779. 

  3780.      INTEGER, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
    3781. 

  3781.      INTEGER, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
    3782. 

  3782.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    3783. 

  3783.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    3784. 

  3784.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    3785. 

  3785.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    3786. 

  3786.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    3787. 

  3787. 

  3788. !    local
    3789. 

  3789. 

  3790.      LOGICAL  FLIP 
    3791. 

  3791.      INTEGER  i,j,k,n
    3792. 

  3792.      REAL     SUM,AMAXVAL
    3793. 

  3793.      REAL,    DIMENSION (4, nims:nime, njms:njme ) :: NBWGT
    3794. 

  3794. 

  3795. !
    3796. 

  3796. !*** INDEX CONVENTIONS
    3797. 

  3797. !***                     NBWGT4=0
    3798. 

  3798. !***                      4
    3799. 

  3799. !***
    3800. 

  3800. !***
    3801. 

  3801. !***
    3802. 

  3802. !***                   h
    3803. 

  3803. !***             1                 2
    3804. 

  3804. !***            NBWGT1=1           NBWGT2=0
    3805. 

  3805. !***
    3806. 

  3806. !***
    3807. 

  3807. !***                      3
    3808. 

  3808. !***                     NBWGT3=0
    3809. 

  3809. 

  3810.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3811. 

  3811.        DO I=NITS,MIN(NITE,NIDE-1)
    3812. 

  3812.         IF(IMASK(I,J) .NE. 1)THEN
    3813. 

  3813.           NBWGT(1,I,J)=HBWGT1(I,J)
    3814. 

  3814.           NBWGT(2,I,J)=HBWGT2(I,J)
    3815. 

  3815.           NBWGT(3,I,J)=HBWGT3(I,J)
    3816. 

  3816.           NBWGT(4,I,J)=HBWGT4(I,J)
    3817. 

  3817.         ENDIF
    3818. 

  3818.        ENDDO
    3819. 

  3819.      ENDDO
    3820. 

  3820. 

  3821.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3822. 

  3822.       DO I=NITS,MIN(NITE,NIDE-1)
    3823. 

  3823.        IF(IMASK(I,J) .NE. 1)THEN
    3824. 

  3824. 

  3825.           AMAXVAL=0.
    3826. 

  3826.           DO N=1,4
    3827. 

  3827.             AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
    3828. 

  3828.           ENDDO
    3829. 

  3829. 

  3830.           FLIP=.TRUE.
    3831. 

  3831.           SUM=0.0
    3832. 

  3832.           DO N=1,4
    3833. 

  3833.              IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
    3834. 

  3834.                NBWGT(N,I,J)=1.0
    3835. 

  3835.                FLIP=.FALSE.
    3836. 

  3836.              ELSE
    3837. 

  3837.                NBWGT(N,I,J)=0.0
    3838. 

  3838.              ENDIF
    3839. 

  3839.              SUM=SUM+NBWGT(N,I,J)
    3840. 

  3840.              IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
    3841. 

  3841.           ENDDO
    3842. 

  3842. ! 
    3843. 

  3843.        ENDIF
    3844. 

  3844.       ENDDO
    3845. 

  3845.      ENDDO
    3846. 

  3846. 

  3847.      DO J=NJTS,MIN(NJTE,NJDE-1)
    3848. 

  3848.        DO K=NKTS,NKTS
    3849. 

  3849.         DO I=NITS,MIN(NITE,NIDE-1)
    3850. 

  3850.          IF(IMASK(I,J) .NE. 1)THEN
    3851. 

  3851.            IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7 
    3852. 

  3852.                NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3853. 

  3853.                            + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3854. 

  3854.                            + NBWGT(3,I,J)*CFLD(IIH(I,J),  JJH(I,J)-1,K) &
    3855. 

  3855.                            + NBWGT(4,I,J)*CFLD(IIH(I,J),  JJH(I,J)+1,K)
    3856. 

  3856.            ELSE
    3857. 

  3857.                NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3858. 

  3858.                            + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3859. 

  3859.                            + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) &
    3860. 

  3860.                            + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K)
    3861. 

  3861.            ENDIF
    3862. 

  3862.          ENDIF
    3863. 

  3863.         ENDDO
    3864. 

  3864.        ENDDO
    3865. 

  3865.      ENDDO
    3866. 

  3866. 

  3867.   END SUBROUTINE interp_int_hnear_nmm
    3868. 

  3868. !
    3869. 

  3869. !--------------------------------------------------------------------------------------
    3870. 

  3870. !
    3871. 

  3871.    SUBROUTINE nmm_bdy_hinterp (cfld,                                 &  ! CD field
    3872. 

  3872.                                cids, cide, ckds, ckde, cjds, cjde,   &
    3873. 

  3873.                                cims, cime, ckms, ckme, cjms, cjme,   &
    3874. 

  3874.                                cits, cite, ckts, ckte, cjts, cjte,   &
    3875. 

  3875.                                nfld,                                 &  ! ND field
    3876. 

  3876.                                nids, nide, nkds, nkde, njds, njde,   &
    3877. 

  3877.                                nims, nime, nkms, nkme, njms, njme,   &
    3878. 

  3878.                                nits, nite, nkts, nkte, njts, njte,   &
    3879. 

  3879.                                shw,                                  &  ! stencil half width
    3880. 

  3880.                                imask,                                &  ! interpolation mask
    3881. 

  3881.                                xstag, ystag,                         &  ! staggering of field
    3882. 

  3882.                                ipos, jpos,                           &  ! Position of lower left of nest in CD
    3883. 

  3883.                                nri, nrj,                             &  ! nest ratios
    3884. 

  3884.                                c_bxs,n_bxs,                          &
    3885. 

  3885.                                c_bxe,n_bxe,                          &
    3886. 

  3886.                                c_bys,n_bys,                          &
    3887. 

  3887.                                c_bye,n_bye,                          &
    3888. 

  3888.                                c_btxs,n_btxs,                        &
    3889. 

  3889.                                c_btxe,n_btxe,                        &
    3890. 

  3890.                                c_btys,n_btys,                        &
    3891. 

  3891.                                c_btye,n_btye,                        &
    3892. 

  3892.                                CTEMP_B,NTEMP_B,                      &  ! These temp arrays should be removed
    3893. 

  3893.                                CTEMP_BT,NTEMP_BT,                    &  ! later on
    3894. 

  3894.                                CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   &  ! south-western grid locs and weights
    3895. 

  3895.                                CBWGT2, HBWGT2, CBWGT3, HBWGT3,       &  ! note that "C"ourse grid ones are
    3896. 

  3896.                                CBWGT4, HBWGT4                        )  ! dummys
    3897. 

  3897. 

  3898. !     use module_state_description
    3899. 

  3899.      USE module_configure
    3900. 

  3900.      USE module_wrf_error
    3901. 

  3901. 

  3902.      IMPLICIT NONE
    3903. 

  3903. 

  3904. 

  3905.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    3906. 

  3906.                             cims, cime, ckms, ckme, cjms, cjme,   &
    3907. 

  3907.                             cits, cite, ckts, ckte, cjts, cjte,   &
    3908. 

  3908.                             nids, nide, nkds, nkde, njds, njde,   &
    3909. 

  3909.                             nims, nime, nkms, nkme, njms, njme,   &
    3910. 

  3910.                             nits, nite, nkts, nkte, njts, njte,   &
    3911. 

  3911.                             shw,                                  &
    3912. 

  3912.                             ipos, jpos,                           &
    3913. 

  3913.                             nri, nrj
    3914. 

  3914. 

  3915.      LOGICAL, INTENT(IN) :: xstag, ystag
    3916. 

  3916. 

  3917.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
    3918. 

  3918.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
    3919. 

  3919. !
    3920. 

  3920.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: ctemp_b,ctemp_bt
    3921. 

  3921.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: ntemp_b,ntemp_bt
    3922. 

  3922. !
    3923. 

  3923.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    3924. 

  3924.      REAL,  DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye
    3925. 

  3925.      REAL,  DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
    3926. 

  3926.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    3927. 

  3927.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    3928. 

  3928.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    3929. 

  3929.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    3930. 

  3930. 

  3931. ! Local
    3932. 

  3932. 

  3933.      INTEGER :: i,j,k
    3934. 

  3934.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme )    :: cwk1,cwk2,cwk3,cwk4
    3935. 

  3935. 

  3936. !    X start boundary
    3937. 

  3937. 

  3938.        NMM_XS: IF(NITS .EQ. NIDS)THEN
    3939. 

  3939. !        WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
    3940. 

  3940.         I = NIDS
    3941. 

  3941.         DO K = NKDS,NKDE
    3942. 

  3942.          DO J = NJTS,MIN(NJTE,NJDE-1)
    3943. 

  3943.               IF(MOD(J,2) .NE.0)THEN                ! 1,3,5,7 of nested domain
    3944. 

  3944.                 IF(MOD(JJH(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    3945. 

  3945.                    CWK1(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3946. 

  3946.                                + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3947. 

  3947.                                + HBWGT3(I,J)*CFLD(IIH(I,J),  JJH(I,J)-1,K) &
    3948. 

  3948.                                + HBWGT4(I,J)*CFLD(IIH(I,J),  JJH(I,J)+1,K)
    3949. 

  3949. 

  3950. 

  3951.                 ELSE
    3952. 

  3952.                    CWK1(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3953. 

  3953.                                + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3954. 

  3954.                                + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) &
    3955. 

  3955.                                + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K)
    3956. 

  3956.                 ENDIF
    3957. 

  3957.               ELSE
    3958. 

  3958.                 CWK1(I,J,K) = 0.0      ! even rows at mass points of the nested domain
    3959. 

  3959.               ENDIF
    3960. 

  3960.               ntemp_b(i,J,K)     = CWK1(I,J,K)
    3961. 

  3961.               ntemp_bt(i,J,K)    = 0.0
    3962. 

  3962.          END DO
    3963. 

  3963.         END DO
    3964. 

  3964.        ENDIF NMM_XS
    3965. 

  3965. 

  3966. !    X end boundary
    3967. 

  3967. 

  3968.        NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
    3969. 

  3969. !       WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
    3970. 

  3970.         I = NIDE-1
    3971. 

  3971.         DO K = NKDS,NKDE
    3972. 

  3972.          DO J = NJTS,MIN(NJTE,NJDE-1)
    3973. 

  3973.               IF(MOD(J,2) .NE.0)THEN                ! 1,3,5,7 of the nested domain 
    3974. 

  3974.                 IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7 of the parent domain
    3975. 

  3975.                    CWK2(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3976. 

  3976.                                + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3977. 

  3977.                                + HBWGT3(I,J)*CFLD(IIH(I,J),  JJH(I,J)-1,K) &
    3978. 

  3978.                                + HBWGT4(I,J)*CFLD(IIH(I,J),  JJH(I,J)+1,K)
    3979. 

  3979.                 ELSE
    3980. 

  3980.                    CWK2(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    3981. 

  3981.                                + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    3982. 

  3982.                                + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) &
    3983. 

  3983.                                + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K)
    3984. 

  3984.                 ENDIF
    3985. 

  3985.               ELSE
    3986. 

  3986.                 CWK2(I,J,K) = 0.0      ! even rows at mass points
    3987. 

  3987.               ENDIF
    3988. 

  3988.               ntemp_b(i,J,K)     = CWK2(I,J,K)
    3989. 

  3989.               ntemp_bt(i,J,K)    = 0.0
    3990. 

  3990.          END DO
    3991. 

  3991.         END DO
    3992. 

  3992.        ENDIF NMM_XE
    3993. 

  3993. 

  3994. !  Y start boundary
    3995. 

  3995. 

  3996.        NMM_YS: IF(NJTS .EQ. NJDS)THEN
    3997. 

  3997. !        WRITE(0,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
    3998. 

  3998.         J = NJDS
    3999. 

  3999.         DO K = NKDS, NKDE
    4000. 

  4000.          DO I = NITS,MIN(NITE,NIDE-1)
    4001. 

  4001.               IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    4002. 

  4002.                  CWK3(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    4003. 

  4003.                              + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    4004. 

  4004.                              + HBWGT3(I,J)*CFLD(IIH(I,J),  JJH(I,J)-1,K) &
    4005. 

  4005.                              + HBWGT4(I,J)*CFLD(IIH(I,J),  JJH(I,J)+1,K)
    4006. 

  4006.               ELSE
    4007. 

  4007.                  CWK3(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    4008. 

  4008.                              + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    4009. 

  4009.                              + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) &
    4010. 

  4010.                              + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K)
    4011. 

  4011.               ENDIF
    4012. 

  4012.               ntemp_b(i,J,K)     = CWK3(I,J,K)
    4013. 

  4013.               ntemp_bt(i,J,K)    = 0.0
    4014. 

  4014.          END DO
    4015. 

  4015.         END DO
    4016. 

  4016.        END IF NMM_YS
    4017. 

  4017. 

  4018. ! Y end boundary
    4019. 

  4019. 

  4020.        NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
    4021. 

  4021. !        WRITE(0,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
    4022. 

  4022.         J = NJDE-1
    4023. 

  4023.         DO K = NKDS,NKDE
    4024. 

  4024.          DO I = NITS,MIN(NITE,NIDE-1)
    4025. 

  4025.               IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    4026. 

  4026.                  CWK4(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    4027. 

  4027.                              + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    4028. 

  4028.                              + HBWGT3(I,J)*CFLD(IIH(I,J),  JJH(I,J)-1,K) &
    4029. 

  4029.                              + HBWGT4(I,J)*CFLD(IIH(I,J),  JJH(I,J)+1,K)
    4030. 

  4030.               ELSE
    4031. 

  4031.                  CWK4(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J),  JJH(I,J)  ,K) &
    4032. 

  4032.                              + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)  ,K) &
    4033. 

  4033.                              + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) &
    4034. 

  4034.                              + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K)
    4035. 

  4035. 

  4036.               ENDIF
    4037. 

  4037.               ntemp_b(i,J,K)     = CWK4(I,J,K)
    4038. 

  4038.               ntemp_bt(i,J,K)    = 0.0
    4039. 

  4039.          END DO
    4040. 

  4040.         END DO
    4041. 

  4041.        END IF NMM_YE
    4042. 

  4042. 

  4043.      RETURN
    4044. 

  4044. 

  4045.    END SUBROUTINE nmm_bdy_hinterp
    4046. 

  4046. 

  4047. !--------------------------------------------------------------------------------------
    4048. 

  4048. 

  4049.    SUBROUTINE nmm_bdy_vinterp ( cfld,                                 &  ! CD field
    4050. 

  4050.                                cids, cide, ckds, ckde, cjds, cjde,   &
    4051. 

  4051.                                cims, cime, ckms, ckme, cjms, cjme,   &
    4052. 

  4052.                                cits, cite, ckts, ckte, cjts, cjte,   &
    4053. 

  4053.                                nfld,                                 &  ! ND field
    4054. 

  4054.                                nids, nide, nkds, nkde, njds, njde,   &
    4055. 

  4055.                                nims, nime, nkms, nkme, njms, njme,   &
    4056. 

  4056.                                nits, nite, nkts, nkte, njts, njte,   &
    4057. 

  4057.                                shw,                                  &  ! stencil half width
    4058. 

  4058.                                imask,                                &  ! interpolation mask
    4059. 

  4059.                                xstag, ystag,                         &  ! staggering of field
    4060. 

  4060.                                ipos, jpos,                           &  ! Position of lower left of nest in CD
    4061. 

  4061.                                nri, nrj,                             &  ! nest ratios
    4062. 

  4062.                                c_bxs,n_bxs,                          &
    4063. 

  4063.                                c_bxe,n_bxe,                          &
    4064. 

  4064.                                c_bys,n_bys,                          &
    4065. 

  4065.                                c_bye,n_bye,                          &
    4066. 

  4066.                                c_btxs,n_btxs,                        &
    4067. 

  4067.                                c_btxe,n_btxe,                        &
    4068. 

  4068.                                c_btys,n_btys,                        &
    4069. 

  4069.                                c_btye,n_btye,                        &
    4070. 

  4070.                                CTEMP_B,NTEMP_B,                      &  ! These temp arrays should be removed
    4071. 

  4071.                                CTEMP_BT,NTEMP_BT,                    &  ! later on
    4072. 

  4072.                                CII, IIV, CJJ, JJV, CBWGT1, VBWGT1,   &  ! south-western grid locs and weights
    4073. 

  4073.                                CBWGT2, VBWGT2, CBWGT3, VBWGT3,       &  ! note that "C"ourse grid ones are
    4074. 

  4074.                                CBWGT4, VBWGT4                        )  ! dummys
    4075. 

  4075. 

  4076. !     use module_state_description
    4077. 

  4077.      USE module_configure
    4078. 

  4078.      USE module_wrf_error
    4079. 

  4079. 

  4080.      IMPLICIT NONE
    4081. 

  4081. 

  4082. 

  4083.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    4084. 

  4084.                             cims, cime, ckms, ckme, cjms, cjme,   &
    4085. 

  4085.                             cits, cite, ckts, ckte, cjts, cjte,   &
    4086. 

  4086.                             nids, nide, nkds, nkde, njds, njde,   &
    4087. 

  4087.                             nims, nime, nkms, nkme, njms, njme,   &
    4088. 

  4088.                             nits, nite, nkts, nkte, njts, njte,   &
    4089. 

  4089.                             shw,                                  &
    4090. 

  4090.                             ipos, jpos,                           &
    4091. 

  4091.                             nri, nrj
    4092. 

  4092. 

  4093.      LOGICAL, INTENT(IN) :: xstag, ystag
    4094. 

  4094. 

  4095.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
    4096. 

  4096.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
    4097. 

  4097. !
    4098. 

  4098.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: ctemp_b,ctemp_bt
    4099. 

  4099.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: ntemp_b,ntemp_bt
    4100. 

  4100. !
    4101. 

  4101.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    4102. 

  4102.      REAL,  DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye
    4103. 

  4103.      REAL,  DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye
    4104. 

  4104.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    4105. 

  4105.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    4106. 

  4106.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    4107. 

  4107.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV
    4108. 

  4108. 

  4109. ! Local
    4110. 

  4110. 

  4111.      INTEGER :: i,j,k
    4112. 

  4112.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme )    :: cwk1,cwk2,cwk3,cwk4
    4113. 

  4113. 

  4114. !    X start boundary
    4115. 

  4115. 

  4116.        NMM_XS: IF(NITS .EQ. NIDS)THEN
    4117. 

  4117. !      WRITE(0,*)'ENTERING X START BOUNDARY AT VELOCITY POINTS',NITS,NIDS,NJTS,MIN(NJTE,NJDE-1)
    4118. 

  4118.         I = NIDS
    4119. 

  4119.         DO K = NKDS,NKDE
    4120. 

  4120.          DO J = NJTS,MIN(NJTE,NJDE-1)
    4121. 

  4121.               IF(MOD(J,2) .EQ.0)THEN                ! 1,3,5,7 of nested domain
    4122. 

  4122.                 IF(MOD(JJV(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    4123. 

  4123.                    CWK1(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4124. 

  4124.                                + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4125. 

  4125.                                + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) &
    4126. 

  4126.                                + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K)
    4127. 

  4127.                 ELSE
    4128. 

  4128.                    CWK1(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4129. 

  4129.                                + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4130. 

  4130.                                + VBWGT3(I,J)*CFLD(IIV(I,J),  JJV(I,J)-1,K) &
    4131. 

  4131.                                + VBWGT4(I,J)*CFLD(IIV(I,J),  JJV(I,J)+1,K)
    4132. 

  4132.                 ENDIF
    4133. 

  4133.               ELSE
    4134. 

  4134.                 CWK1(I,J,K) = 0.0 ! odd rows along J, at mass points have zero velocity  
    4135. 

  4135.               ENDIF
    4136. 

  4136.               ntemp_b(i,J,K)     = CWK1(I,J,K)
    4137. 

  4137.               ntemp_bt(i,J,K)    = 0.0
    4138. 

  4138.          END DO
    4139. 

  4139.         END DO
    4140. 

  4140.        ENDIF NMM_XS
    4141. 

  4141. 

  4142. !    X end boundary
    4143. 

  4143. 

  4144.        NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
    4145. 

  4145. !        WRITE(0,*)'ENTERING X END BOUNDARY AT VELOCITY POINTS',NITE-1,NIDE-1,NJTS,MIN(NJTE,NJDE-1)
    4146. 

  4146.         I = NIDE-1
    4147. 

  4147.         DO K = NKDS,NKDE
    4148. 

  4148.          DO J = NJTS,MIN(NJTE,NJDE-1)
    4149. 

  4149.               IF(MOD(J,2) .EQ.0)THEN                ! 1,3,5,7 of the nested domain
    4150. 

  4150.                 IF(MOD(JJV(I,J),2) .NE. 0)THEN      ! 1,3,5,7 of the parent domain
    4151. 

  4151.                    CWK2(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4152. 

  4152.                                + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4153. 

  4153.                                + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) &
    4154. 

  4154.                                + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K)
    4155. 

  4155.                 ELSE
    4156. 

  4156.                    CWK2(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4157. 

  4157.                                + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4158. 

  4158.                                + VBWGT3(I,J)*CFLD(IIV(I,J),  JJV(I,J)-1,K) &
    4159. 

  4159.                                + VBWGT4(I,J)*CFLD(IIV(I,J),  JJV(I,J)+1,K)
    4160. 

  4160.                 ENDIF
    4161. 

  4161.               ELSE
    4162. 

  4162.                 CWK2(I,J,K) = 0.0      ! odd rows at mass points
    4163. 

  4163.               ENDIF
    4164. 

  4164.               ntemp_b(i,J,K)     = CWK2(I,J,K)
    4165. 

  4165.               ntemp_bt(i,J,K)    = 0.0
    4166. 

  4166.          END DO
    4167. 

  4167.         END DO
    4168. 

  4168.        ENDIF NMM_XE
    4169. 

  4169. 

  4170. !  Y start boundary
    4171. 

  4171. 

  4172.        NMM_YS: IF(NJTS .EQ. NJDS)THEN
    4173. 

  4173. !        WRITE(0,*)'ENTERING Y START BOUNDARY AT VELOCITY POINTS',NJTS,NJDS,NITS,MIN(NITE,NIDE-1)
    4174. 

  4174.         J = NJDS
    4175. 

  4175.         DO K = NKDS, NKDE
    4176. 

  4176.          DO I = NITS,MIN(NITE,NIDE-2)     ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL 
    4177. 

  4177.               IF(MOD(JJV(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    4178. 

  4178.                  CWK3(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4179. 

  4179.                              + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4180. 

  4180.                              + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) &
    4181. 

  4181.                              + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K)
    4182. 

  4182.               ELSE
    4183. 

  4183.                  CWK3(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4184. 

  4184.                              + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4185. 

  4185.                              + VBWGT3(I,J)*CFLD(IIV(I,J),  JJV(I,J)-1,K) &
    4186. 

  4186.                              + VBWGT4(I,J)*CFLD(IIV(I,J),  JJV(I,J)+1,K)
    4187. 

  4187.               ENDIF
    4188. 

  4188.               ntemp_b(i,J,K)     = CWK3(I,J,K)
    4189. 

  4189.               ntemp_bt(i,J,K)    = 0.0
    4190. 

  4190.          END DO
    4191. 

  4191.         END DO
    4192. 

  4192.        END IF NMM_YS
    4193. 

  4193. 

  4194. ! Y end boundary
    4195. 

  4195. 

  4196.        NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
    4197. 

  4197. !       WRITE(0,*)'ENTERING Y END BOUNDARY AT VELOCITY POINTS',NJTE-1,NJDE-1,NITS,MIN(NITE,NIDE-1)
    4198. 

  4198.         J = NJDE-1
    4199. 

  4199.         DO K = NKDS,NKDE
    4200. 

  4200.          DO I = NITS,MIN(NITE,NIDE-2)   ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL
    4201. 

  4201.               IF(MOD(JJV(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    4202. 

  4202.                  CWK4(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4203. 

  4203.                              + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4204. 

  4204.                              + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) &
    4205. 

  4205.                              + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K)
    4206. 

  4206.               ELSE
    4207. 

  4207.                  CWK4(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J),  JJV(I,J)  ,K) &
    4208. 

  4208.                              + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)  ,K) &
    4209. 

  4209.                              + VBWGT3(I,J)*CFLD(IIV(I,J),  JJV(I,J)-1,K) &
    4210. 

  4210.                              + VBWGT4(I,J)*CFLD(IIV(I,J),  JJV(I,J)+1,K)
    4211. 

  4211.               ENDIF
    4212. 

  4212.               ntemp_b(i,J,K)     = CWK4(I,J,K)
    4213. 

  4213.               ntemp_bt(i,J,K)    = 0.0
    4214. 

  4214.          END DO
    4215. 

  4215.         END DO
    4216. 

  4216.        END IF NMM_YE
    4217. 

  4217. 

  4218.      RETURN
    4219. 

  4219. 

  4220.    END SUBROUTINE nmm_bdy_vinterp
    4221. 

  4221. 

  4222. !
    4223. 

  4223. !=======================================================================================
    4224. 

  4224. ! E grid interpolation: simple copy from parent to mother domain
    4225. 

  4225. !=======================================================================================
    4226. 

  4226. !
    4227. 

  4227. 

  4228.    SUBROUTINE nmm_copy      ( cfld,                                 &  ! CD field
    4229. 

  4229.                               cids, cide, ckds, ckde, cjds, cjde,   &
    4230. 

  4230.                               cims, cime, ckms, ckme, cjms, cjme,   &
    4231. 

  4231.                               cits, cite, ckts, ckte, cjts, cjte,   &
    4232. 

  4232.                               nfld,                                 &  ! ND field
    4233. 

  4233.                               nids, nide, nkds, nkde, njds, njde,   &
    4234. 

  4234.                               nims, nime, nkms, nkme, njms, njme,   &
    4235. 

  4235.                               nits, nite, nkts, nkte, njts, njte,   &
    4236. 

  4236.                               shw,                                  &  ! stencil half width
    4237. 

  4237.                               imask,                                &  ! interpolation mask
    4238. 

  4238.                               xstag, ystag,                         &  ! staggering of field
    4239. 

  4239.                               ipos, jpos,                           &  ! Position of lower left of nest in CD
    4240. 

  4240.                               nri, nrj,                             &  ! nest ratios
    4241. 

  4241.                               CII, IIH, CJJ, JJH                    )
    4242. 

  4242. 

  4243.      USE module_timing
    4244. 

  4244.      IMPLICIT NONE
    4245. 

  4245. 

  4246.      LOGICAL, INTENT(IN) :: xstag, ystag
    4247. 

  4247.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    4248. 

  4248.                             cims, cime, ckms, ckme, cjms, cjme,   &
    4249. 

  4249.                             cits, cite, ckts, ckte, cjts, cjte,   &
    4250. 

  4250.                             nids, nide, nkds, nkde, njds, njde,   &
    4251. 

  4251.                             nims, nime, nkms, nkme, njms, njme,   &
    4252. 

  4252.                             nits, nite, nkts, nkte, njts, njte,   &
    4253. 

  4253.                             shw,                                  &
    4254. 

  4254.                             ipos, jpos,                           &
    4255. 

  4255.                             nri, nrj
    4256. 

  4256.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(IN)    :: cfld
    4257. 

  4257.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(INOUT) :: nfld
    4258. 

  4258.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
    4259. 

  4259.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    4260. 

  4260.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    4261. 

  4261. 

  4262. !    local
    4263. 

  4263.      INTEGER i,j,k
    4264. 

  4264. 

  4265.      DO J=NJTS,MIN(NJTE,NJDE-1)
    4266. 

  4266.        DO K=NKTS,NKTE
    4267. 

  4267.         DO I=NITS,MIN(NITE,NIDE-1)
    4268. 

  4268.            NFLD(I,J,K) = CFLD(IIH(I,J),JJH(I,J),K)
    4269. 

  4269.         ENDDO
    4270. 

  4270.        ENDDO
    4271. 

  4271.      ENDDO
    4272. 

  4272. 

  4273.   RETURN
    4274. 

  4274. 

  4275.   END SUBROUTINE nmm_copy
    4276. 

  4276. !
    4277. 

  4277. !=======================================================================================
    4278. 

  4278. !  E grid test for mass point coincidence
    4279. 

  4279. !=======================================================================================
    4280. 

  4280. !
    4281. 

  4281.   SUBROUTINE test_nmm (cfld,                                 &  ! CD field
    4282. 

  4282.                        cids, cide, ckds, ckde, cjds, cjde,   &
    4283. 

  4283.                        cims, cime, ckms, ckme, cjms, cjme,   &
    4284. 

  4284.                        cits, cite, ckts, ckte, cjts, cjte,   &
    4285. 

  4285.                        nfld,                                 &  ! ND field
    4286. 

  4286.                        nids, nide, nkds, nkde, njds, njde,   &
    4287. 

  4287.                        nims, nime, nkms, nkme, njms, njme,   &
    4288. 

  4288.                        nits, nite, nkts, nkte, njts, njte,   &
    4289. 

  4289.                        shw,                                  & ! stencil half width for interp
    4290. 

  4290.                        imask,                                & ! interpolation mask
    4291. 

  4291.                        xstag, ystag,                         & ! staggering of field
    4292. 

  4292.                        ipos, jpos,                           & ! Position of lower left of nest in CD
    4293. 

  4293.                        nri, nrj,                             & ! nest ratios                        
    4294. 

  4294.                        CII, IIH, CJJ, JJH, CBWGT1, HBWGT1,   & ! south-western grid locs and weights 
    4295. 

  4295.                        CBWGT2, HBWGT2, CBWGT3, HBWGT3,       & ! note that "C"ourse grid ones are
    4296. 

  4296.                        CBWGT4, HBWGT4                        ) ! dummys for weights
    4297. 

  4297.      USE module_timing
    4298. 

  4298.      IMPLICIT NONE
    4299. 

  4299. 

  4300.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    4301. 

  4301.                             cims, cime, ckms, ckme, cjms, cjme,   &
    4302. 

  4302.                             cits, cite, ckts, ckte, cjts, cjte,   &
    4303. 

  4303.                             nids, nide, nkds, nkde, njds, njde,   &
    4304. 

  4304.                             nims, nime, nkms, nkme, njms, njme,   &
    4305. 

  4305.                             nits, nite, nkts, nkte, njts, njte,   &
    4306. 

  4306.                             shw,                                  &
    4307. 

  4307.                             ipos, jpos,                           &
    4308. 

  4308.                             nri, nrj
    4309. 

  4309.      LOGICAL, INTENT(IN) :: xstag, ystag
    4310. 

  4310. 

  4311.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld
    4312. 

  4312.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld
    4313. 

  4313.      REAL,    DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4    ! dummy
    4314. 

  4314.      REAL,    DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    4315. 

  4315.      INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ                        ! dummy
    4316. 

  4316.      INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
    4317. 

  4317.      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
    4318. 

  4318. 

  4319. !    local
    4320. 

  4320.      INTEGER i,j,k
    4321. 

  4321.      REAL,PARAMETER                                :: error=0.0001,error1=1.0
    4322. 

  4322.      REAL                                          :: diff
    4323. 

  4323. !
    4324. 

  4324. !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
    4325. 

  4325. !
    4326. 

  4326.     DO J=NJTS,MIN(NJTE,NJDE-1)
    4327. 

  4327.      DO I=NITS,MIN(NITE,NIDE-1)
    4328. 

  4328.        IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) &
    4329. 

  4329.            CALL wrf_error_fatal ('hpoints:check domain bounds along x' )
    4330. 

  4330.        IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) &
    4331. 

  4331.            CALL wrf_error_fatal ('hpoints:check domain bounds along y' )
    4332. 

  4332.      ENDDO
    4333. 

  4333.     ENDDO
    4334. 

  4334. 

  4335. !
    4336. 

  4336. !*** INDEX CONVENTIONS
    4337. 

  4337. !***                     HBWGT4
    4338. 

  4338. !***                      4
    4339. 

  4339. !***
    4340. 

  4340. !***
    4341. 

  4341. !***
    4342. 

  4342. !***                   h
    4343. 

  4343. !***             1                 2
    4344. 

  4344. !***            HBWGT1             HBWGT2
    4345. 

  4345. !***
    4346. 

  4346. !***
    4347. 

  4347. !***                      3
    4348. 

  4348. !***                     HBWGT3
    4349. 

  4349. 

  4350. 

  4351. !    WRITE(0,*)NITS,MIN(NITE,NIDE-1),CITS,CITE
    4352. 

  4352.      DO J=NJTS,MIN(NJTE,NJDE-1)
    4353. 

  4353.        DO K=NKDS,NKDE
    4354. 

  4354.         DO I=NITS,MIN(NITE,NIDE-1)
    4355. 

  4355.           IF(ABS(1.0-HBWGT1(I,J)) .LE. ERROR)THEN
    4356. 

  4356.              DIFF=ABS(NFLD(I,J,K)-CFLD(IIH(I,J),JJH(I,J),K))
    4357. 

  4357.              IF(DIFF .GT. ERROR)THEN
    4358. 

  4358.               CALL wrf_debug(1,"dyn_nmm: NON-COINCIDENT, NESTED MASS POINT") 
    4359. 

  4359.               WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF 
    4360. 

  4360.              ENDIF
    4361. 

  4361.              IF(DIFF .GT. ERROR1)THEN
    4362. 

  4362.               WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF
    4363. 

  4363.               CALL wrf_error_fatal ('dyn_nmm: NON-COINCIDENT, NESTED MASS POINT')
    4364. 

  4364.              ENDIF
    4365. 

  4365.           ENDIF
    4366. 

  4366.         ENDDO
    4367. 

  4367.        ENDDO
    4368. 

  4368.      ENDDO
    4369. 

  4369. 

  4370.   END SUBROUTINE test_nmm
    4371. 

  4371. 

  4372. !==================================
    4373. 

  4373. ! this is the default function used in nmm feedback at mass points.
    4374. 

  4374. 

  4375.    SUBROUTINE nmm_feedback ( cfld,                                 &  ! CD field
    4376. 

  4376.                            cids, cide, ckds, ckde, cjds, cjde,   &
    4377. 

  4377.                            cims, cime, ckms, ckme, cjms, cjme,   &
    4378. 

  4378.                            cits, cite, ckts, ckte, cjts, cjte,   &
    4379. 

  4379.                            nfld,                                 &  ! ND field
    4380. 

  4380.                            nids, nide, nkds, nkde, njds, njde,   &
    4381. 

  4381.                            nims, nime, nkms, nkme, njms, njme,   &
    4382. 

  4382.                            nits, nite, nkts, nkte, njts, njte,   &
    4383. 

  4383.                            shw,                                  &  ! stencil half width for interp
    4384. 

  4384.                            imask,                                &  ! interpolation mask
    4385. 

  4385.                            xstag, ystag,                         &  ! staggering of field
    4386. 

  4386.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    4387. 

  4387.                            nri, nrj,                             &  ! nest ratios 
    4388. 

  4388.                            CII, IIH, CJJ, JJH,                   &
    4389. 

  4389.                            CBWGT1, HBWGT1, CBWGT2, HBWGT2,       &
    4390. 

  4390.                            CBWGT3, HBWGT3, CBWGT4, HBWGT4        )
    4391. 

  4391.      USE module_configure
    4392. 

  4392.      IMPLICIT NONE
    4393. 

  4393. 

  4394. 

  4395.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    4396. 

  4396.                             cims, cime, ckms, ckme, cjms, cjme,   &
    4397. 

  4397.                             cits, cite, ckts, ckte, cjts, cjte,   &
    4398. 

  4398.                             nids, nide, nkds, nkde, njds, njde,   &
    4399. 

  4399.                             nims, nime, nkms, nkme, njms, njme,   &
    4400. 

  4400.                             nits, nite, nkts, nkte, njts, njte,   &
    4401. 

  4401.                             shw,                                  &
    4402. 

  4402.                             ipos, jpos,                           &
    4403. 

  4403.                             nri, nrj
    4404. 

  4404.      INTEGER,DIMENSION(cims:cime,cjms:cjme),  INTENT(IN)    :: CII,CJJ     ! dummy
    4405. 

  4405.      INTEGER,DIMENSION(nims:nime,njms:njme),  INTENT(IN)    :: IIH,JJH
    4406. 

  4406.      REAL,DIMENSION(cims:cime,cjms:cjme),     INTENT(IN)    :: CBWGT1,CBWGT2,CBWGT3,CBWGT4
    4407. 

  4407.      REAL,DIMENSION(nims:nime,njms:njme),     INTENT(IN)    :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    4408. 

  4408.      LOGICAL, INTENT(IN)                                    :: xstag, ystag
    4409. 

  4409. 

  4410.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: cfld
    4411. 

  4411.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(IN)  :: nfld
    4412. 

  4412.      INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN)           :: imask
    4413. 

  4413. 

  4414.      ! Local
    4415. 

  4415. 

  4416.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
    4417. 

  4417.      INTEGER :: icmin,icmax,jcmin,jcmax
    4418. 

  4418.      INTEGER :: is, ipoints,jpoints,ijpoints
    4419. 

  4419.      INTEGER , PARAMETER :: passes = 2
    4420. 

  4420.      REAL    :: AVGH
    4421. 

  4421. 

  4422. !=====================================================================================
    4423. 

  4423. !
    4424. 

  4424. 

  4425.    IF(nri .ne. 3 .OR. nrj .ne. 3)               &
    4426. 

  4426.     CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist' )
    4427. 

  4427. 

  4428. !  WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR MASS'
    4429. 

  4429. 

  4430.    CFLD = 9999.0
    4431. 

  4431. 

  4432.    DO ck = ckts, ckte
    4433. 

  4433.      nk = ck
    4434. 

  4434.      DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte)  ! exclude top and bottom BCs
    4435. 

  4435.        nj = (cj-jpos)*nrj + 1
    4436. 

  4436.        if(mod(cj,2) .eq. 0)THEN
    4437. 

  4437.          is=0 ! even rows for mass points (2,4,6,8)
    4438. 

  4438.        else
    4439. 

  4439.          is=1 ! odd rows for mass points  (1,3,5,7)
    4440. 

  4440.        endif
    4441. 

  4441.        DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
    4442. 

  4442.          ni = (ci-ipos)*nri + 2 -is
    4443. 

  4443.          IF(IS==0)THEN    ! (2,4,6,8)
    4444. 

  4444. !           AVGH = NFLD(NI,NJ+1,NK)  + NFLD(NI,NJ-1,NK)  + NFLD(NI+1,NJ+1,NK)+ NFLD(NI+1,NJ-1,NK)  &
    4445. 

  4445. !                + NFLD(NI+1,NJ,NK)  + NFLD(NI-1,NJ,NK)  + NFLD(NI,NJ+2,NK)  + NFLD(NI,NJ-2,NK)    &
    4446. 

  4446. !                + NFLD(NI+1,NJ+2,NK)+ NFLD(NI-1,NJ+2,NK)+ NFLD(NI+1,NJ-2,NK)+ NFLD(NI-1,NJ-2,NK)
    4447. 

  4447. 

  4448.           AVGH =                          NFLD(NI,NJ+2,NK)                                       &
    4449. 

  4449.                +          NFLD(NI  ,NJ+1,NK)              + NFLD(NI+1,NJ+1,NK)                   &
    4450. 

  4450.                + NFLD(NI-1,NJ  ,NK)     + NFLD(NI,NJ  ,NK)                 + NFLD(NI+1,NJ  ,NK)  &
    4451. 

  4451.                +          NFLD(NI  ,NJ-1,NK)              + NFLD(NI+1,NJ-1,NK)                   &
    4452. 

  4452.                +                          NFLD(NI,NJ-2,NK)
    4453. 

  4453. 

  4454.          ELSE
    4455. 

  4455. !           AVGH = NFLD(NI,NJ+1,NK)  + NFLD(NI,NJ-1,NK)  + NFLD(NI-1,NJ+1,NK)+ NFLD(NI-1,NJ-1,NK)  &
    4456. 

  4456. !                + NFLD(NI+1,NJ,NK)  + NFLD(NI-1,NJ,NK)  + NFLD(NI,NJ+2,NK)  + NFLD(NI,NJ-2,NK)    &
    4457. 

  4457. !                + NFLD(NI+1,NJ+2,NK)+ NFLD(NI-1,NJ+2,NK)+ NFLD(NI+1,NJ-2,NK)+ NFLD(NI-1,NJ-2,NK)
    4458. 

  4458. 

  4459.           AVGH =                          NFLD(NI,NJ+2,NK)                                       &
    4460. 

  4460.                +          NFLD(NI-1,NJ+1,NK)              + NFLD(NI,NJ+1,NK)                     &
    4461. 

  4461.                + NFLD(NI-1,NJ  ,NK)     + NFLD(NI,NJ  ,NK)                 + NFLD(NI+1,NJ  ,NK)  &
    4462. 

  4462.                +          NFLD(NI-1,NJ-1,NK)              + NFLD(NI,NJ-1,NK)                     &
    4463. 

  4463.                +                          NFLD(NI,NJ-2,NK)
    4464. 

  4464. 

  4465.          ENDIF
    4466. 

  4466. !dusan         CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGH)/13.0
    4467. 

  4467. !         CFLD(CI,CJ,CK) = (NFLD(NI,NJ,NK)+AVGH)/13.0
    4468. 

  4468.        CFLD(CI,CJ,CK) = AVGH/9.0
    4469. 

  4469.        ENDDO
    4470. 

  4470.      ENDDO
    4471. 

  4471.    ENDDO
    4472. 

  4472. 

  4473.    END SUBROUTINE nmm_feedback
    4474. 

  4474. 

  4475. !===========================================================================================
    4476. 

  4476. 

  4477.    SUBROUTINE nmm_vfeedback ( cfld,                              &  ! CD field
    4478. 

  4478.                            cids, cide, ckds, ckde, cjds, cjde,   &
    4479. 

  4479.                            cims, cime, ckms, ckme, cjms, cjme,   &
    4480. 

  4480.                            cits, cite, ckts, ckte, cjts, cjte,   &
    4481. 

  4481.                            nfld,                                 &  ! ND field
    4482. 

  4482.                            nids, nide, nkds, nkde, njds, njde,   &
    4483. 

  4483.                            nims, nime, nkms, nkme, njms, njme,   &
    4484. 

  4484.                            nits, nite, nkts, nkte, njts, njte,   &
    4485. 

  4485.                            shw,                                  &  ! stencil half width for interp
    4486. 

  4486.                            imask,                                &  ! interpolation mask
    4487. 

  4487.                            xstag, ystag,                         &  ! staggering of field
    4488. 

  4488.                            ipos, jpos,                           &  ! Position of lower left of nest in CD
    4489. 

  4489.                            nri, nrj,                             &  ! nest ratios 
    4490. 

  4490.                            CII, IIV, CJJ, JJV,                   &
    4491. 

  4491.                            CBWGT1, VBWGT1, CBWGT2, VBWGT2,       &
    4492. 

  4492.                            CBWGT3, VBWGT3, CBWGT4, VBWGT4        )
    4493. 

  4493.      USE module_configure
    4494. 

  4494.      IMPLICIT NONE
    4495. 

  4495. 

  4496. 

  4497.      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    4498. 

  4498.                             cims, cime, ckms, ckme, cjms, cjme,   &
    4499. 

  4499.                             cits, cite, ckts, ckte, cjts, cjte,   &
    4500. 

  4500.                             nids, nide, nkds, nkde, njds, njde,   &
    4501. 

  4501.                             nims, nime, nkms, nkme, njms, njme,   &
    4502. 

  4502.                             nits, nite, nkts, nkte, njts, njte,   &
    4503. 

  4503.                             shw,                                  &
    4504. 

  4504.                             ipos, jpos,                           &
    4505. 

  4505.                             nri, nrj
    4506. 

  4506.      INTEGER,DIMENSION(cims:cime,cjms:cjme),  INTENT(IN)    :: CII,CJJ     ! dummy
    4507. 

  4507.      INTEGER,DIMENSION(nims:nime,njms:njme),  INTENT(IN)    :: IIV,JJV
    4508. 

  4508.      REAL,DIMENSION(cims:cime,cjms:cjme),     INTENT(IN)    :: CBWGT1,CBWGT2,CBWGT3,CBWGT4
    4509. 

  4509.      REAL,DIMENSION(nims:nime,njms:njme),     INTENT(IN)    :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    4510. 

  4510.      LOGICAL, INTENT(IN)                                    :: xstag, ystag
    4511. 

  4511. 

  4512.      REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: cfld
    4513. 

  4513.      REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(IN)  :: nfld
    4514. 

  4514.      INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN)           :: imask
    4515. 

  4515. 

  4516.      ! Local
    4517. 

  4517. 

  4518.      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
    4519. 

  4519.      INTEGER :: icmin,icmax,jcmin,jcmax
    4520. 

  4520.      INTEGER :: is, ipoints,jpoints,ijpoints
    4521. 

  4521.      INTEGER , PARAMETER :: passes = 2
    4522. 

  4522.      REAL :: AVGV
    4523. 

  4523. 

  4524. !=====================================================================================
    4525. 

  4525. !
    4526. 

  4526. 

  4527.     IF(nri .ne. 3 .OR. nrj .ne. 3)               &
    4528. 

  4528.       CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist')
    4529. 

  4529. 

  4530. !   WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR VELOCITY'
    4531. 

  4531. 

  4532.    CFLD = 9999.0
    4533. 

  4533. 

  4534.    DO ck = ckts, ckte
    4535. 

  4535.     nk = ck
    4536. 

  4536.     DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte)  ! exclude top and bottom BCs
    4537. 

  4537.      nj = (cj-jpos)*nrj + 1
    4538. 

  4538.      if(mod(cj,2) .eq. 0)THEN
    4539. 

  4539.       is=1 ! even rows for velocity points (2,4,6,8) 
    4540. 

  4540.      else
    4541. 

  4541.       is=0 ! odd rows for velocity points (1,3,5,7) 
    4542. 

  4542.      endif
    4543. 

  4543.      DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
    4544. 

  4544.        ni = (ci-ipos)*nri + 2 -is
    4545. 

  4545.          IF(IS==0)THEN    ! (1,3,5,7)
    4546. 

  4546. !          AVGV = NFLD(NI,NK,NJ+1)  + NFLD(NI,NK,NJ-1)  + NFLD(NI+1,NK,NJ+1)+ NFLD(NI+1,NK,NJ-1)  &
    4547. 

  4547. !               + NFLD(NI+1,NK,NJ)  + NFLD(NI-1,NK,NJ)  + NFLD(NI,NK,NJ+2)  + NFLD(NI,NK,NJ-2)    &
    4548. 

  4548. !               + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2)
    4549. 

  4549. 

  4550.           AVGV =                          NFLD(NI,NJ+2,NK)                                       &
    4551. 

  4551.                +          NFLD(NI  ,NJ+1,NK)              + NFLD(NI+1,NJ+1,NK)                   &
    4552. 

  4552.                + NFLD(NI-1,NJ  ,NK)     + NFLD(NI,NJ  ,NK)                 + NFLD(NI+1,NJ  ,NK)  &
    4553. 

  4553.                +          NFLD(NI  ,NJ-1,NK)              + NFLD(NI+1,NJ-1,NK)                   &
    4554. 

  4554.                +                          NFLD(NI,NJ-2,NK)
    4555. 

  4555. 

  4556.          ELSE
    4557. 

  4557. !          AVGV = NFLD(NI,NK,NJ+1)  + NFLD(NI,NK,NJ-1)  + NFLD(NI-1,NK,NJ+1)+ NFLD(NI-1,NK,NJ-1)  &
    4558. 

  4558. !               + NFLD(NI+1,NK,NJ)  + NFLD(NI-1,NK,NJ)  + NFLD(NI,NK,NJ+2)  + NFLD(NI,NK,NJ-2)    &
    4559. 

  4559. !               + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2)
    4560. 

  4560. 

  4561.           AVGV =                          NFLD(NI,NJ+2,NK)                                       &
    4562. 

  4562.                +          NFLD(NI-1,NJ+1,NK)              + NFLD(NI,NJ+1,NK)                     &
    4563. 

  4563.                + NFLD(NI-1,NJ  ,NK)     + NFLD(NI,NJ  ,NK)                 + NFLD(NI+1,NJ  ,NK)  &
    4564. 

  4564.                +          NFLD(NI-1,NJ-1,NK)              + NFLD(NI,NJ-1,NK)                     &
    4565. 

  4565.                +                          NFLD(NI,NJ-2,NK)
    4566. 

  4566. 

  4567.          ENDIF
    4568. 

  4568. !dusan         CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGV)/13.0
    4569. 

  4569. !         CFLD(CI,CK,CJ) = (NFLD(NI,NK,NJ)+AVGV)/13.0
    4570. 

  4570.        CFLD(CI,CJ,CK) = AVGV/9.0
    4571. 

  4571.      ENDDO
    4572. 

  4572.     ENDDO
    4573. 

  4573.    ENDDO
    4574. 

  4574. 

  4575.    END SUBROUTINE nmm_vfeedback 
    4576. 

  4576. 

  4577. 

  4578.    SUBROUTINE nmm_smoother ( cfld , &
    4579. 

  4579.                              cids, cide, ckds, ckde, cjds, cjde,   &
    4580. 

  4580.                              cims, cime, ckms, ckme, cjms, cjme,   &
    4581. 

  4581.                              cits, cite, ckts, ckte, cjts, cjte,   &
    4582. 

  4582.                              nids, nide, nkds, nkde, njds, njde,   &
    4583. 

  4583.                              nims, nime, nkms, nkme, njms, njme,   &
    4584. 

  4584.                              nits, nite, nkts, nkte, njts, njte,   &
    4585. 

  4585.                              xstag, ystag,                         &
    4586. 

  4586.                              ipos, jpos,                           &
    4587. 

  4587.                              nri, nrj                              &
    4588. 

  4588.                              )
    4589. 

  4589. 

  4590.       USE module_configure
    4591. 

  4591.       IMPLICIT NONE
    4592. 

  4592. 

  4593.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    4594. 

  4594.                              cims, cime, ckms, ckme, cjms, cjme,   &
    4595. 

  4595.                              cits, cite, ckts, ckte, cjts, cjte,   &
    4596. 

  4596.                              nids, nide, nkds, nkde, njds, njde,   &
    4597. 

  4597.                              nims, nime, nkms, nkme, njms, njme,   &
    4598. 

  4598.                              nits, nite, nkts, nkte, njts, njte,   &
    4599. 

  4599.                              nri, nrj,                             &
    4600. 

  4600.                              ipos, jpos
    4601. 

  4601.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
    4602. 

  4602.       LOGICAL, INTENT(IN) :: xstag, ystag
    4603. 

  4603. 

  4604. 

  4605.       ! Local
    4606. 

  4606. 

  4607.       INTEGER             :: feedback
    4608. 

  4608.       INTEGER, PARAMETER  :: smooth_passes = 5
    4609. 

  4609. 

  4610.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew
    4611. 

  4611.       INTEGER :: ci, cj, ck
    4612. 

  4612.       INTEGER :: is, npass
    4613. 

  4613.       REAL    :: AVGH
    4614. 

  4614. 

  4615.       RETURN
    4616. 

  4616.       !  If there is no feedback, there can be no smoothing.
    4617. 

  4617. 

  4618.       CALL nl_get_feedback       ( 1, feedback  )
    4619. 

  4619.       IF ( feedback == 0 ) RETURN
    4620. 

  4620. 

  4621.       WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT'
    4622. 

  4622. 

  4623.       DO npass = 1, smooth_passes
    4624. 

  4624. 

  4625.       DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte)  ! exclude top and bottom BCs
    4626. 

  4626.        if(mod(cj,2) .eq. 0)THEN
    4627. 

  4627.         is=0 ! even rows for mass points (2,4,6,8)
    4628. 

  4628.        else
    4629. 

  4629.         is=1 ! odd rows for mass points  (1,3,5,7)
    4630. 

  4630.        endif
    4631. 

  4631.        DO ck = ckts, ckte
    4632. 

  4632.         DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
    4633. 

  4633.             IF(IS==0)THEN    ! (2,4,6,8)
    4634. 

  4634.              AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1)
    4635. 

  4635.             ELSE
    4636. 

  4636.              AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1)
    4637. 

  4637.             ENDIF
    4638. 

  4638.             CFLDNEW(CI,CK,CJ) = (AVGH + 4*CFLD(CI,CK,CJ)) / 8.0
    4639. 

  4639.         ENDDO
    4640. 

  4640.        ENDDO
    4641. 

  4641.       ENDDO
    4642. 

  4642. 

  4643.       DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte)  ! exclude top and bottom BCs
    4644. 

  4644.        if(mod(cj,2) .eq. 0)THEN
    4645. 

  4645.         is=0 ! even rows for mass points (2,4,6,8)
    4646. 

  4646.        else
    4647. 

  4647.         is=1 ! odd rows for mass points  (1,3,5,7)
    4648. 

  4648.        endif
    4649. 

  4649.        DO ck = ckts, ckte
    4650. 

  4650.         DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
    4651. 

  4651.            CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ)
    4652. 

  4652.         ENDDO
    4653. 

  4653.        ENDDO
    4654. 

  4654.       ENDDO
    4655. 

  4655. 

  4656.       ENDDO   ! do npass
    4657. 

  4657. 

  4658.    END SUBROUTINE nmm_smoother
    4659. 

  4659. 

  4660. 

  4661.    SUBROUTINE nmm_vsmoother ( cfld , &
    4662. 

  4662.                              cids, cide, ckds, ckde, cjds, cjde,   &
    4663. 

  4663.                              cims, cime, ckms, ckme, cjms, cjme,   &
    4664. 

  4664.                              cits, cite, ckts, ckte, cjts, cjte,   &
    4665. 

  4665.                              nids, nide, nkds, nkde, njds, njde,   &
    4666. 

  4666.                              nims, nime, nkms, nkme, njms, njme,   &
    4667. 

  4667.                              nits, nite, nkts, nkte, njts, njte,   &
    4668. 

  4668.                              xstag, ystag,                         &
    4669. 

  4669.                              ipos, jpos,                           &
    4670. 

  4670.                              nri, nrj                              &
    4671. 

  4671.                              )
    4672. 

  4672. 

  4673.       USE module_configure
    4674. 

  4674.       IMPLICIT NONE
    4675. 

  4675. 

  4676.       INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
    4677. 

  4677.                              cims, cime, ckms, ckme, cjms, cjme,   &
    4678. 

  4678.                              cits, cite, ckts, ckte, cjts, cjte,   &
    4679. 

  4679.                              nids, nide, nkds, nkde, njds, njde,   &
    4680. 

  4680.                              nims, nime, nkms, nkme, njms, njme,   &
    4681. 

  4681.                              nits, nite, nkts, nkte, njts, njte,   &
    4682. 

  4682.                              nri, nrj,                             &
    4683. 

  4683.                              ipos, jpos
    4684. 

  4684.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
    4685. 

  4685.       LOGICAL, INTENT(IN) :: xstag, ystag
    4686. 

  4686. 

  4687. 

  4688.       ! Local
    4689. 

  4689. 

  4690.       INTEGER             :: feedback
    4691. 

  4691.       INTEGER, PARAMETER  :: smooth_passes = 5
    4692. 

  4692. 

  4693.       REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew
    4694. 

  4694.       INTEGER :: ci, cj, ck
    4695. 

  4695.       INTEGER :: is, npass
    4696. 

  4696.       REAL    :: AVGV
    4697. 

  4697. 

  4698.       RETURN
    4699. 

  4699.       !  If there is no feedback, there can be no smoothing.
    4700. 

  4700. 

  4701.       CALL nl_get_feedback       ( 1, feedback  )
    4702. 

  4702.       IF ( feedback == 0 ) RETURN
    4703. 

  4703. 

  4704.       WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR VELOCITY'
    4705. 

  4705. 

  4706.       DO npass = 1, smooth_passes
    4707. 

  4707. 

  4708.       DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte)  ! exclude top and bottom BCs
    4709. 

  4709.        if(mod(cj,2) .eq. 0)THEN
    4710. 

  4710.         is=1 ! even rows for mass points (2,4,6,8)
    4711. 

  4711.        else
    4712. 

  4712.         is=0 ! odd rows for mass points  (1,3,5,7)
    4713. 

  4713.        endif
    4714. 

  4714.        DO ck = ckts, ckte
    4715. 

  4715.         DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
    4716. 

  4716.             IF(IS==0)THEN    ! (2,4,6,8)
    4717. 

  4717.              AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1)
    4718. 

  4718.             ELSE
    4719. 

  4719.              AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1)
    4720. 

  4720.             ENDIF
    4721. 

  4721.             CFLDNEW(CI,CK,CJ) = (AVGV + 4*CFLD(CI,CK,CJ)) / 8.0
    4722. 

  4722.         ENDDO
    4723. 

  4723.        ENDDO
    4724. 

  4724.       ENDDO
    4725. 

  4725. 

  4726.       DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte)  ! exclude top and bottom BCs
    4727. 

  4727.        if(mod(cj,2) .eq. 0)THEN
    4728. 

  4728.         is=1 ! even rows for mass points (2,4,6,8)
    4729. 

  4729.        else
    4730. 

  4730.         is=0 ! odd rows for mass points  (1,3,5,7)
    4731. 

  4731.        endif
    4732. 

  4732.        DO ck = ckts, ckte
    4733. 

  4733.         DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
    4734. 

  4734.            CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ)
    4735. 

  4735.         ENDDO
    4736. 

  4736.        ENDDO
    4737. 

  4737.       ENDDO
    4738. 

  4738. 

  4739.       ENDDO
    4740. 

  4740. 

  4741.    END SUBROUTINE nmm_vsmoother
    4742. 

  4742. !======================================================================================
    4743. 

  4743. !   End of gopal's doing
    4744. 

  4744. !======================================================================================
    4745. 

  4745. #endif
    4746. 

  4746.