PageRenderTime 80ms CodeModel.GetById 38ms 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

Large files files are truncated, but you can click here to view the full file

    

  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 n…
    1051.

Large files files are truncated, but you can click here to view the full file