PageRenderTime 61ms CodeModel.GetById 16ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/share/module_bc.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 3400 lines | 2558 code | 521 blank | 321 comment | 148 complexity | 29e913f4d91363971266041ed6c69a14 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:MODEL_LAYER:BOUNDARY
    2. 

  2. !
    3. 

  3. 

  4. MODULE module_bc
    5. 

  5. 

  6.    USE module_configure
    7. 

  7.    USE module_wrf_error
    8. 

  8.    USE module_model_constants
    9. 

  9.    IMPLICIT NONE
    10. 

  10. 

  11. !   TYPE bcs
    12. 

  12. !
    13. 

  13. !     LOGICAL                     :: periodic_x
    14. 

  14. !     LOGICAL                     :: symmetric_xs
    15. 

  15. !     LOGICAL                     :: symmetric_xe
    16. 

  16. !     LOGICAL                     :: open_xs
    17. 

  17. !     LOGICAL                     :: open_xe
    18. 

  18. !     LOGICAL                     :: periodic_y
    19. 

  19. !     LOGICAL                     :: symmetric_ys
    20. 

  20. !     LOGICAL                     :: symmetric_ye
    21. 

  21. !     LOGICAL                     :: open_ys
    22. 

  22. !     LOGICAL                     :: open_ye
    23. 

  23. !     LOGICAL                     :: nested
    24. 

  24. !     LOGICAL                     :: specified
    25. 

  25. !     LOGICAL                     :: top_radiation
    26. 

  26. !
    27. 

  27. !   END TYPE bcs
    28. 

  28. 

  29. !  set the bdyzone.  We are hardwiring this here and we'll
    30. 

  30. !  decide later where it should be set and stored
    31. 

  31. 

  32.    INTEGER, PARAMETER            :: bdyzone = 4
    33. 

  33.    INTEGER, PARAMETER            :: bdyzone_x = bdyzone
    34. 

  34.    INTEGER, PARAMETER            :: bdyzone_y = bdyzone
    35. 

  35. 

  36.    INTERFACE stuff_bdy
    37. 

  37.      MODULE PROCEDURE stuff_bdy_new , stuff_bdy_old
    38. 

  38.    END INTERFACE
    39. 

  39. 

  40.    INTERFACE stuff_bdytend
    41. 

  41.      MODULE PROCEDURE stuff_bdytend_new , stuff_bdytend_old
    42. 

  42.    END INTERFACE
    43. 

  43. 

  44. CONTAINS
    45. 

  45. 

  46.   SUBROUTINE boundary_condition_check ( config_flags, bzone, error, gn )
    47. 

  47. 

  48. !  this routine checks the boundary condition logicals 
    49. 

  49. !  to make sure that the boundary conditions are not over
    50. 

  50. !  or under specified.  The routine also checks that the
    51. 

  51. !  boundary zone is sufficiently sized for the specified
    52. 

  52. !  boundary conditions
    53. 

  53. 

  54.   IMPLICIT NONE
    55. 

  55. 

  56.   TYPE( grid_config_rec_type ) config_flags
    57. 

  57. 

  58.   INTEGER, INTENT(IN   ) :: bzone, gn
    59. 

  59.   INTEGER, INTENT(INOUT) :: error
    60. 

  60. 

  61. ! local variables
    62. 

  62. 

  63.   INTEGER :: xs_bc, xe_bc, ys_bc, ye_bc, bzone_min
    64. 

  64.   INTEGER :: nprocx, nprocy
    65. 

  65. 

  66.   CALL wrf_debug( 100 , ' checking boundary conditions for grid ' )
    67. 

  67. 

  68.   error = 0
    69. 

  69.   xs_bc = 0
    70. 

  70.   xe_bc = 0
    71. 

  71.   ys_bc = 0
    72. 

  72.   ye_bc = 0
    73. 

  73. 

  74. !  sum the number of conditions specified for each lateral boundary.
    75. 

  75. !  obviously, this number should be 1
    76. 

  76. 

  77.   IF( config_flags%periodic_x ) THEN
    78. 

  78.     xs_bc = xs_bc+1
    79. 

  79.     xe_bc = xe_bc+1
    80. 

  80.   ENDIF
    81. 

  81. 

  82.   IF( config_flags%periodic_y ) THEN
    83. 

  83.     ys_bc = ys_bc+1
    84. 

  84.     ye_bc = ye_bc+1
    85. 

  85.   ENDIF
    86. 

  86. 

  87.   IF( config_flags%symmetric_xs ) xs_bc = xs_bc + 1
    88. 

  88.   IF( config_flags%symmetric_xe ) xe_bc = xe_bc + 1
    89. 

  89.   IF( config_flags%open_xs )      xs_bc = xs_bc + 1
    90. 

  90.   IF( config_flags%open_xe )      xe_bc = xe_bc + 1
    91. 

  91. 

  92. 

  93.   IF( config_flags%symmetric_ys ) ys_bc = ys_bc + 1
    94. 

  94.   IF( config_flags%symmetric_ye ) ye_bc = ye_bc + 1
    95. 

  95.   IF( config_flags%open_ys )      ys_bc = ys_bc + 1
    96. 

  96.   IF( config_flags%open_ye )      ye_bc = ye_bc + 1
    97. 

  97. 

  98.   IF( config_flags%nested ) THEN
    99. 

  99.      xs_bc = xs_bc + 1
    100. 

  100.      xe_bc = xe_bc + 1
    101. 

  101.      ys_bc = ys_bc + 1
    102. 

  102.      ye_bc = ye_bc + 1
    103. 

  103.    ENDIF
    104. 

  104. 

  105.   IF( config_flags%specified ) THEN
    106. 

  106.      IF( .NOT. config_flags%periodic_x)xs_bc = xs_bc + 1
    107. 

  107.      IF( .NOT. config_flags%periodic_x)xe_bc = xe_bc + 1
    108. 

  108.      ys_bc = ys_bc + 1
    109. 

  109.      ye_bc = ye_bc + 1
    110. 

  110.    ENDIF
    111. 

  111. 

  112.   IF( config_flags%polar ) THEN
    113. 

  113.      ys_bc = ys_bc + 1
    114. 

  114.      ye_bc = ye_bc + 1
    115. 

  115.    ENDIF
    116. 

  116. 

  117. !  check the number of conditions for each boundary
    118. 

  118. 

  119.    IF( (xs_bc /= 1) .or. &
    120. 

  120.        (xe_bc /= 1) .or. &
    121. 

  121.        (ys_bc /= 1) .or. &
    122. 

  122.        (ye_bc /= 1)         ) THEN
    123. 

  123. 

  124.      error = 1
    125. 

  125. 

  126.      write( wrf_err_message ,*) ' *** Error in boundary condition specification '
    127. 

  127.      CALL wrf_message ( wrf_err_message )
    128. 

  128.      write( wrf_err_message ,*) ' boundary conditions at xs ', xs_bc
    129. 

  129.      CALL wrf_message ( wrf_err_message )
    130. 

  130.      write( wrf_err_message ,*) ' boundary conditions at xe ', xe_bc
    131. 

  131.      CALL wrf_message ( wrf_err_message )
    132. 

  132.      write( wrf_err_message ,*) ' boundary conditions at ys ', ys_bc
    133. 

  133.      CALL wrf_message ( wrf_err_message )
    134. 

  134.      write( wrf_err_message ,*) ' boundary conditions at ye ', ye_bc
    135. 

  135.      CALL wrf_message ( wrf_err_message )
    136. 

  136.      write( wrf_err_message ,*) ' boundary conditions logicals are '
    137. 

  137.      CALL wrf_message ( wrf_err_message )
    138. 

  138.      write( wrf_err_message ,*) ' periodic_x   ',config_flags%periodic_x
    139. 

  139.      CALL wrf_message ( wrf_err_message )
    140. 

  140.      write( wrf_err_message ,*) ' periodic_y   ',config_flags%periodic_y
    141. 

  141.      CALL wrf_message ( wrf_err_message )
    142. 

  142.      write( wrf_err_message ,*) ' symmetric_xs ',config_flags%symmetric_xs
    143. 

  143.      CALL wrf_message ( wrf_err_message )
    144. 

  144.      write( wrf_err_message ,*) ' symmetric_xe ',config_flags%symmetric_xe
    145. 

  145.      CALL wrf_message ( wrf_err_message )
    146. 

  146.      write( wrf_err_message ,*) ' symmetric_ys ',config_flags%symmetric_ys
    147. 

  147.      CALL wrf_message ( wrf_err_message )
    148. 

  148.      write( wrf_err_message ,*) ' symmetric_ye ',config_flags%symmetric_ye
    149. 

  149.      CALL wrf_message ( wrf_err_message )
    150. 

  150.      write( wrf_err_message ,*) ' open_xs      ',config_flags%open_xs
    151. 

  151.      CALL wrf_message ( wrf_err_message )
    152. 

  152.      write( wrf_err_message ,*) ' open_xe      ',config_flags%open_xe
    153. 

  153.      CALL wrf_message ( wrf_err_message )
    154. 

  154.      write( wrf_err_message ,*) ' open_ys      ',config_flags%open_ys
    155. 

  155.      CALL wrf_message ( wrf_err_message )
    156. 

  156.      write( wrf_err_message ,*) ' open_ye      ',config_flags%open_ye
    157. 

  157.      CALL wrf_message ( wrf_err_message )
    158. 

  158.      write( wrf_err_message ,*) ' polar        ',config_flags%polar
    159. 

  159.      CALL wrf_message ( wrf_err_message )
    160. 

  160.      write( wrf_err_message ,*) ' nested       ',config_flags%nested
    161. 

  161.      CALL wrf_message ( wrf_err_message )
    162. 

  162.      write( wrf_err_message ,*) ' specified    ',config_flags%specified
    163. 

  163.      CALL wrf_message ( wrf_err_message )
    164. 

  164.      CALL wrf_error_fatal( ' *** Error in boundary condition specification ' )
    165. 

  165. 

  166.    ENDIF
    167. 

  167. 

  168. !  now check to see if boundary zone size is sufficient.
    169. 

  169. !  we could have the necessary boundary zone size be returned
    170. 

  170. !  to the calling routine.
    171. 

  171. 

  172.    IF( config_flags%periodic_x   .or. &
    173. 

  173.        config_flags%periodic_y   .or. &
    174. 

  174.        config_flags%symmetric_xs .or. &
    175. 

  175.        config_flags%symmetric_xe .or. &
    176. 

  176.        config_flags%symmetric_ys .or. &
    177. 

  177.        config_flags%symmetric_ye        )  THEN
    178. 

  178. 

  179.        bzone_min = MAX( 1,                                  &
    180. 

  180.                         (config_flags%h_mom_adv_order+1)/2, &
    181. 

  181.                         (config_flags%h_sca_adv_order+1)/2 )
    182. 

  182. 

  183.        IF( bzone < bzone_min) THEN  
    184. 

  184. 

  185.          error = 2
    186. 

  186.          WRITE ( wrf_err_message , * ) ' boundary zone not large enough '
    187. 

  187.          CALL wrf_message ( wrf_err_message )
    188. 

  188.          WRITE ( wrf_err_message , * ) ' boundary zone specified      ',bzone
    189. 

  189.          CALL wrf_message ( wrf_err_message )
    190. 

  190.          WRITE ( wrf_err_message , * ) ' minimum boundary zone needed ',bzone_min
    191. 

  191.          CALL wrf_error_fatal ( wrf_err_message )
    192. 

  192. 

  193.        ENDIF
    194. 

  194.    ENDIF
    195. 

  195. 

  196.    CALL wrf_debug ( 100 , ' boundary conditions OK for grid ' )
    197. 

  197. 

  198.    END subroutine boundary_condition_check
    199. 

  199. 

  200. !--------------------------------------------------------------------------
    201. 

  201.    SUBROUTINE set_physical_bc2d( dat, variable_in,  &
    202. 

  202.                                  config_flags,           & 
    203. 

  203.                                  ids,ide, jds,jde,   & ! domain dims
    204. 

  204.                                  ims,ime, jms,jme,   & ! memory dims
    205. 

  205.                                  ips,ipe, jps,jpe,   & ! patch  dims
    206. 

  206.                                  its,ite, jts,jte   )      
    207. 

  207. 

  208. !  This subroutine sets the data in the boundary region, by direct
    209. 

  209. !  assignment if possible, for periodic and symmetric (wall)
    210. 

  210. !  boundary conditions.  Currently, we are only doing 1 variable
    211. 

  211. !  at a time - lots of overhead, so maybe this routine can be easily 
    212. 

  212. !  inlined later or we could pass multiple variables -
    213. 

  213. !  would probably want a largestep and smallstep version.
    214. 

  214. 

  215. !  15 Jan 99, Dave
    216. 

  216. !  Modified the incoming its,ite,jts,jte to truly be the tile size.
    217. 

  217. !  This required modifying the loop limits when the "istag" or "jstag"
    218. 

  218. !  is used, as this is only required at the end of the domain.
    219. 

  219. 

  220.       IMPLICIT NONE
    221. 

  221. 

  222.       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde
    223. 

  223.       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme
    224. 

  224.       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe
    225. 

  225.       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte
    226. 

  226.       CHARACTER,    INTENT(IN   )    :: variable_in
    227. 

  227. 

  228.       CHARACTER                      :: variable
    229. 

  229. 

  230.       REAL,  DIMENSION( ims:ime , jms:jme ) :: dat
    231. 

  231.       TYPE( grid_config_rec_type ) config_flags
    232. 

  232. 

  233.       INTEGER  :: i, j, istag, jstag, itime
    234. 

  234. 

  235.       LOGICAL  :: debug, open_bc_copy
    236. 

  236. 

  237. !------------
    238. 

  238. 

  239.       debug = .false.
    240. 

  240. 

  241.       open_bc_copy = .false.
    242. 

  242. 

  243.       variable = variable_in
    244. 

  244.       IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
    245. 

  245.         variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
    246. 

  246.       ENDIF
    247. 

  247.       IF ((variable == 'u') .or. (variable == 'v') .or.  &
    248. 

  248.           (variable == 'w') .or. (variable == 't') .or.  &
    249. 

  249.           (variable == 'x') .or. (variable == 'y') .or.  &
    250. 

  250.           (variable == 'r') .or. (variable == 'p') ) open_bc_copy = .true.
    251. 

  251. 

  252. !  begin, first set a staggering variable
    253. 

  253. 

  254.       istag = -1
    255. 

  255.       jstag = -1
    256. 

  256. 

  257.       IF ((variable == 'u') .or. (variable == 'x')) istag = 0
    258. 

  258.       IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
    259. 

  259. 

  260.       if(debug) then
    261. 

  261.         write(6,*) ' in bc2d, var is ',variable, istag, jstag
    262. 

  262.         write(6,*) ' b.cs are ',  &
    263. 

  263.       config_flags%periodic_x,  &
    264. 

  264.       config_flags%periodic_y
    265. 

  265.       end if
    266. 

  266.       
    267. 

  267.       IF ( variable == 'd' ) then  !JDM
    268. 

  268.          istag = 0
    269. 

  269.          jstag = 0
    270. 

  270.       ENDIF
    271. 

  271.       IF ( variable == 'e' ) then  !JDM
    272. 

  272.          istag = 0
    273. 

  273.       ENDIF
    274. 

  274.       IF ( variable == 'f' ) then  !JDM
    275. 

  275.          jstag = 0
    276. 

  276.       ENDIF
    277. 

  277. 

  278. !  periodic conditions.
    279. 

  279. !  note, patch must cover full range in periodic dir, or else
    280. 

  280. !  its intra-patch communication that is handled elsewheres.
    281. 

  281. !  symmetry conditions can always be handled here, because no
    282. 

  282. !  outside patch communication is needed
    283. 

  283. 

  284.       periodicity_x:  IF( ( config_flags%periodic_x ) ) THEN 
    285. 

  285.         IF ( ( ids == ips ) .and.  ( ide == ipe ) ) THEN  ! test if east and west both on-processor 
    286. 

  286.           IF ( its == ids ) THEN
    287. 

  287. 

  288.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    289. 

  289.             DO i = 0,-(bdyzone-1),-1
    290. 

  290.               dat(ids+i-1,j) = dat(ide+i-1,j)
    291. 

  291.             ENDDO
    292. 

  292.             ENDDO
    293. 

  293. 

  294.           ENDIF
    295. 

  295. 

  296.           IF ( ite == ide ) THEN
    297. 

  297. 

  298.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    299. 

  299. !!          DO i = 1 , bdyzone
    300. 

  300.             DO i = -istag , bdyzone
    301. 

  301.               dat(ide+i+istag,j) = dat(ids+i+istag,j)
    302. 

  302.             ENDDO
    303. 

  303.             ENDDO
    304. 

  304. 

  305.           ENDIF
    306. 

  306.         ENDIF
    307. 

  307. 

  308.       ELSE 
    309. 

  309. 

  310.         symmetry_xs: IF( ( config_flags%symmetric_xs ) .and.  &
    311. 

  311.                          ( its == ids )                  )  THEN
    312. 

  312. 

  313.           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
    314. 

  314. 

  315.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    316. 

  316.             DO i = 1, bdyzone
    317. 

  317.               dat(ids-i,j) = dat(ids+i-1,j) !  here, dat(0) = dat(1), etc
    318. 

  318.             ENDDO                             !  symmetry about dat(0.5) (u=0 pt)
    319. 

  319.             ENDDO
    320. 

  320. 

  321.           ELSE
    322. 

  322. 

  323.             IF( variable == 'u' ) THEN
    324. 

  324. 

  325.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    326. 

  326.               DO i = 0, bdyzone-1
    327. 

  327.                 dat(ids-i,j) = - dat(ids+i,j) ! here, u(0) = - u(2), etc
    328. 

  328.               ENDDO                             !  normal b.c symmetry at u(1)
    329. 

  329.               ENDDO
    330. 

  330. 

  331.             ELSE
    332. 

  332. 

  333.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    334. 

  334.               DO i = 0, bdyzone-1
    335. 

  335.                 dat(ids-i,j) =   dat(ids+i,j) ! here, phi(0) = phi(2), etc
    336. 

  336.               ENDDO                             !  normal b.c symmetry at phi(1)
    337. 

  337.               ENDDO
    338. 

  338. 

  339.             END IF
    340. 

  340. 

  341.           ENDIF
    342. 

  342. 

  343.         ENDIF symmetry_xs
    344. 

  344. 

  345. 

  346. !  now the symmetry boundary at xe
    347. 

  347. 

  348.         symmetry_xe: IF( ( config_flags%symmetric_xe ) .and.  &
    349. 

  349.                          ( ite == ide )                  )  THEN
    350. 

  350. 

  351.           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
    352. 

  352. 

  353.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    354. 

  354.             DO i = 1, bdyzone
    355. 

  355.               dat(ide+i-1,j) = dat(ide-i,j)  !  sym. about dat(ide-0.5)
    356. 

  356.             ENDDO
    357. 

  357.             ENDDO
    358. 

  358. 

  359.           ELSE
    360. 

  360. 

  361.             IF (variable == 'u' ) THEN
    362. 

  362. 

  363.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    364. 

  364.               DO i = 0, bdyzone-1
    365. 

  365.                 dat(ide+i,j) = - dat(ide-i,j)  ! u(ide+1) = - u(ide-1), etc.
    366. 

  366.               ENDDO
    367. 

  367.               ENDDO
    368. 

  368. 

  369. 

  370.             ELSE
    371. 

  371. 

  372.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    373. 

  373.               DO i = 0, bdyzone-1
    374. 

  374.                 dat(ide+i,j) = dat(ide-i,j)  !  phi(ide+1) = phi(ide-1), etc.
    375. 

  375.               ENDDO
    376. 

  376.               ENDDO
    377. 

  377. 

  378.             END IF
    379. 

  379. 

  380.           END IF 
    381. 

  381. 

  382.         END IF symmetry_xe
    383. 

  383. 

  384. 

  385. !  set open b.c in X copy into boundary zone here.  WCS, 19 March 2000
    386. 

  386. 

  387.         open_xs: IF( ( config_flags%open_xs   .or. &
    388. 

  388.                        config_flags%specified .or. &
    389. 

  389.                        config_flags%nested            ) .and.  &
    390. 

  390.                          ( its == ids ) .and. open_bc_copy  )  THEN
    391. 

  391. 

  392.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    393. 

  393.               dat(ids-1,j) = dat(ids,j) !  here, dat(0) = dat(1)
    394. 

  394.               dat(ids-2,j) = dat(ids,j)
    395. 

  395.               dat(ids-3,j) = dat(ids,j)
    396. 

  396.             ENDDO
    397. 

  397. 

  398.         ENDIF open_xs
    399. 

  399. 

  400. 

  401. !  now the open boundary copy at xe
    402. 

  402. 

  403.         open_xe: IF( ( config_flags%open_xe   .or. &
    404. 

  404.                        config_flags%specified .or. &
    405. 

  405.                        config_flags%nested            ) .and.  &
    406. 

  406.                           ( ite == ide ) .and. open_bc_copy  )  THEN
    407. 

  407. 

  408.           IF ( variable /= 'u' .and. variable /= 'x') THEN
    409. 

  409. 

  410.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    411. 

  411.               dat(ide  ,j) = dat(ide-1,j) 
    412. 

  412.               dat(ide+1,j) = dat(ide-1,j) 
    413. 

  413.               dat(ide+2,j) = dat(ide-1,j) 
    414. 

  414.             ENDDO
    415. 

  415. 

  416.           ELSE
    417. 

  417. 

  418.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    419. 

  419.               dat(ide+1,j) = dat(ide,j)
    420. 

  420.               dat(ide+2,j) = dat(ide,j)
    421. 

  421.               dat(ide+3,j) = dat(ide,j)
    422. 

  422.             ENDDO
    423. 

  423. 

  424.           END IF 
    425. 

  425. 

  426.         END IF open_xe
    427. 

  427. 

  428. !  end open b.c in X copy into boundary zone addition.  WCS, 19 March 2000
    429. 

  429. 

  430.       END IF periodicity_x
    431. 

  431. 

  432. !  same procedure in y
    433. 

  433. 

  434.       periodicity_y:  IF( ( config_flags%periodic_y ) ) THEN
    435. 

  435.         IF ( ( jds == jps ) .and. ( jde == jpe ) )  THEN    ! test of both north and south on processor
    436. 

  436. 

  437.           IF( jts == jds ) then
    438. 

  438. 

  439.             DO j = 0, -(bdyzone-1), -1
    440. 

  440.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    441. 

  441.               dat(i,jds+j-1) = dat(i,jde+j-1)
    442. 

  442.             ENDDO
    443. 

  443.             ENDDO
    444. 

  444. 

  445.           END IF
    446. 

  446. 

  447.           IF( jte == jde ) then
    448. 

  448. 

  449.             DO j = -jstag, bdyzone
    450. 

  450.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    451. 

  451.               dat(i,jde+j+jstag) = dat(i,jds+j+jstag)
    452. 

  452.             ENDDO
    453. 

  453.             ENDDO
    454. 

  454. 

  455.           END IF
    456. 

  456. 

  457.         END IF
    458. 

  458. 

  459.       ELSE
    460. 

  460. 

  461.         symmetry_ys: IF( ( config_flags%symmetric_ys ) .and.  &
    462. 

  462.                          ( jts == jds)                   )  THEN
    463. 

  463. 

  464.           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
    465. 

  465. 

  466.             DO j = 1, bdyzone
    467. 

  467.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    468. 

  468.               dat(i,jds-j) = dat(i,jds+j-1) 
    469. 

  469.             ENDDO
    470. 

  470.             ENDDO
    471. 

  471. 

  472.           ELSE
    473. 

  473. 

  474.             IF (variable == 'v') THEN
    475. 

  475. 

  476.               DO j = 1, bdyzone
    477. 

  477.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    478. 

  478.                 dat(i,jds-j) = - dat(i,jds+j) 
    479. 

  479.               ENDDO              
    480. 

  480.               ENDDO
    481. 

  481. 

  482.             ELSE
    483. 

  483. 

  484.               DO j = 1, bdyzone
    485. 

  485.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    486. 

  486.                 dat(i,jds-j) = dat(i,jds+j) 
    487. 

  487.               ENDDO              
    488. 

  488.               ENDDO
    489. 

  489. 

  490.             END IF
    491. 

  491. 

  492.           ENDIF
    493. 

  493. 

  494.         ENDIF symmetry_ys
    495. 

  495. 

  496. !  now the symmetry boundary at ye
    497. 

  497. 

  498.         symmetry_ye: IF( ( config_flags%symmetric_ye ) .and.  &
    499. 

  499.                          ( jte == jde )                  )  THEN
    500. 

  500. 

  501.           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
    502. 

  502. 

  503.             DO j = 1, bdyzone
    504. 

  504.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    505. 

  505.               dat(i,jde+j-1) = dat(i,jde-j) 
    506. 

  506.             ENDDO                               
    507. 

  507.             ENDDO
    508. 

  508. 

  509.           ELSE
    510. 

  510. 

  511.             IF (variable == 'v' ) THEN
    512. 

  512. 

  513.               DO j = 1, bdyzone
    514. 

  514.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    515. 

  515.                 dat(i,jde+j) = - dat(i,jde-j)    ! bugfix: changed jds on rhs to jde , JM 20020410
    516. 

  516.               ENDDO                               
    517. 

  517.               ENDDO
    518. 

  518. 

  519.             ELSE
    520. 

  520. 

  521.               DO j = 1, bdyzone
    522. 

  522.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    523. 

  523.                 dat(i,jde+j) = dat(i,jde-j)
    524. 

  524.               ENDDO                               
    525. 

  525.               ENDDO
    526. 

  526. 

  527.             END IF
    528. 

  528. 

  529.           ENDIF
    530. 

  530. 

  531.         END IF symmetry_ye
    532. 

  532. 

  533. !  set open b.c in Y copy into boundary zone here.  WCS, 19 March 2000
    534. 

  534. 

  535.         open_ys: IF( ( config_flags%open_ys   .or. &
    536. 

  536.                        config_flags%polar     .or. &
    537. 

  537.                        config_flags%specified .or. &
    538. 

  538.                        config_flags%nested            ) .and.  &
    539. 

  539.                          ( jts == jds) .and. open_bc_copy )  THEN
    540. 

  540. 

  541.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    542. 

  542.               dat(i,jds-1) = dat(i,jds) 
    543. 

  543.               dat(i,jds-2) = dat(i,jds) 
    544. 

  544.               dat(i,jds-3) = dat(i,jds) 
    545. 

  545.             ENDDO
    546. 

  546. 

  547.         ENDIF open_ys
    548. 

  548. 

  549. !  now the open boundary copy at ye
    550. 

  550. 

  551.         open_ye: IF( ( config_flags%open_ye   .or. &
    552. 

  552.                        config_flags%polar     .or. &
    553. 

  553.                        config_flags%specified .or. &
    554. 

  554.                        config_flags%nested            ) .and.  &
    555. 

  555.                          ( jte == jde ) .and. open_bc_copy )  THEN
    556. 

  556. 

  557.           IF  (variable /= 'v' .and. variable /= 'y' ) THEN
    558. 

  558. 

  559.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    560. 

  560.               dat(i,jde  ) = dat(i,jde-1) 
    561. 

  561.               dat(i,jde+1) = dat(i,jde-1) 
    562. 

  562.               dat(i,jde+2) = dat(i,jde-1) 
    563. 

  563.             ENDDO                               
    564. 

  564. 

  565.           ELSE
    566. 

  566. 

  567.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    568. 

  568.               dat(i,jde+1) = dat(i,jde) 
    569. 

  569.               dat(i,jde+2) = dat(i,jde) 
    570. 

  570.               dat(i,jde+3) = dat(i,jde) 
    571. 

  571.             ENDDO                               
    572. 

  572. 

  573.           ENDIF
    574. 

  574. 

  575.         END IF open_ye
    576. 

  576.       
    577. 

  577. !  end open b.c in Y copy into boundary zone addition.  WCS, 19 March 2000
    578. 

  578. 

  579.       END IF periodicity_y
    580. 

  580. 

  581. !  fix corners for doubly periodic domains
    582. 

  582. 

  583.       IF ( config_flags%periodic_x .and. config_flags%periodic_y &
    584. 

  584.            .and. (ids == ips) .and. (ide == ipe)                 &
    585. 

  585.            .and. (jds == jps) .and. (jde == jpe)                   ) THEN
    586. 

  586. 

  587.          IF ( (its == ids) .and. (jts == jds) ) THEN  ! lower left corner fill
    588. 

  588.            DO j = 0, -(bdyzone-1), -1
    589. 

  589.            DO i = 0, -(bdyzone-1), -1
    590. 

  590.              dat(ids+i-1,jds+j-1) = dat(ide+i-1,jde+j-1)
    591. 

  591.            ENDDO
    592. 

  592.            ENDDO
    593. 

  593.          END IF
    594. 

  594. 

  595.          IF ( (ite == ide) .and. (jts == jds) ) THEN  ! lower right corner fill
    596. 

  596.            DO j = 0, -(bdyzone-1), -1
    597. 

  597.            DO i = 1, bdyzone
    598. 

  598.              dat(ide+i+istag,jds+j-1) = dat(ids+i+istag,jde+j-1)
    599. 

  599.            ENDDO
    600. 

  600.            ENDDO
    601. 

  601.          END IF
    602. 

  602. 

  603.          IF ( (ite == ide) .and. (jte == jde) ) THEN  ! upper right corner fill
    604. 

  604.            DO j = 1, bdyzone
    605. 

  605.            DO i = 1, bdyzone
    606. 

  606.              dat(ide+i+istag,jde+j+jstag) = dat(ids+i+istag,jds+j+jstag)
    607. 

  607.            ENDDO
    608. 

  608.            ENDDO
    609. 

  609.          END IF
    610. 

  610. 

  611.          IF ( (its == ids) .and. (jte == jde) ) THEN  ! upper left corner fill
    612. 

  612.            DO j = 1, bdyzone
    613. 

  613.            DO i = 0, -(bdyzone-1), -1
    614. 

  614.              dat(ids+i-1,jde+j+jstag) = dat(ide+i-1,jds+j+jstag)
    615. 

  615.            ENDDO
    616. 

  616.            ENDDO
    617. 

  617.          END IF
    618. 

  618. 

  619.        END IF
    620. 

  620. 

  621.    END SUBROUTINE set_physical_bc2d
    622. 

  622. 

  623. !-----------------------------------
    624. 

  624. 

  625.    SUBROUTINE set_physical_bc3d( dat, variable_in,        &
    626. 

  626.                                config_flags,                   & 
    627. 

  627.                                ids,ide, jds,jde, kds,kde,  & ! domain dims
    628. 

  628.                                ims,ime, jms,jme, kms,kme,  & ! memory dims
    629. 

  629.                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
    630. 

  630.                                its,ite, jts,jte, kts,kte )
    631. 

  631. 

  632. !  This subroutine sets the data in the boundary region, by direct
    633. 

  633. !  assignment if possible, for periodic and symmetric (wall)
    634. 

  634. !  boundary conditions.  Currently, we are only doing 1 variable
    635. 

  635. !  at a time - lots of overhead, so maybe this routine can be easily 
    636. 

  636. !  inlined later or we could pass multiple variables -
    637. 

  637. !  would probably want a largestep and smallstep version.
    638. 

  638. 

  639. !  15 Jan 99, Dave
    640. 

  640. !  Modified the incoming its,ite,jts,jte to truly be the tile size.
    641. 

  641. !  This required modifying the loop limits when the "istag" or "jstag"
    642. 

  642. !  is used, as this is only required at the end of the domain.
    643. 

  643. 

  644.       IMPLICIT NONE
    645. 

  645. 

  646.       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
    647. 

  647.       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
    648. 

  648.       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
    649. 

  649.       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
    650. 

  650.       CHARACTER,    INTENT(IN   )    :: variable_in
    651. 

  651. 

  652.       CHARACTER                      :: variable
    653. 

  653. 

  654.       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) :: dat
    655. 

  655.       TYPE( grid_config_rec_type ) config_flags
    656. 

  656. 

  657.       INTEGER  :: i, j, k, istag, jstag, itime, k_end
    658. 

  658. 

  659.       LOGICAL  :: debug, open_bc_copy
    660. 

  660. 

  661. !------------
    662. 

  662. 

  663.       debug = .false.
    664. 

  664. 

  665.       open_bc_copy = .false.
    666. 

  666. 

  667.       variable = variable_in
    668. 

  668.       IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
    669. 

  669.         variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
    670. 

  670.       ENDIF
    671. 

  671. 

  672.       IF ((variable == 'u') .or. (variable == 'v') .or.     &
    673. 

  673.           (variable == 'w') .or. (variable == 't') .or.     &
    674. 

  674.           (variable == 'd') .or. (variable == 'e') .or. &
    675. 

  675.           (variable == 'x') .or. (variable == 'y') .or. &
    676. 

  676.           (variable == 'f') .or. (variable == 'r') .or. &
    677. 

  677.           (variable == 'p')                        ) open_bc_copy = .true.
    678. 

  678. 

  679. !  begin, first set a staggering variable
    680. 

  680. 

  681.       istag = -1
    682. 

  682.       jstag = -1
    683. 

  683.       k_end = max(1,min(kde-1,kte))
    684. 

  684. 

  685. 

  686.       IF ((variable == 'u') .or. (variable == 'x')) istag = 0
    687. 

  687.       IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
    688. 

  688.       IF ((variable == 'd') .or. (variable == 'xy')) then
    689. 

  689.          istag = 0
    690. 

  690.          jstag = 0
    691. 

  691.       ENDIF
    692. 

  692.       IF ((variable == 'e') ) then
    693. 

  693.          istag = 0
    694. 

  694.          k_end = min(kde,kte)
    695. 

  695.       ENDIF
    696. 

  696. 

  697.       IF ((variable == 'f') ) then
    698. 

  698.          jstag = 0
    699. 

  699.          k_end = min(kde,kte)
    700. 

  700.       ENDIF
    701. 

  701. 

  702.       IF ( variable == 'w')  k_end = min(kde,kte)
    703. 

  703. 

  704. !      k_end = kte
    705. 

  705. 

  706.       if(debug) then
    707. 

  707.         write(6,*) ' in bc, var is ',variable, istag, jstag, kte, k_end
    708. 

  708.         write(6,*) ' b.cs are ',  &
    709. 

  709.       config_flags%periodic_x,  &
    710. 

  710.       config_flags%periodic_y
    711. 

  711.       end if
    712. 

  712.       
    713. 

  713. 

  714. 

  715. !  periodic conditions.
    716. 

  716. !  note, patch must cover full range in periodic dir, or else
    717. 

  717. !  its intra-patch communication that is handled elsewheres.
    718. 

  718. !  symmetry conditions can always be handled here, because no
    719. 

  719. !  outside patch communication is needed
    720. 

  720. 

  721.       periodicity_x:  IF( ( config_flags%periodic_x ) ) THEN
    722. 

  722. 

  723.         IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN  ! test if both east and west on-processor
    724. 

  724.           IF ( its == ids ) THEN
    725. 

  725. 

  726.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    727. 

  727.             DO k = kts, k_end
    728. 

  728.             DO i = 0,-(bdyzone-1),-1
    729. 

  729.               dat(ids+i-1,k,j) = dat(ide+i-1,k,j)
    730. 

  730.             ENDDO
    731. 

  731.             ENDDO
    732. 

  732.             ENDDO
    733. 

  733. 

  734.           ENDIF
    735. 

  735. 

  736. 

  737.           IF ( ite == ide ) THEN
    738. 

  738. 

  739.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    740. 

  740.             DO k = kts, k_end
    741. 

  741.             DO i = -istag , bdyzone
    742. 

  742.               dat(ide+i+istag,k,j) = dat(ids+i+istag,k,j)
    743. 

  743.             ENDDO
    744. 

  744.             ENDDO
    745. 

  745.             ENDDO
    746. 

  746. 

  747.           ENDIF
    748. 

  748. 

  749.         ENDIF
    750. 

  750. 

  751.       ELSE 
    752. 

  752. 

  753.         symmetry_xs: IF( ( config_flags%symmetric_xs ) .and.  &
    754. 

  754.                          ( its == ids )                  )  THEN
    755. 

  755. 

  756.           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
    757. 

  757. 

  758.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    759. 

  759.             DO k = kts, k_end
    760. 

  760.             DO i = 1, bdyzone
    761. 

  761.               dat(ids-i,k,j) = dat(ids+i-1,k,j) !  here, dat(0) = dat(1), etc
    762. 

  762.             ENDDO                                 !  symmetry about dat(0.5) (u = 0 pt)
    763. 

  763.             ENDDO
    764. 

  764.             ENDDO
    765. 

  765. 

  766.           ELSE
    767. 

  767. 

  768.             IF ( variable == 'u' ) THEN
    769. 

  769. 

  770.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    771. 

  771.               DO k = kts, k_end
    772. 

  772.               DO i = 1, bdyzone
    773. 

  773.                 dat(ids-i,k,j) = - dat(ids+i,k,j) ! here, u(0) = - u(2), etc
    774. 

  774.               ENDDO                                 !  normal b.c symmetry at u(1)
    775. 

  775.               ENDDO
    776. 

  776.               ENDDO
    777. 

  777. 

  778.             ELSE
    779. 

  779. 

  780.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    781. 

  781.               DO k = kts, k_end
    782. 

  782.               DO i = 1, bdyzone
    783. 

  783.                 dat(ids-i,k,j) = dat(ids+i,k,j) ! here, phi(0) = phi(2), etc
    784. 

  784.               ENDDO                               !  normal b.c symmetry at phi(1)
    785. 

  785.               ENDDO
    786. 

  786.               ENDDO
    787. 

  787. 

  788.             END IF
    789. 

  789. 

  790.           ENDIF
    791. 

  791. 

  792.         ENDIF symmetry_xs
    793. 

  793. 

  794. 

  795. !  now the symmetry boundary at xe
    796. 

  796. 

  797.         symmetry_xe: IF( ( config_flags%symmetric_xe ) .and.  &
    798. 

  798.                          ( ite == ide )                  )  THEN
    799. 

  799. 

  800.           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
    801. 

  801. 

  802.             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    803. 

  803.             DO k = kts, k_end
    804. 

  804.             DO i = 1, bdyzone
    805. 

  805.               dat(ide+i-1,k,j) = dat(ide-i,k,j)  !  sym. about dat(ide-0.5)
    806. 

  806.             ENDDO
    807. 

  807.             ENDDO
    808. 

  808.             ENDDO
    809. 

  809. 

  810.           ELSE
    811. 

  811. 

  812.             IF (variable == 'u') THEN
    813. 

  813. 

  814.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    815. 

  815.               DO k = kts, k_end
    816. 

  816.               DO i = 1, bdyzone
    817. 

  817.                 dat(ide+i,k,j) = - dat(ide-i,k,j)  ! u(ide+1) = - u(ide-1), etc.
    818. 

  818.               ENDDO
    819. 

  819.               ENDDO
    820. 

  820.               ENDDO
    821. 

  821. 

  822.             ELSE
    823. 

  823. 

  824.               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
    825. 

  825.               DO k = kts, k_end
    826. 

  826.               DO i = 1, bdyzone
    827. 

  827.                 dat(ide+i,k,j) = dat(ide-i,k,j)  ! phi(ide+1) = - phi(ide-1), etc.
    828. 

  828.               ENDDO
    829. 

  829.               ENDDO
    830. 

  830.               ENDDO
    831. 

  831. 

  832.              END IF
    833. 

  833. 

  834.           END IF 
    835. 

  835. 

  836.         END IF symmetry_xe
    837. 

  837. 

  838. !  set open b.c in X copy into boundary zone here.  WCS, 19 March 2000
    839. 

  839. 

  840.         open_xs: IF( ( config_flags%open_xs   .or. &
    841. 

  841.                        config_flags%specified .or. &
    842. 

  842.                        config_flags%nested            ) .and.  &
    843. 

  843.                          ( its == ids ) .and. open_bc_copy  )  THEN
    844. 

  844. 

  845.             DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
    846. 

  846.             DO k = kts, k_end
    847. 

  847.               dat(ids-1,k,j) = dat(ids,k,j) !  here, dat(0) = dat(1), etc
    848. 

  848.               dat(ids-2,k,j) = dat(ids,k,j)
    849. 

  849.               dat(ids-3,k,j) = dat(ids,k,j)
    850. 

  850.             ENDDO
    851. 

  851.             ENDDO
    852. 

  852. 

  853.         ENDIF open_xs
    854. 

  854. 

  855. 

  856. !  now the open_xe boundary copy 
    857. 

  857. 

  858.         open_xe: IF( ( config_flags%open_xe   .or. &
    859. 

  859.                        config_flags%specified .or. &
    860. 

  860.                        config_flags%nested            ) .and.  &
    861. 

  861.                          ( ite == ide ) .and. open_bc_copy )  THEN
    862. 

  862. 

  863.           IF (variable /= 'u' .and. variable /= 'x' ) THEN
    864. 

  864. 

  865.             DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
    866. 

  866.             DO k = kts, k_end
    867. 

  867.               dat(ide  ,k,j) = dat(ide-1,k,j)
    868. 

  868.               dat(ide+1,k,j) = dat(ide-1,k,j)
    869. 

  869.               dat(ide+2,k,j) = dat(ide-1,k,j)
    870. 

  870.             ENDDO
    871. 

  871.             ENDDO
    872. 

  872. 

  873.           ELSE
    874. 

  874. 

  875. !!!!!!! I am not sure about this one!  JM 20020402
    876. 

  876.             DO j = MAX(jds,jts-1)-bdyzone, MIN(jte+1,jde+jstag)+bdyzone
    877. 

  877.             DO k = kts, k_end
    878. 

  878.               dat(ide+1,k,j) = dat(ide,k,j)
    879. 

  879.               dat(ide+2,k,j) = dat(ide,k,j)
    880. 

  880.               dat(ide+3,k,j) = dat(ide,k,j)
    881. 

  881.             ENDDO
    882. 

  882.             ENDDO
    883. 

  883. 

  884.           END IF 
    885. 

  885. 

  886.         END IF open_xe
    887. 

  887. 

  888. !  end open b.c in X copy into boundary zone addition.  WCS, 19 March 2000
    889. 

  889. 

  890.       END IF periodicity_x
    891. 

  891. 

  892. !  same procedure in y
    893. 

  893. 

  894.       periodicity_y:  IF( ( config_flags%periodic_y ) ) THEN
    895. 

  895.         IF ( ( jds == jps ) .and. ( jde == jpe ) )  THEN      ! test if both north and south on processor
    896. 

  896.           IF( jts == jds ) then
    897. 

  897. 

  898.             DO j = 0, -(bdyzone-1), -1
    899. 

  899.             DO k = kts, k_end
    900. 

  900.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    901. 

  901.               dat(i,k,jds+j-1) = dat(i,k,jde+j-1)
    902. 

  902.             ENDDO
    903. 

  903.             ENDDO
    904. 

  904.             ENDDO
    905. 

  905. 

  906.           END IF
    907. 

  907. 

  908.           IF( jte == jde ) then
    909. 

  909. 

  910.             DO j = -jstag, bdyzone
    911. 

  911.             DO k = kts, k_end
    912. 

  912.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    913. 

  913.               dat(i,k,jde+j+jstag) = dat(i,k,jds+j+jstag)
    914. 

  914.             ENDDO
    915. 

  915.             ENDDO
    916. 

  916.             ENDDO
    917. 

  917. 

  918.           END IF
    919. 

  919. 

  920.         END IF
    921. 

  921. 

  922.       ELSE
    923. 

  923. 

  924.         symmetry_ys: IF( ( config_flags%symmetric_ys ) .and.  &
    925. 

  925.                          ( jts == jds)                   )  THEN
    926. 

  926. 

  927.           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
    928. 

  928. 

  929.             DO j = 1, bdyzone
    930. 

  930.             DO k = kts, k_end
    931. 

  931.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    932. 

  932.               dat(i,k,jds-j) = dat(i,k,jds+j-1) 
    933. 

  933.             ENDDO                               
    934. 

  934.             ENDDO
    935. 

  935.             ENDDO
    936. 

  936. 

  937.           ELSE
    938. 

  938. 

  939.             IF (variable == 'v') THEN
    940. 

  940. 

  941.               DO j = 1, bdyzone
    942. 

  942.               DO k = kts, k_end
    943. 

  943.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    944. 

  944.                 dat(i,k,jds-j) = - dat(i,k,jds+j) 
    945. 

  945.               ENDDO              
    946. 

  946.               ENDDO
    947. 

  947.               ENDDO
    948. 

  948. 

  949.             ELSE
    950. 

  950. 

  951.               DO j = 1, bdyzone
    952. 

  952.               DO k = kts, k_end
    953. 

  953.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    954. 

  954.                 dat(i,k,jds-j) = dat(i,k,jds+j) 
    955. 

  955.               ENDDO              
    956. 

  956.               ENDDO
    957. 

  957.               ENDDO
    958. 

  958. 

  959.             END IF
    960. 

  960. 

  961.           ENDIF
    962. 

  962. 

  963.         ENDIF symmetry_ys
    964. 

  964. 

  965. !  now the symmetry boundary at ye
    966. 

  966. 

  967.         symmetry_ye: IF( ( config_flags%symmetric_ye ) .and.  &
    968. 

  968.                          ( jte == jde )                  )  THEN
    969. 

  969. 

  970.           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
    971. 

  971. 

  972.             DO j = 1, bdyzone
    973. 

  973.             DO k = kts, k_end
    974. 

  974.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    975. 

  975.               dat(i,k,jde+j-1) = dat(i,k,jde-j) 
    976. 

  976.             ENDDO                               
    977. 

  977.             ENDDO
    978. 

  978.             ENDDO
    979. 

  979. 

  980.           ELSE
    981. 

  981. 

  982.             IF ( variable == 'v' ) THEN
    983. 

  983. 

  984.               DO j = 1, bdyzone
    985. 

  985.               DO k = kts, k_end
    986. 

  986.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    987. 

  987.                 dat(i,k,jde+j) = - dat(i,k,jde-j) 
    988. 

  988.               ENDDO                               
    989. 

  989.               ENDDO
    990. 

  990.               ENDDO
    991. 

  991. 

  992.             ELSE
    993. 

  993. 

  994.               DO j = 1, bdyzone
    995. 

  995.               DO k = kts, k_end
    996. 

  996.               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    997. 

  997.                 dat(i,k,jde+j) = dat(i,k,jde-j) 
    998. 

  998.               ENDDO                               
    999. 

  999.               ENDDO
    1000. 

  1000.               ENDDO
    1001. 

  1001. 

  1002.             END IF
    1003. 

  1003. 

  1004.           ENDIF
    1005. 

  1005. 

  1006.         END IF symmetry_ye
    1007. 

  1007.       
    1008. 

  1008. !  set open b.c in Y copy into boundary zone here.  WCS, 19 March 2000
    1009. 

  1009. 

  1010.         open_ys: IF( ( config_flags%open_ys   .or. &
    1011. 

  1011.                        config_flags%polar     .or. &
    1012. 

  1012.                        config_flags%specified .or. &
    1013. 

  1013.                        config_flags%nested            ) .and.  &
    1014. 

  1014.                          ( jts == jds) .and. open_bc_copy )  THEN
    1015. 

  1015. 

  1016.             DO k = kts, k_end
    1017. 

  1017.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    1018. 

  1018.               dat(i,k,jds-1) = dat(i,k,jds) 
    1019. 

  1019.               dat(i,k,jds-2) = dat(i,k,jds) 
    1020. 

  1020.               dat(i,k,jds-3) = dat(i,k,jds) 
    1021. 

  1021.             ENDDO
    1022. 

  1022.             ENDDO
    1023. 

  1023. 

  1024.         ENDIF open_ys
    1025. 

  1025. 

  1026. !  now the open boundary copy at ye
    1027. 

  1027. 

  1028.         open_ye: IF( ( config_flags%open_ye   .or. &
    1029. 

  1029.                        config_flags%polar     .or. &
    1030. 

  1030.                        config_flags%specified .or. &
    1031. 

  1031.                        config_flags%nested            ) .and.  &
    1032. 

  1032.                          ( jte == jde ) .and. open_bc_copy )  THEN
    1033. 

  1033. 

  1034.           IF (variable /= 'v' .and. variable /= 'y' ) THEN
    1035. 

  1035. 

  1036.             DO k = kts, k_end
    1037. 

  1037.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    1038. 

  1038.               dat(i,k,jde  ) = dat(i,k,jde-1) 
    1039. 

  1039.               dat(i,k,jde+1) = dat(i,k,jde-1) 
    1040. 

  1040.               dat(i,k,jde+2) = dat(i,k,jde-1) 
    1041. 

  1041.             ENDDO                               
    1042. 

  1042.             ENDDO
    1043. 

  1043. 

  1044.           ELSE
    1045. 

  1045. 

  1046.             DO k = kts, k_end
    1047. 

  1047.             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
    1048. 

  1048.               dat(i,k,jde+1) = dat(i,k,jde) 
    1049. 

  1049.               dat(i,k,jde+2) = dat(i,k,jde) 
    1050. 

  1050.               dat(i,k,jde+3) = dat(i,k,jde) 
    1051. 

  1051.             ENDDO                               
    1052. 

  1052.             ENDDO
    1053. 

  1053. 

  1054.           ENDIF
    1055. 

  1055. 

  1056.       END IF open_ye
    1057. 

  1057. 

  1058. !  end open b.c in Y copy into boundary zone addition.  WCS, 19 March 2000
    1059. 

  1059. 

  1060.       END IF periodicity_y
    1061. 

  1061. 

  1062. !  fix corners for doubly periodic domains
    1063. 

  1063. 

  1064.       IF ( config_flags%periodic_x .and. config_flags%periodic_y &
    1065. 

  1065.            .and. (ids == ips) .and. (ide == ipe)                 &
    1066. 

  1066.            .and. (jds == jps) .and. (jde == jpe)                   ) THEN
    1067. 

  1067. 

  1068.          IF ( (its == ids) .and. (jts == jds) ) THEN  ! lower left corner fill
    1069. 

  1069.            DO j = 0, -(bdyzone-1), -1
    1070. 

  1070.            DO k = kts, k_end
    1071. 

  1071.            DO i = 0, -(bdyzone-1), -1
    1072. 

  1072.              dat(ids+i-1,k,jds+j-1) = dat(ide+i-1,k,jde+j-1)
    1073. 

  1073.            ENDDO
    1074. 

  1074.            ENDDO
    1075. 

  1075.            ENDDO
    1076. 

  1076.          END IF
    1077. 

  1077. 

  1078.          IF ( (ite == ide) .and. (jts == jds) ) THEN  ! lower right corner fill
    1079. 

  1079.            DO j = 0, -(bdyzone-1), -1
    1080. 

  1080.            DO k = kts, k_end
    1081. 

  1081.            DO i = 1, bdyzone
    1082. 

  1082.              dat(ide+i+istag,k,jds+j-1) = dat(ids+i+istag,k,jde+j-1)
    1083. 

  1083.            ENDDO
    1084. 

  1084.            ENDDO
    1085. 

  1085.            ENDDO
    1086. 

  1086.          END IF
    1087. 

  1087. 

  1088.          IF ( (ite == ide) .and. (jte == jde) ) THEN  ! upper right corner fill
    1089. 

  1089.            DO j = 1, bdyzone
    1090. 

  1090.            DO k = kts, k_end
    1091. 

  1091.            DO i = 1, bdyzone
    1092. 

  1092.              dat(ide+i+istag,k,jde+j+jstag) = dat(ids+i+istag,k,jds+j+jstag)
    1093. 

  1093.            ENDDO
    1094. 

  1094.            ENDDO
    1095. 

  1095.            ENDDO
    1096. 

  1096.          END IF
    1097. 

  1097. 

  1098.          IF ( (its == ids) .and. (jte == jde) ) THEN  ! upper left corner fill
    1099. 

  1099.            DO j = 1, bdyzone
    1100. 

  1100.            DO k = kts, k_end
    1101. 

  1101.            DO i = 0, -(bdyzone-1), -1
    1102. 

  1102.              dat(ids+i-1,k,jde+j+jstag) = dat(ide+i-1,k,jds+j+jstag)
    1103. 

  1103.            ENDDO
    1104. 

  1104.            ENDDO
    1105. 

  1105.            ENDDO
    1106. 

  1106.          END IF
    1107. 

  1107. 

  1108.        END IF
    1109. 

  1109. 

  1110.    END SUBROUTINE set_physical_bc3d
    1111. 

  1111. 

  1112.    SUBROUTINE init_module_bc
    1113. 

  1113.    END SUBROUTINE init_module_bc
    1114. 

  1114. 

  1115. !------------------------------------------------------------------------
    1116. 

  1116. 

  1117. ! a couple versions of this call to allow a smaller-than-memory dimensioned field (e.g. tile sized)
    1118. 

  1118. ! to be passed in as the first argument.  Both of these call the _core version defined below.
    1119. 

  1119.    SUBROUTINE relax_bdytend   ( field, field_tend,                     &
    1120. 

  1120.                                 field_bdy_xs, field_bdy_xe,            &
    1121. 

  1121.                                 field_bdy_ys, field_bdy_ye,            &
    1122. 

  1122.                                 field_bdy_tend_xs, field_bdy_tend_xe,  &
    1123. 

  1123.                                 field_bdy_tend_ys, field_bdy_tend_ye,  &
    1124. 

  1124.                                 variable_in, config_flags,             &
    1125. 

  1125.                                 spec_bdy_width, spec_zone, relax_zone, &
    1126. 

  1126.                                 dtbc, fcx, gcx,             &
    1127. 

  1127.                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
    1128. 

  1128.                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
    1129. 

  1129.                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
    1130. 

  1130.                                 its,ite, jts,jte, kts,kte   &
    1131. 

  1131.                                 )
    1132. 

  1132. 

  1133.       IMPLICIT NONE
    1134. 

  1134. 

  1135.       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
    1136. 

  1136.       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
    1137. 

  1137.       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
    1138. 

  1138.       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
    1139. 

  1139.       INTEGER,      INTENT(IN   )    :: spec_bdy_width, spec_zone, relax_zone
    1140. 

  1140.       REAL,         INTENT(IN   )    :: dtbc
    1141. 

  1141.       CHARACTER,    INTENT(IN   )    :: variable_in
    1142. 

  1142. 

  1143.       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN   ) :: field
    1144. 

  1144.       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field_tend
    1145. 

  1145.       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_xs, field_bdy_xe
    1146. 

  1146.       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_ys, field_bdy_ye
    1147. 

  1147.       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_xs, field_bdy_tend_xe
    1148. 

  1148.       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_ys, field_bdy_tend_ye
    1149. 

  1149.       REAL,  DIMENSION( spec_bdy_width ), INTENT(IN   ) :: fcx, gcx
    1150. 

  1150.       TYPE( grid_config_rec_type ) config_flags
    1151. 

  1151. 

  1152.       CALL relax_bdytend_core   ( field, field_tend,                     &
    1153. 

  1153.                                 field_bdy_xs, field_bdy_xe,            &
    1154. 

  1154.                                 field_bdy_ys, field_bdy_ye,            &
    1155. 

  1155.                                 field_bdy_tend_xs, field_bdy_tend_xe,  &
    1156. 

  1156.                                 field_bdy_tend_ys, field_bdy_tend_ye,  &
    1157. 

  1157.                                 variable_in, config_flags,             &
    1158. 

  1158.                                 spec_bdy_width, spec_zone, relax_zone, &
    1159. 

  1159.                                 dtbc, fcx, gcx,             &
    1160. 

  1160.                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
    1161. 

  1161.                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
    1162. 

  1162.                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
    1163. 

  1163.                                 its,ite, jts,jte, kts,kte,  & ! patch  dims
    1164. 

  1164.                                 ims,ime, jms,jme, kms,kme )  ! dimension of the field argument
    1165. 

  1165.    END SUBROUTINE relax_bdytend
    1166. 

  1166. 

  1167. ! version that allows tile-sized version of field. Note, caller should define the
    1168. 

  1168. ! field to be -+1 of tile size in each dimension because routine is going off onto halo
    1169. 

  1169. ! for example, see relax_bdytend in dyn_em/module_bc_em.F 
    1170. 

  1170.    SUBROUTINE relax_bdytend_tile   ( field, field_tend,                     &
    1171. 

  1171.                                 field_bdy_xs, field_bdy_xe,            &
    1172. 

  1172.                                 field_bdy_ys, field_bdy_ye,            &
    1173. 

  1173.                                 field_bdy_tend_xs, field_bdy_tend_xe,  &
    1174. 

  1174.                                 field_bdy_tend_ys, field_bdy_tend_ye,  &
    1175. 

  1175.                                 variable_in, config_flags,             &
    1176. 

  1176.                                 spec_bdy_width, spec_zone, relax_zone, &
    1177. 

  1177.                                 dtbc, fcx, gcx,             &
    1178. 

  1178.                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
    1179. 

  1179.                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
    1180. 

  1180.                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
    1181. 

  1181.                                 its,ite, jts,jte, kts,kte,  &
    1182. 

  1182.                                 iXs,iXe, jXs,jXe, kXs,kXe   &  ! dims of first argument
    1183. 

  1183.                                 )
    1184. 

  1184. 

  1185.       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
    1186. 

  1186.       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
    1187. 

  1187.       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
    1188. 

  1188.       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
    1189. 

  1189.       INTEGER,      INTENT(IN   )    :: iXs,iXe, jXs,jXe, kXs,kXe
    1190. 

  1190.       INTEGER,      INTENT(IN   )    :: spec_bdy_width, spec_zone, relax_zone
    1191. 

  1191.       REAL,         INTENT(IN   )    :: dtbc
    1192. 

  1192.       CHARACTER,    INTENT(IN   )    :: variable_in
    1193. 

  1193. 

  1194.       REAL,  DIMENSION( iXs:iXe , kXs:kXe , jXs:jXe ), INTENT(IN   ) :: field
    1195. 

  1195.       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field_tend
    1196. 

  1196.       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_xs, field_bdy_xe
    1197. 

  1197.       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_ys, field_bdy_ye
    1198. 

  1198.       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_xs, field_bdy_tend_xe
    1199. 

  1199.       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_ys, field_bdy_tend_ye
    1200. 

  1200.       REAL,  DIMENSION( spec_bdy_width ), INTENT(IN   ) :: fcx, gcx
    1201. 

  1201.       TYPE( grid_config_rec_type ) config_flags
    1202. 

  1202. 

  1203.       CALL relax_bdytend_core   ( field, field_tend,                     &
    1204. 

  1204.                                 field_bdy_xs, field_bdy_xe,            &
    1205. 

  1205.                                 field_bdy_ys, field_bdy_ye,            &
    1206. 

  1206.                                 field_bdy_tend_xs, field_bdy_tend_xe,  &
    1207. 

  1207.                                 field_bdy_tend_ys, field_bdy_tend_ye,  &
    1208. 

  1208.                                 variable_in, config_flags,             &
    1209. 

  1209.                                 spec_bdy_width, spec_zone, relax_zone, &
    1210. 

  1210.                                 dtbc, fcx, gcx,             &
    1211. 

  1211.                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
    1212. 

  1212.                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
    1213. 

  1213.                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
    1214. 

  1214.                                 its,ite, jts,jte, kts,kte,  &
    1215. 

  1215.                                 iXs,iXe, jXs,jXe, kXs,kXe )  ! dimension of the field argument
    1216. 

  1216.    END SUBROUTINE relax_bdytend_tile
    1217. 

  1217. 

  1218.    SUBROUTINE relax_bdytend_core   ( field, field_tend,                     &
    1219. 

  1219.                                 field_bdy_xs, field_bdy_xe,            &
    1220. 

  1220.                                 field_bdy_ys, field_bdy_ye,            &
    1221. 

  1221.                                 field_bdy_tend_xs, field_bdy_tend_xe,  &
    1222. 

  1222.                                 field_bdy_tend_ys, field_bdy_tend_ye,  &
    1223. 

  1223.                                 variable_in, config_flags,             &
    1224. 

  1224.                                 spec_bdy_width, spec_zone, relax_zone, &
    1225. 

  1225.                                 dtbc, fcx, gcx,             &
    1226. 

  1226.                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
    1227. 

  1227.                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
    1228. 

  1228.                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
    1229. 

  1229.                                 its,ite, jts,jte, kts,kte,  & ! patch  dims
    1230. 

  1230.                                 iXs,iXe, jXs,jXe, kXs,kXe   & ! field (1st arg) dims; might be tile or patch
    1231. 

  1231.                                 )
    1232. 

  1232. 

  1233. !  This subroutine adds the tendencies in the boundary relaxation region, for specified
    1234. 

  1234. !  boundary conditions.  
    1235. 

  1235. !  spec_bdy_width is only used to dimension the boundary arrays.
    1236. 

  1236. !  relax_zone is the inner edge of the boundary relaxation zone treated here.
    1237. 

  1237. !  spec_zone is the width of the outer specified b.c.s that are not changed here.
    1238. 

  1238. !  (JD July 2000)
    1239. 

  1239. 

  1240.       IMPLICIT NONE
    1241. 

  1241. 

  1242.       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
    1243. 

  1243.       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
    1244. 

  1244.       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
    1245. 

  1245.       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
    1246. 

  1246.       INTEGER,      INTENT(IN   )    :: iXs,iXe, jXs,jXe, kXs,kXe
    1247. 

  1247.       INTEGER,      INTENT(IN   )    :: spec_bdy_width, spec_zone, relax_zone
    1248. 

  1248.       REAL,         INTENT(IN   )    :: dtbc
    1249. 

  1249.       CHARACTER,    INTENT(IN   )    :: variable_in
    1250. 

  1250. 

  1251. 

  1252.       REAL,  DIMENSION( iXs:iXe , kXs:kXe , jXs:jXe ), INTENT(IN   ) :: field
    1253. 

  1253.       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field_tend
    1254. 

  1254.       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_xs, field_bdy_xe
    1255. 

  1255.       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_ys, field_bdy_ye
    1256. 

  1256.       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_xs, field_bdy_tend_xe
    1257. 

  1257.       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_ys, field_bdy_tend_ye
    1258. 

  1258.       REAL,  DIMENSION( spec_bdy_width ), INTENT(IN   ) :: fcx, gcx
    1259. 

  1259.       TYPE( grid_config_rec_type ) config_flags
    1260. 

  1260. 

  1261.       CHARACTER  :: variable
    1262. 

  1262.       INTEGER    :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, im1, ip1
    1263. 

  1263.       INTEGER    :: b_dist, b_limit
    1264. 

  1264.       REAL       :: fls0, fls1, fls2, fls3, fls4
    1265. 

  1265.       LOGICAL    :: periodic_x
    1266. 

  1266. 

  1267.       periodic_x = config_flags%periodic_x
    1268. 

  1268.       variable = variable_in
    1269. 

  1269. 

  1270.       IF (variable == 'U') variable = 'u'
    1271. 

  1271.       IF (variable == 'V') variable = 'v'
    1272. 

  1272.       IF (variable == 'M') variable = 'm'
    1273. 

  1273.       IF (variable == 'H') variable = 'h'
    1274. 

  1274. 

  1275.       ibs = ids
    1276. 

  1276.       ibe = ide-1
    1277. 

  1277.       itf = min(ite,ide-1)
    1278. 

  1278.       jbs = jds
    1279. 

  1279.       jbe = jde-1
    1280. 

  1280.       jtf = min(jte,jde-1)
    1281. 

  1281.       ktf = kde-1
    1282. 

  1282.       IF (variable == 'u') ibe = ide
    1283. 

  1283.       IF (variable == 'u') itf = min(ite,ide)
    1284. 

  1284.       IF (variable == 'v') jbe = jde
    1285. 

  1285.       IF (variable == 'v') jtf = min(jte,jde)
    1286. 

  1286.       IF (variable == 'm') ktf = kte
    1287. 

  1287.       IF (variable == 'h') ktf = kte
    1288. 

  1288. 

  1289. 

  1290.       IF (jts - jbs .lt. relax_zone) THEN
    1291. 

  1291. ! Y-start boundary
    1292. 

  1292.         DO j = max(jts,jbs+spec_zone), min(jtf,jbs+relax_zone-1)
    1293. 

  1293.           b_dist = j - jbs
    1294. 

  1294.           b_limit = b_dist
    1295. 

  1295.           IF(periodic_x)b_limit = 0
    1296. 

  1296.           DO k = kts, ktf
    1297. 

  1297.             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
    1298. 

  1298.               im1 = max(i-1,ibs)
    1299. 

  1299.               ip1 = min(i+1,ibe)
    1300. 

  1300.               fls0 = field_bdy_ys(i, k, b_dist+1) &
    1301. 

  1301.                    + dtbc * field_bdy_tend_ys(i, k, b_dist+1) &
    1302. 

  1302.                    - field(i,k,j)
    1303. 

  1303.               fls1 = field_bdy_ys(im1, k, b_dist+1) &
    1304. 

  1304.                    + dtbc * field_bdy_tend_ys(im1, k, b_dist+1) &
    1305. 

  1305.                    - field(im1,k,j)
    1306. 

  1306.               fls2 = field_bdy_ys(ip1, k, b_dist+1) &
    1307. 

  1307.                    + dtbc * field_bdy_tend_ys(ip1, k, b_dist+1) &
    1308. 

  1308.                    - field(ip1,k,j)
    1309. 

  1309.               fls3 = field_bdy_ys(i, k, b_dist) &
    1310. 

  1310.                    + dtbc * field_bdy_tend_ys(i, k, b_dist) &
    1311. 

  1311.                    - field(i,k,j-1)
    1312. 

  1312.               fls4 = field_bdy_ys(i, k, b_dist+2) &
    1313. 

  1313.                    + dtbc * field_bdy_tend_ys(i, k, b_dist+2) &
    1314. 

  1314.                    - field(i,k,j+1)
    1315. 

  1315.               field_tend(i,k,j) = field_tend(i,k,j) &
    1316. 

  1316.                                 + fcx(b_dist+1)*fls0 &
    1317. 

  1317.                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
    1318. 

  1318.             ENDDO
    1319. 

  1319.           ENDDO
    1320. 

  1320.         ENDDO
    1321. 

  1321.       ENDIF
    1322. 

  1322. 

  1323.       IF (jbe - jtf .lt. relax_zone) THEN
    1324. 

  1324. 

  1325. 

  1326. ! Y-end boundary
    1327. 

  1327.         DO j = max(jts,jbe-relax_zone+1), min(jtf,jbe-spec_zone)
    1328. 

  1328.           b_dist = jbe - j
    1329. 

  1329.           b_limit = b_dist
    1330. 

  1330.           IF(periodic_x)b_limit = 0
    1331. 

  1331. 

  1332. 

  1333.           DO k = kts, ktf
    1334. 

  1334.             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
    1335. 

  1335.               im1 = max(i-1,ibs)
    1336. 

  1336.               ip1 = min(i+1,ibe)
    1337. 

  1337.               fls0 = field_bdy_ye(i, k, b_dist+1) &
    1338. 

  1338.                    + dtbc * field_bdy_tend_ye(i, k, b_dist+1) &
    1339. 

  1339.                    - field(i,k,j)
    1340. 

  1340.               fls1 = field_bdy_ye(im1, k, b_dist+1) &
    1341. 

  1341.                    + dtbc * field_bdy_tend_ye(im1, k, b_dist+1) &
    1342. 

  1342.                    - field(im1,k,j)
    1343. 

  1343.               fls2 = field_bdy_ye(ip1, k, b_dist+1) &
    1344. 

  1344.                    + dtbc * field_bdy_tend_ye(ip1, k, b_dist+1) &
    1345. 

  1345.                    - field(ip1,k,j)
    1346. 

  1346.               fls3 = field_bdy_ye(i, k, b_dist) &
    1347. 

  1347.                    + dtbc * field_bdy_tend_ye(i, k, b_dist) &
    1348. 

  1348.                    - field(i,k,j+1)
    1349. 

  1349.               fls4 = field_bdy_ye(i, k, b_dist+2) &
    1350. 

  1350.                    + dtbc * field_bdy_tend_ye(i, k, b_dist+2) &
    1351. 

  1351.                    - field(i,k,j-1)
    1352. 

  1352.               field_tend(i,k,j) = field_tend(i,k,j) &
    1353. 

  1353.                                 + fcx(b_dist+1)*fls0 &
    1354. 

  1354.                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
    1355. 

  1355. 

  1356.             ENDDO
    1357. 

  1357.           ENDDO
    1358. 

  1358.         ENDDO
    1359. 

  1359.       ENDIF
    1360. 

  1360. 

  1361.     IF(.NOT.periodic_x)THEN
    1362. 

  1362.       IF (its - ibs .lt. relax_zone) THEN
    1363. 

  1363. ! X-start boundary
    1364. 

  1364.         DO i = max(its,ibs+spec_zone), min(itf,ibs+relax_zone-1)
    1365. 

  1365.           b_dist = i - ibs
    1366. 

  1366.           DO k = kts, ktf
    1367. 

  1367.             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
    1368. 

  1368.               fls0 = field_bdy_xs(j, k, b_dist+1) &
    1369. 

  1369.                    + dtbc * field_bdy_tend_xs(j, k, b_dist+1) &
    1370. 

  1370.                    - field(i,k,j)
    1371. 

  1371.               fls1 = field_bdy_xs(j-1, k, b_dist+1) &
    1372. 

  1372.                    + dtbc * field_bdy_tend_xs(j-1, k, b_dist+1) &
    1373. 

  1373.                    - field(i,k,j-1)
    1374. 

  1374.               fls2 = field_bdy_xs(j+1, k, b_dist+1) &
    1375. 

  1375.                    + dtbc * field_bdy_tend_xs(j+1, k, b_dist+1) &
    1376. 

  1376.                    - field(i,k,j+1)
    1377. 

  1377.               fls3 = field_bdy_xs(j, k, b_dist) &
    1378. 

  1378.                    + dtbc * field_bdy_tend_xs(j, k, b_dist) &
    1379. 

  1379.                    - field(i-1,k,j)
    1380. 

  1380.               fls4 = field_bdy_xs(j, k, b_dist+2) &
    1381. 

  1381.                    + dtbc * field_bdy_tend_xs(j, k, b_dist+2) &
    1382. 

  1382.                    - field(i+1,k,j)
    1383. 

  1383.               field_tend(i,k,j) = field_tend(i,k,j) &
    1384. 

  1384.                                 + fcx(b_dist+1)*fls0 &
    1385. 

  1385.                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
    1386. 

  1386. 

  1387.             ENDDO
    1388. 

  1388.           ENDDO
    1389. 

  1389.         ENDDO
    1390. 

  1390.       ENDIF
    1391. 

  1391. 

  1392.       IF (ibe - itf .lt. relax_zone) THEN
    1393. 

  1393. ! X-end boundary
    1394. 

  1394.         DO i = max(its,ibe-relax_zone+1), min(itf,ibe-spec_zone)
    1395. 

  1395.           b_dist = ibe - i
    1396. 

  1396.           DO k = kts, ktf
    1397. 

  1397.             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
    1398. 

  1398.               fls0 = field_bdy_xe(j, k, b_dist+1) &
    1399. 

  1399.                    + dtbc * field_bdy_tend_xe(j, k, b_dist+1) &
    1400. 

  1400.                    - field(i,k,j)
    1401. 

  1401.               fls1 = field_bdy_xe(j-1, k, b_dist+1) &
    1402. 

  1402.                    + dtbc * field_bdy_tend_xe(j-1, k, b_dist+1) &
    1403. 

  1403.                    - field(i,k,j-1)
    1404. 

  1404.               fls2 = field_bdy_xe(j+1, k, b_dist+1) &
    1405. 

  1405.                    + dtbc * field_bdy_tend_xe(j+1, k, b_dist+1) &
    1406. 

  1406.                    - field(i,k,j+1)
    1407. 

  1407.               fls3 = field_bdy_xe(j, k, b_dist) &
    1408. 

  1408.                    + dtbc * field_bdy_tend_xe(j, k, b_dist) &
    1409. 

  1409.                    - field(i+1,k,j)
    1410. 

  1410.               fls4 = field_bdy_xe(j, k, b_dist+2) &
    1411. 

  1411.                    + dtbc * field_bdy_tend_xe(j, k, b_dist+2) &
    1412. 

  1412.                    - field(i-1,k,j)
    1413. 

  1413.               field_tend(i,k,j) = field_tend(i,k,j) &
    1414. 

  1414.                                 + fcx(b_dist+1)*fls0 &
    1415. 

  1415.                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
    1416. 

  1416.             ENDDO
    1417. 

  1417.           ENDDO
    1418. 

  1418.         ENDDO
    1419. 

  1419.       ENDIF
    1420. 

  1420.     ENDIF
    1421. 

  1421. 

  1422. 

  1423. 

  1424.    END SUBROUTINE relax_bdytend_core
    1425. 

  1425. !------------------------------------------------------------------------
    1426. 

  1426. 

  1427.    SUBROUTINE spec_bdytend   ( field_tend,                           &
    1428. 

  1428.                                field_bdy_xs, field_bdy_xe,           &
    1429. 

  1429.                     …
    1430.

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