wrfv2_fire/share/module_bc.F

   1 !WRF:MODEL_LAYER:BOUNDARY
   2 !
   3
   4 MODULE module_bc
   5
   6    USE module_configure
   7    USE module_wrf_error
   8    IMPLICIT NONE
   9
  10 !   TYPE bcs
  11 !
  12 !     LOGICAL                     :: periodic_x
  13 !     LOGICAL                     :: symmetric_xs
  14 !     LOGICAL                     :: symmetric_xe
  15 !     LOGICAL                     :: open_xs
  16 !     LOGICAL                     :: open_xe
  17 !     LOGICAL                     :: periodic_y
  18 !     LOGICAL                     :: symmetric_ys
  19 !     LOGICAL                     :: symmetric_ye
  20 !     LOGICAL                     :: open_ys
  21 !     LOGICAL                     :: open_ye
  22 !     LOGICAL                     :: nested
  23 !     LOGICAL                     :: specified
  24 !     LOGICAL                     :: top_radiation
  25 !
  26 !   END TYPE bcs
  27
  28 !  set the bdyzone.  We are hardwiring this here and we'll
  29 !  decide later where it should be set and stored
  30
  31    INTEGER, PARAMETER            :: bdyzone = 4
  32    INTEGER, PARAMETER            :: bdyzone_x = bdyzone
  33    INTEGER, PARAMETER            :: bdyzone_y = bdyzone
  34
  35    INTERFACE stuff_bdy
  36      MODULE PROCEDURE stuff_bdy_new , stuff_bdy_old
  37    END INTERFACE
  38
  39    INTERFACE stuff_bdytend
  40      MODULE PROCEDURE stuff_bdytend_new , stuff_bdytend_old
  41    END INTERFACE
  42
  43 CONTAINS
  44
  45   SUBROUTINE boundary_condition_check ( config_flags, bzone, error, gn )
  46
  47 !  this routine checks the boundary condition logicals
  48 !  to make sure that the boundary conditions are not over
  49 !  or under specified.  The routine also checks that the
  50 !  boundary zone is sufficiently sized for the specified
  51 !  boundary conditions
  52
  53   IMPLICIT NONE
  54
  55   TYPE( grid_config_rec_type ) config_flags
  56
  57   INTEGER, INTENT(IN   ) :: bzone, gn
  58   INTEGER, INTENT(INOUT) :: error
  59
  60 ! local variables
  61
  62   INTEGER :: xs_bc, xe_bc, ys_bc, ye_bc, bzone_min
  63   INTEGER :: nprocx, nprocy
  64
  65   CALL wrf_debug( 100 , ' checking boundary conditions for grid ' )
  66
  67   error = 0
  68   xs_bc = 0
  69   xe_bc = 0
  70   ys_bc = 0
  71   ye_bc = 0
  72
  73 !  sum the number of conditions specified for each lateral boundary.
  74 !  obviously, this number should be 1
  75
  76   IF( config_flags%periodic_x ) THEN
  77     xs_bc = xs_bc+1
  78     xe_bc = xe_bc+1
  79   ENDIF
  80
  81   IF( config_flags%periodic_y ) THEN
  82     ys_bc = ys_bc+1
  83     ye_bc = ye_bc+1
  84   ENDIF
  85
  86   IF( config_flags%symmetric_xs ) xs_bc = xs_bc + 1
  87   IF( config_flags%symmetric_xe ) xe_bc = xe_bc + 1
  88   IF( config_flags%open_xs )      xs_bc = xs_bc + 1
  89   IF( config_flags%open_xe )      xe_bc = xe_bc + 1
  90
  91
  92   IF( config_flags%symmetric_ys ) ys_bc = ys_bc + 1
  93   IF( config_flags%symmetric_ye ) ye_bc = ye_bc + 1
  94   IF( config_flags%open_ys )      ys_bc = ys_bc + 1
  95   IF( config_flags%open_ye )      ye_bc = ye_bc + 1
  96
  97   IF( config_flags%nested ) THEN
  98      xs_bc = xs_bc + 1
  99      xe_bc = xe_bc + 1
 100      ys_bc = ys_bc + 1
 101      ye_bc = ye_bc + 1
 102    ENDIF
 103
 104   IF( config_flags%specified ) THEN
 105      IF( .NOT. config_flags%periodic_x)xs_bc = xs_bc + 1
 106      IF( .NOT. config_flags%periodic_x)xe_bc = xe_bc + 1
 107      ys_bc = ys_bc + 1
 108      ye_bc = ye_bc + 1
 109    ENDIF
 110
 111   IF( config_flags%polar ) THEN
 112      ys_bc = ys_bc + 1
 113      ye_bc = ye_bc + 1
 114    ENDIF
 115
 116 !  check the number of conditions for each boundary
 117
 118    IF( (xs_bc /= 1) .or. &
 119        (xe_bc /= 1) .or. &
 120        (ys_bc /= 1) .or. &
 121        (ye_bc /= 1)         ) THEN
 122
 123      error = 1
 124
 125      write( wrf_err_message ,*) ' *** Error in boundary condition specification '
 126      CALL wrf_message ( wrf_err_message )
 127      write( wrf_err_message ,*) ' boundary conditions at xs ', xs_bc
 128      CALL wrf_message ( wrf_err_message )
 129      write( wrf_err_message ,*) ' boundary conditions at xe ', xe_bc
 130      CALL wrf_message ( wrf_err_message )
 131      write( wrf_err_message ,*) ' boundary conditions at ys ', ys_bc
 132      CALL wrf_message ( wrf_err_message )
 133      write( wrf_err_message ,*) ' boundary conditions at ye ', ye_bc
 134      CALL wrf_message ( wrf_err_message )
 135      write( wrf_err_message ,*) ' boundary conditions logicals are '
 136      CALL wrf_message ( wrf_err_message )
 137      write( wrf_err_message ,*) ' periodic_x   ',config_flags%periodic_x
 138      CALL wrf_message ( wrf_err_message )
 139      write( wrf_err_message ,*) ' periodic_y   ',config_flags%periodic_y
 140      CALL wrf_message ( wrf_err_message )
 141      write( wrf_err_message ,*) ' symmetric_xs ',config_flags%symmetric_xs
 142      CALL wrf_message ( wrf_err_message )
 143      write( wrf_err_message ,*) ' symmetric_xe ',config_flags%symmetric_xe
 144      CALL wrf_message ( wrf_err_message )
 145      write( wrf_err_message ,*) ' symmetric_ys ',config_flags%symmetric_ys
 146      CALL wrf_message ( wrf_err_message )
 147      write( wrf_err_message ,*) ' symmetric_ye ',config_flags%symmetric_ye
 148      CALL wrf_message ( wrf_err_message )
 149      write( wrf_err_message ,*) ' open_xs      ',config_flags%open_xs
 150      CALL wrf_message ( wrf_err_message )
 151      write( wrf_err_message ,*) ' open_xe      ',config_flags%open_xe
 152      CALL wrf_message ( wrf_err_message )
 153      write( wrf_err_message ,*) ' open_ys      ',config_flags%open_ys
 154      CALL wrf_message ( wrf_err_message )
 155      write( wrf_err_message ,*) ' open_ye      ',config_flags%open_ye
 156      CALL wrf_message ( wrf_err_message )
 157      write( wrf_err_message ,*) ' polar        ',config_flags%polar
 158      CALL wrf_message ( wrf_err_message )
 159      write( wrf_err_message ,*) ' nested       ',config_flags%nested
 160      CALL wrf_message ( wrf_err_message )
 161      write( wrf_err_message ,*) ' specified    ',config_flags%specified
 162      CALL wrf_message ( wrf_err_message )
 163      CALL wrf_error_fatal( ' *** Error in boundary condition specification ' )
 164
 165    ENDIF
 166
 167 !  now check to see if boundary zone size is sufficient.
 168 !  we could have the necessary boundary zone size be returned
 169 !  to the calling routine.
 170
 171    IF( config_flags%periodic_x   .or. &
 172        config_flags%periodic_y   .or. &
 173        config_flags%symmetric_xs .or. &
 174        config_flags%symmetric_xe .or. &
 175        config_flags%symmetric_ys .or. &
 176        config_flags%symmetric_ye        )  THEN
 177
 178        bzone_min = MAX( 1,                                  &
 179                         (config_flags%h_mom_adv_order+1)/2, &
 180                         (config_flags%h_sca_adv_order+1)/2 )
 181
 182        IF( bzone < bzone_min) THEN
 183
 184          error = 2
 185          WRITE ( wrf_err_message , * ) ' boundary zone not large enough '
 186          CALL wrf_message ( wrf_err_message )
 187          WRITE ( wrf_err_message , * ) ' boundary zone specified      ',bzone
 188          CALL wrf_message ( wrf_err_message )
 189          WRITE ( wrf_err_message , * ) ' minimum boundary zone needed ',bzone_min
 190          CALL wrf_error_fatal ( wrf_err_message )
 191
 192        ENDIF
 193    ENDIF
 194
 195    CALL wrf_debug ( 100 , ' boundary conditions OK for grid ' )
 196
 197    END subroutine boundary_condition_check
 198
 199 !--------------------------------------------------------------------------
 200    SUBROUTINE set_physical_bc2d( dat, variable_in,  &
 201                                  config_flags,           &
 202                                  ids,ide, jds,jde,   & ! domain dims
 203                                  ims,ime, jms,jme,   & ! memory dims
 204                                  ips,ipe, jps,jpe,   & ! patch  dims
 205                                  its,ite, jts,jte   )
 206
 207 !  This subroutine sets the data in the boundary region, by direct
 208 !  assignment if possible, for periodic and symmetric (wall)
 209 !  boundary conditions.  Currently, we are only doing 1 variable
 210 !  at a time - lots of overhead, so maybe this routine can be easily
 211 !  inlined later or we could pass multiple variables -
 212 !  would probably want a largestep and smallstep version.
 213
 214 !  15 Jan 99, Dave
 215 !  Modified the incoming its,ite,jts,jte to truly be the tile size.
 216 !  This required modifying the loop limits when the "istag" or "jstag"
 217 !  is used, as this is only required at the end of the domain.
 218
 219       IMPLICIT NONE
 220
 221       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde
 222       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme
 223       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe
 224       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte
 225       CHARACTER,    INTENT(IN   )    :: variable_in
 226
 227       CHARACTER                      :: variable
 228
 229       REAL,  DIMENSION( ims:ime , jms:jme ) :: dat
 230       TYPE( grid_config_rec_type ) config_flags
 231
 232       INTEGER  :: i, j, istag, jstag, itime
 233
 234       LOGICAL  :: debug, open_bc_copy
 235
 236 !------------
 237
 238       debug = .false.
 239
 240       open_bc_copy = .false.
 241
 242       variable = variable_in
 243       IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
 244         variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
 245       ENDIF
 246       IF ((variable == 'u') .or. (variable == 'v') .or.  &
 247           (variable == 'w') .or. (variable == 't') .or.  &
 248           (variable == 'x') .or. (variable == 'y') .or.  &
 249           (variable == 'r') .or. (variable == 'p') ) open_bc_copy = .true.
 250
 251 !  begin, first set a staggering variable
 252
 253       istag = -1
 254       jstag = -1
 255
 256       IF ((variable == 'u') .or. (variable == 'x')) istag = 0
 257       IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
 258
 259       if(debug) then
 260         write(6,*) ' in bc2d, var is ',variable, istag, jstag
 261         write(6,*) ' b.cs are ',  &
 262       config_flags%periodic_x,  &
 263       config_flags%periodic_y
 264       end if
 265
 266
 267
 268 !  periodic conditions.
 269 !  note, patch must cover full range in periodic dir, or else
 270 !  its intra-patch communication that is handled elsewheres.
 271 !  symmetry conditions can always be handled here, because no
 272 !  outside patch communication is needed
 273
 274       periodicity_x:  IF( ( config_flags%periodic_x ) ) THEN
 275         IF ( ( ids == ips ) .and.  ( ide == ipe ) ) THEN  ! test if east and west both on-processor
 276           IF ( its == ids ) THEN
 277
 278             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 279             DO i = 0,-(bdyzone-1),-1
 280               dat(ids+i-1,j) = dat(ide+i-1,j)
 281             ENDDO
 282             ENDDO
 283
 284           ENDIF
 285
 286           IF ( ite == ide ) THEN
 287
 288             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 289 !!          DO i = 1 , bdyzone
 290             DO i = -istag , bdyzone
 291               dat(ide+i+istag,j) = dat(ids+i+istag,j)
 292             ENDDO
 293             ENDDO
 294
 295           ENDIF
 296         ENDIF
 297
 298       ELSE
 299
 300         symmetry_xs: IF( ( config_flags%symmetric_xs ) .and.  &
 301                          ( its == ids )                  )  THEN
 302
 303           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
 304
 305             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 306             DO i = 1, bdyzone
 307               dat(ids-i,j) = dat(ids+i-1,j) !  here, dat(0) = dat(1), etc
 308             ENDDO                             !  symmetry about dat(0.5) (u=0 pt)
 309             ENDDO
 310
 311           ELSE
 312
 313             IF( variable == 'u' ) THEN
 314
 315               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 316               DO i = 0, bdyzone-1
 317                 dat(ids-i,j) = - dat(ids+i,j) ! here, u(0) = - u(2), etc
 318               ENDDO                             !  normal b.c symmetry at u(1)
 319               ENDDO
 320
 321             ELSE
 322
 323               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 324               DO i = 0, bdyzone-1
 325                 dat(ids-i,j) =   dat(ids+i,j) ! here, phi(0) = phi(2), etc
 326               ENDDO                             !  normal b.c symmetry at phi(1)
 327               ENDDO
 328
 329             END IF
 330
 331           ENDIF
 332
 333         ENDIF symmetry_xs
 334
 335
 336 !  now the symmetry boundary at xe
 337
 338         symmetry_xe: IF( ( config_flags%symmetric_xe ) .and.  &
 339                          ( ite == ide )                  )  THEN
 340
 341           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
 342
 343             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 344             DO i = 1, bdyzone
 345               dat(ide+i-1,j) = dat(ide-i,j)  !  sym. about dat(ide-0.5)
 346             ENDDO
 347             ENDDO
 348
 349           ELSE
 350
 351             IF (variable == 'u' ) THEN
 352
 353               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 354               DO i = 0, bdyzone-1
 355                 dat(ide+i,j) = - dat(ide-i,j)  ! u(ide+1) = - u(ide-1), etc.
 356               ENDDO
 357               ENDDO
 358
 359
 360             ELSE
 361
 362               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 363               DO i = 0, bdyzone-1
 364                 dat(ide+i,j) = dat(ide-i,j)  !  phi(ide+1) = phi(ide-1), etc.
 365               ENDDO
 366               ENDDO
 367
 368             END IF
 369
 370           END IF
 371
 372         END IF symmetry_xe
 373
 374
 375 !  set open b.c in X copy into boundary zone here.  WCS, 19 March 2000
 376
 377         open_xs: IF( ( config_flags%open_xs   .or. &
 378                        config_flags%specified .or. &
 379                        config_flags%nested            ) .and.  &
 380                          ( its == ids ) .and. open_bc_copy  )  THEN
 381
 382             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 383               dat(ids-1,j) = dat(ids,j) !  here, dat(0) = dat(1)
 384               dat(ids-2,j) = dat(ids,j)
 385               dat(ids-3,j) = dat(ids,j)
 386             ENDDO
 387
 388         ENDIF open_xs
 389
 390
 391 !  now the open boundary copy at xe
 392
 393         open_xe: IF( ( config_flags%open_xe   .or. &
 394                        config_flags%specified .or. &
 395                        config_flags%nested            ) .and.  &
 396                           ( ite == ide ) .and. open_bc_copy  )  THEN
 397
 398           IF ( variable /= 'u' .and. variable /= 'x') THEN
 399
 400             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 401               dat(ide  ,j) = dat(ide-1,j)
 402               dat(ide+1,j) = dat(ide-1,j)
 403               dat(ide+2,j) = dat(ide-1,j)
 404             ENDDO
 405
 406           ELSE
 407
 408             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 409               dat(ide+1,j) = dat(ide,j)
 410               dat(ide+2,j) = dat(ide,j)
 411               dat(ide+3,j) = dat(ide,j)
 412             ENDDO
 413
 414           END IF
 415
 416         END IF open_xe
 417
 418 !  end open b.c in X copy into boundary zone addition.  WCS, 19 March 2000
 419
 420       END IF periodicity_x
 421
 422 !  same procedure in y
 423
 424       periodicity_y:  IF( ( config_flags%periodic_y ) ) THEN
 425         IF ( ( jds == jps ) .and. ( jde == jpe ) )  THEN    ! test of both north and south on processor
 426
 427           IF( jts == jds ) then
 428
 429             DO j = 0, -(bdyzone-1), -1
 430             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 431               dat(i,jds+j-1) = dat(i,jde+j-1)
 432             ENDDO
 433             ENDDO
 434
 435           END IF
 436
 437           IF( jte == jde ) then
 438
 439             DO j = -jstag, bdyzone
 440             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 441               dat(i,jde+j+jstag) = dat(i,jds+j+jstag)
 442             ENDDO
 443             ENDDO
 444
 445           END IF
 446
 447         END IF
 448
 449       ELSE
 450
 451         symmetry_ys: IF( ( config_flags%symmetric_ys ) .and.  &
 452                          ( jts == jds)                   )  THEN
 453
 454           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
 455
 456             DO j = 1, bdyzone
 457             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 458               dat(i,jds-j) = dat(i,jds+j-1)
 459             ENDDO
 460             ENDDO
 461
 462           ELSE
 463
 464             IF (variable == 'v') THEN
 465
 466               DO j = 1, bdyzone
 467               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 468                 dat(i,jds-j) = - dat(i,jds+j)
 469               ENDDO
 470               ENDDO
 471
 472             ELSE
 473
 474               DO j = 1, bdyzone
 475               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 476                 dat(i,jds-j) = dat(i,jds+j)
 477               ENDDO
 478               ENDDO
 479
 480             END IF
 481
 482           ENDIF
 483
 484         ENDIF symmetry_ys
 485
 486 !  now the symmetry boundary at ye
 487
 488         symmetry_ye: IF( ( config_flags%symmetric_ye ) .and.  &
 489                          ( jte == jde )                  )  THEN
 490
 491           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
 492
 493             DO j = 1, bdyzone
 494             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 495               dat(i,jde+j-1) = dat(i,jde-j)
 496             ENDDO
 497             ENDDO
 498
 499           ELSE
 500
 501             IF (variable == 'v' ) THEN
 502
 503               DO j = 1, bdyzone
 504               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 505                 dat(i,jde+j) = - dat(i,jde-j)    ! bugfix: changed jds on rhs to jde , JM 20020410
 506               ENDDO
 507               ENDDO
 508
 509             ELSE
 510
 511               DO j = 1, bdyzone
 512               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 513                 dat(i,jde+j) = dat(i,jde-j)
 514               ENDDO
 515               ENDDO
 516
 517             END IF
 518
 519           ENDIF
 520
 521         END IF symmetry_ye
 522
 523 !  set open b.c in Y copy into boundary zone here.  WCS, 19 March 2000
 524
 525         open_ys: IF( ( config_flags%open_ys   .or. &
 526                        config_flags%polar     .or. &
 527                        config_flags%specified .or. &
 528                        config_flags%nested            ) .and.  &
 529                          ( jts == jds) .and. open_bc_copy )  THEN
 530
 531             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 532               dat(i,jds-1) = dat(i,jds)
 533               dat(i,jds-2) = dat(i,jds)
 534               dat(i,jds-3) = dat(i,jds)
 535             ENDDO
 536
 537         ENDIF open_ys
 538
 539 !  now the open boundary copy at ye
 540
 541         open_ye: IF( ( config_flags%open_ye   .or. &
 542                        config_flags%polar     .or. &
 543                        config_flags%specified .or. &
 544                        config_flags%nested            ) .and.  &
 545                          ( jte == jde ) .and. open_bc_copy )  THEN
 546
 547           IF  (variable /= 'v' .and. variable /= 'y' ) THEN
 548
 549             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 550               dat(i,jde  ) = dat(i,jde-1)
 551               dat(i,jde+1) = dat(i,jde-1)
 552               dat(i,jde+2) = dat(i,jde-1)
 553             ENDDO
 554
 555           ELSE
 556
 557             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 558               dat(i,jde+1) = dat(i,jde)
 559               dat(i,jde+2) = dat(i,jde)
 560               dat(i,jde+3) = dat(i,jde)
 561             ENDDO
 562
 563           ENDIF
 564
 565         END IF open_ye
 566
 567 !  end open b.c in Y copy into boundary zone addition.  WCS, 19 March 2000
 568
 569       END IF periodicity_y
 570
 571 !  fix corners for doubly periodic domains
 572
 573       IF ( config_flags%periodic_x .and. config_flags%periodic_y &
 574            .and. (ids == ips) .and. (ide == ipe)                 &
 575            .and. (jds == jps) .and. (jde == jpe)                   ) THEN
 576
 577          IF ( (its == ids) .and. (jts == jds) ) THEN  ! lower left corner fill
 578            DO j = 0, -(bdyzone-1), -1
 579            DO i = 0, -(bdyzone-1), -1
 580              dat(ids+i-1,jds+j-1) = dat(ide+i-1,jde+j-1)
 581            ENDDO
 582            ENDDO
 583          END IF
 584
 585          IF ( (ite == ide) .and. (jts == jds) ) THEN  ! lower right corner fill
 586            DO j = 0, -(bdyzone-1), -1
 587            DO i = 1, bdyzone
 588              dat(ide+i+istag,jds+j-1) = dat(ids+i+istag,jde+j-1)
 589            ENDDO
 590            ENDDO
 591          END IF
 592
 593          IF ( (ite == ide) .and. (jte == jde) ) THEN  ! upper right corner fill
 594            DO j = 1, bdyzone
 595            DO i = 1, bdyzone
 596              dat(ide+i+istag,jde+j+jstag) = dat(ids+i+istag,jds+j+jstag)
 597            ENDDO
 598            ENDDO
 599          END IF
 600
 601          IF ( (its == ids) .and. (jte == jde) ) THEN  ! upper left corner fill
 602            DO j = 1, bdyzone
 603            DO i = 0, -(bdyzone-1), -1
 604              dat(ids+i-1,jde+j+jstag) = dat(ide+i-1,jds+j+jstag)
 605            ENDDO
 606            ENDDO
 607          END IF
 608
 609        END IF
 610
 611    END SUBROUTINE set_physical_bc2d
 612
 613 !-----------------------------------
 614
 615    SUBROUTINE set_physical_bc3d( dat, variable_in,        &
 616                                config_flags,                   &
 617                                ids,ide, jds,jde, kds,kde,  & ! domain dims
 618                                ims,ime, jms,jme, kms,kme,  & ! memory dims
 619                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 620                                its,ite, jts,jte, kts,kte )
 621
 622 !  This subroutine sets the data in the boundary region, by direct
 623 !  assignment if possible, for periodic and symmetric (wall)
 624 !  boundary conditions.  Currently, we are only doing 1 variable
 625 !  at a time - lots of overhead, so maybe this routine can be easily
 626 !  inlined later or we could pass multiple variables -
 627 !  would probably want a largestep and smallstep version.
 628
 629 !  15 Jan 99, Dave
 630 !  Modified the incoming its,ite,jts,jte to truly be the tile size.
 631 !  This required modifying the loop limits when the "istag" or "jstag"
 632 !  is used, as this is only required at the end of the domain.
 633
 634       IMPLICIT NONE
 635
 636       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
 637       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
 638       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
 639       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
 640       CHARACTER,    INTENT(IN   )    :: variable_in
 641
 642       CHARACTER                      :: variable
 643
 644       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) :: dat
 645       TYPE( grid_config_rec_type ) config_flags
 646
 647       INTEGER  :: i, j, k, istag, jstag, itime, k_end
 648
 649       LOGICAL  :: debug, open_bc_copy
 650
 651 !------------
 652
 653       debug = .false.
 654
 655       open_bc_copy = .false.
 656
 657       variable = variable_in
 658       IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
 659         variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
 660       ENDIF
 661
 662       IF ((variable == 'u') .or. (variable == 'v') .or.     &
 663           (variable == 'w') .or. (variable == 't') .or.     &
 664           (variable == 'd') .or. (variable == 'e') .or. &
 665           (variable == 'x') .or. (variable == 'y') .or. &
 666           (variable == 'f') .or. (variable == 'r') .or. &
 667           (variable == 'p')                        ) open_bc_copy = .true.
 668
 669 !  begin, first set a staggering variable
 670
 671       istag = -1
 672       jstag = -1
 673       k_end = max(1,min(kde-1,kte))
 674
 675
 676       IF ((variable == 'u') .or. (variable == 'x')) istag = 0
 677       IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
 678       IF ((variable == 'd') .or. (variable == 'xy')) then
 679          istag = 0
 680          jstag = 0
 681       ENDIF
 682       IF ((variable == 'e') ) then
 683          istag = 0
 684          k_end = min(kde,kte)
 685       ENDIF
 686
 687       IF ((variable == 'f') ) then
 688          jstag = 0
 689          k_end = min(kde,kte)
 690       ENDIF
 691
 692       IF ( variable == 'w')  k_end = min(kde,kte)
 693
 694 !      k_end = kte
 695
 696       if(debug) then
 697         write(6,*) ' in bc, var is ',variable, istag, jstag, kte, k_end
 698         write(6,*) ' b.cs are ',  &
 699       config_flags%periodic_x,  &
 700       config_flags%periodic_y
 701       end if
 702
 703
 704
 705 !  periodic conditions.
 706 !  note, patch must cover full range in periodic dir, or else
 707 !  its intra-patch communication that is handled elsewheres.
 708 !  symmetry conditions can always be handled here, because no
 709 !  outside patch communication is needed
 710
 711       periodicity_x:  IF( ( config_flags%periodic_x ) ) THEN
 712
 713         IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN  ! test if both east and west on-processor
 714           IF ( its == ids ) THEN
 715
 716             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 717             DO k = kts, k_end
 718             DO i = 0,-(bdyzone-1),-1
 719               dat(ids+i-1,k,j) = dat(ide+i-1,k,j)
 720             ENDDO
 721             ENDDO
 722             ENDDO
 723
 724           ENDIF
 725
 726
 727           IF ( ite == ide ) THEN
 728
 729             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 730             DO k = kts, k_end
 731             DO i = -istag , bdyzone
 732               dat(ide+i+istag,k,j) = dat(ids+i+istag,k,j)
 733             ENDDO
 734             ENDDO
 735             ENDDO
 736
 737           ENDIF
 738
 739         ENDIF
 740
 741       ELSE
 742
 743         symmetry_xs: IF( ( config_flags%symmetric_xs ) .and.  &
 744                          ( its == ids )                  )  THEN
 745
 746           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
 747
 748             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 749             DO k = kts, k_end
 750             DO i = 1, bdyzone
 751               dat(ids-i,k,j) = dat(ids+i-1,k,j) !  here, dat(0) = dat(1), etc
 752             ENDDO                                 !  symmetry about dat(0.5) (u = 0 pt)
 753             ENDDO
 754             ENDDO
 755
 756           ELSE
 757
 758             IF ( variable == 'u' ) THEN
 759
 760               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 761               DO k = kts, k_end
 762               DO i = 1, bdyzone
 763                 dat(ids-i,k,j) = - dat(ids+i,k,j) ! here, u(0) = - u(2), etc
 764               ENDDO                                 !  normal b.c symmetry at u(1)
 765               ENDDO
 766               ENDDO
 767
 768             ELSE
 769
 770               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 771               DO k = kts, k_end
 772               DO i = 1, bdyzone
 773                 dat(ids-i,k,j) = dat(ids+i,k,j) ! here, phi(0) = phi(2), etc
 774               ENDDO                               !  normal b.c symmetry at phi(1)
 775               ENDDO
 776               ENDDO
 777
 778             END IF
 779
 780           ENDIF
 781
 782         ENDIF symmetry_xs
 783
 784
 785 !  now the symmetry boundary at xe
 786
 787         symmetry_xe: IF( ( config_flags%symmetric_xe ) .and.  &
 788                          ( ite == ide )                  )  THEN
 789
 790           IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
 791
 792             DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 793             DO k = kts, k_end
 794             DO i = 1, bdyzone
 795               dat(ide+i-1,k,j) = dat(ide-i,k,j)  !  sym. about dat(ide-0.5)
 796             ENDDO
 797             ENDDO
 798             ENDDO
 799
 800           ELSE
 801
 802             IF (variable == 'u') THEN
 803
 804               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 805               DO k = kts, k_end
 806               DO i = 1, bdyzone
 807                 dat(ide+i,k,j) = - dat(ide-i,k,j)  ! u(ide+1) = - u(ide-1), etc.
 808               ENDDO
 809               ENDDO
 810               ENDDO
 811
 812             ELSE
 813
 814               DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
 815               DO k = kts, k_end
 816               DO i = 1, bdyzone
 817                 dat(ide+i,k,j) = dat(ide-i,k,j)  ! phi(ide+1) = - phi(ide-1), etc.
 818               ENDDO
 819               ENDDO
 820               ENDDO
 821
 822              END IF
 823
 824           END IF
 825
 826         END IF symmetry_xe
 827
 828 !  set open b.c in X copy into boundary zone here.  WCS, 19 March 2000
 829
 830         open_xs: IF( ( config_flags%open_xs   .or. &
 831                        config_flags%specified .or. &
 832                        config_flags%nested            ) .and.  &
 833                          ( its == ids ) .and. open_bc_copy  )  THEN
 834
 835             DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
 836             DO k = kts, k_end
 837               dat(ids-1,k,j) = dat(ids,k,j) !  here, dat(0) = dat(1), etc
 838               dat(ids-2,k,j) = dat(ids,k,j)
 839               dat(ids-3,k,j) = dat(ids,k,j)
 840             ENDDO
 841             ENDDO
 842
 843         ENDIF open_xs
 844
 845
 846 !  now the open_xe boundary copy
 847
 848         open_xe: IF( ( config_flags%open_xe   .or. &
 849                        config_flags%specified .or. &
 850                        config_flags%nested            ) .and.  &
 851                          ( ite == ide ) .and. open_bc_copy )  THEN
 852
 853           IF (variable /= 'u' .and. variable /= 'x' ) THEN
 854
 855             DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
 856             DO k = kts, k_end
 857               dat(ide  ,k,j) = dat(ide-1,k,j)
 858               dat(ide+1,k,j) = dat(ide-1,k,j)
 859               dat(ide+2,k,j) = dat(ide-1,k,j)
 860             ENDDO
 861             ENDDO
 862
 863           ELSE
 864
 865 !!!!!!! I am not sure about this one!  JM 20020402
 866             DO j = MAX(jds,jts-1)-bdyzone, MIN(jte+1,jde+jstag)+bdyzone
 867             DO k = kts, k_end
 868               dat(ide+1,k,j) = dat(ide,k,j)
 869               dat(ide+2,k,j) = dat(ide,k,j)
 870               dat(ide+3,k,j) = dat(ide,k,j)
 871             ENDDO
 872             ENDDO
 873
 874           END IF
 875
 876         END IF open_xe
 877
 878 !  end open b.c in X copy into boundary zone addition.  WCS, 19 March 2000
 879
 880       END IF periodicity_x
 881
 882 !  same procedure in y
 883
 884       periodicity_y:  IF( ( config_flags%periodic_y ) ) THEN
 885         IF ( ( jds == jps ) .and. ( jde == jpe ) )  THEN      ! test if both north and south on processor
 886           IF( jts == jds ) then
 887
 888             DO j = 0, -(bdyzone-1), -1
 889             DO k = kts, k_end
 890             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 891               dat(i,k,jds+j-1) = dat(i,k,jde+j-1)
 892             ENDDO
 893             ENDDO
 894             ENDDO
 895
 896           END IF
 897
 898           IF( jte == jde ) then
 899
 900             DO j = -jstag, bdyzone
 901             DO k = kts, k_end
 902             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 903               dat(i,k,jde+j+jstag) = dat(i,k,jds+j+jstag)
 904             ENDDO
 905             ENDDO
 906             ENDDO
 907
 908           END IF
 909
 910         END IF
 911
 912       ELSE
 913
 914         symmetry_ys: IF( ( config_flags%symmetric_ys ) .and.  &
 915                          ( jts == jds)                   )  THEN
 916
 917           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
 918
 919             DO j = 1, bdyzone
 920             DO k = kts, k_end
 921             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 922               dat(i,k,jds-j) = dat(i,k,jds+j-1)
 923             ENDDO
 924             ENDDO
 925             ENDDO
 926
 927           ELSE
 928
 929             IF (variable == 'v') THEN
 930
 931               DO j = 1, bdyzone
 932               DO k = kts, k_end
 933               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 934                 dat(i,k,jds-j) = - dat(i,k,jds+j)
 935               ENDDO
 936               ENDDO
 937               ENDDO
 938
 939             ELSE
 940
 941               DO j = 1, bdyzone
 942               DO k = kts, k_end
 943               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 944                 dat(i,k,jds-j) = dat(i,k,jds+j)
 945               ENDDO
 946               ENDDO
 947               ENDDO
 948
 949             END IF
 950
 951           ENDIF
 952
 953         ENDIF symmetry_ys
 954
 955 !  now the symmetry boundary at ye
 956
 957         symmetry_ye: IF( ( config_flags%symmetric_ye ) .and.  &
 958                          ( jte == jde )                  )  THEN
 959
 960           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
 961
 962             DO j = 1, bdyzone
 963             DO k = kts, k_end
 964             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 965               dat(i,k,jde+j-1) = dat(i,k,jde-j)
 966             ENDDO
 967             ENDDO
 968             ENDDO
 969
 970           ELSE
 971
 972             IF ( variable == 'v' ) THEN
 973
 974               DO j = 1, bdyzone
 975               DO k = kts, k_end
 976               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 977                 dat(i,k,jde+j) = - dat(i,k,jde-j)
 978               ENDDO
 979               ENDDO
 980               ENDDO
 981
 982             ELSE
 983
 984               DO j = 1, bdyzone
 985               DO k = kts, k_end
 986               DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
 987                 dat(i,k,jde+j) = dat(i,k,jde-j)
 988               ENDDO
 989               ENDDO
 990               ENDDO
 991
 992             END IF
 993
 994           ENDIF
 995
 996         END IF symmetry_ye
 997
 998 !  set open b.c in Y copy into boundary zone here.  WCS, 19 March 2000
 999
1000         open_ys: IF( ( config_flags%open_ys   .or. &
1001                        config_flags%polar     .or. &
1002                        config_flags%specified .or. &
1003                        config_flags%nested            ) .and.  &
1004                          ( jts == jds) .and. open_bc_copy )  THEN
1005
1006             DO k = kts, k_end
1007             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1008               dat(i,k,jds-1) = dat(i,k,jds)
1009               dat(i,k,jds-2) = dat(i,k,jds)
1010               dat(i,k,jds-3) = dat(i,k,jds)
1011             ENDDO
1012             ENDDO
1013
1014         ENDIF open_ys
1015
1016 !  now the open boundary copy at ye
1017
1018         open_ye: IF( ( config_flags%open_ye   .or. &
1019                        config_flags%polar     .or. &
1020                        config_flags%specified .or. &
1021                        config_flags%nested            ) .and.  &
1022                          ( jte == jde ) .and. open_bc_copy )  THEN
1023
1024           IF (variable /= 'v' .and. variable /= 'y' ) THEN
1025
1026             DO k = kts, k_end
1027             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1028               dat(i,k,jde  ) = dat(i,k,jde-1)
1029               dat(i,k,jde+1) = dat(i,k,jde-1)
1030               dat(i,k,jde+2) = dat(i,k,jde-1)
1031             ENDDO
1032             ENDDO
1033
1034           ELSE
1035
1036             DO k = kts, k_end
1037             DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
1038               dat(i,k,jde+1) = dat(i,k,jde)
1039               dat(i,k,jde+2) = dat(i,k,jde)
1040               dat(i,k,jde+3) = dat(i,k,jde)
1041             ENDDO
1042             ENDDO
1043
1044           ENDIF
1045
1046       END IF open_ye
1047
1048 !  end open b.c in Y copy into boundary zone addition.  WCS, 19 March 2000
1049
1050       END IF periodicity_y
1051
1052 !  fix corners for doubly periodic domains
1053
1054       IF ( config_flags%periodic_x .and. config_flags%periodic_y &
1055            .and. (ids == ips) .and. (ide == ipe)                 &
1056            .and. (jds == jps) .and. (jde == jpe)                   ) THEN
1057
1058          IF ( (its == ids) .and. (jts == jds) ) THEN  ! lower left corner fill
1059            DO j = 0, -(bdyzone-1), -1
1060            DO k = kts, k_end
1061            DO i = 0, -(bdyzone-1), -1
1062              dat(ids+i-1,k,jds+j-1) = dat(ide+i-1,k,jde+j-1)
1063            ENDDO
1064            ENDDO
1065            ENDDO
1066          END IF
1067
1068          IF ( (ite == ide) .and. (jts == jds) ) THEN  ! lower right corner fill
1069            DO j = 0, -(bdyzone-1), -1
1070            DO k = kts, k_end
1071            DO i = 1, bdyzone
1072              dat(ide+i+istag,k,jds+j-1) = dat(ids+i+istag,k,jde+j-1)
1073            ENDDO
1074            ENDDO
1075            ENDDO
1076          END IF
1077
1078          IF ( (ite == ide) .and. (jte == jde) ) THEN  ! upper right corner fill
1079            DO j = 1, bdyzone
1080            DO k = kts, k_end
1081            DO i = 1, bdyzone
1082              dat(ide+i+istag,k,jde+j+jstag) = dat(ids+i+istag,k,jds+j+jstag)
1083            ENDDO
1084            ENDDO
1085            ENDDO
1086          END IF
1087
1088          IF ( (its == ids) .and. (jte == jde) ) THEN  ! upper left corner fill
1089            DO j = 1, bdyzone
1090            DO k = kts, k_end
1091            DO i = 0, -(bdyzone-1), -1
1092              dat(ids+i-1,k,jde+j+jstag) = dat(ide+i-1,k,jds+j+jstag)
1093            ENDDO
1094            ENDDO
1095            ENDDO
1096          END IF
1097
1098        END IF
1099
1100    END SUBROUTINE set_physical_bc3d
1101
1102    SUBROUTINE init_module_bc
1103    END SUBROUTINE init_module_bc
1104
1105 !------------------------------------------------------------------------
1106    SUBROUTINE relax_bdytend   ( field, field_tend,                     &
1107                                 field_bdy_xs, field_bdy_xe,            &
1108                                 field_bdy_ys, field_bdy_ye,            &
1109                                 field_bdy_tend_xs, field_bdy_tend_xe,  &
1110                                 field_bdy_tend_ys, field_bdy_tend_ye,  &
1111                                 variable_in, config_flags,             &
1112                                 spec_bdy_width, spec_zone, relax_zone, &
1113                                 dtbc, fcx, gcx,             &
1114                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
1115                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
1116                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
1117                                 its,ite, jts,jte, kts,kte )
1118
1119 !  This subroutine adds the tendencies in the boundary relaxation region, for specified
1120 !  boundary conditions.
1121 !  spec_bdy_width is only used to dimension the boundary arrays.
1122 !  relax_zone is the inner edge of the boundary relaxation zone treated here.
1123 !  spec_zone is the width of the outer specified b.c.s that are not changed here.
1124 !  (JD July 2000)
1125
1126       IMPLICIT NONE
1127
1128       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
1129       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
1130       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
1131       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
1132       INTEGER,      INTENT(IN   )    :: spec_bdy_width, spec_zone, relax_zone
1133       REAL,         INTENT(IN   )    :: dtbc
1134       CHARACTER,    INTENT(IN   )    :: variable_in
1135
1136
1137       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN   ) :: field
1138       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field_tend
1139       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_xs, field_bdy_xe
1140       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_ys, field_bdy_ye
1141       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_xs, field_bdy_tend_xe
1142       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_ys, field_bdy_tend_ye
1143       REAL,  DIMENSION( spec_bdy_width ), INTENT(IN   ) :: fcx, gcx
1144       TYPE( grid_config_rec_type ) config_flags
1145
1146       CHARACTER  :: variable
1147       INTEGER    :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, im1, ip1
1148       INTEGER    :: b_dist, b_limit
1149       REAL       :: fls0, fls1, fls2, fls3, fls4
1150       LOGICAL    :: periodic_x
1151
1152       periodic_x = config_flags%periodic_x
1153       variable = variable_in
1154
1155       IF (variable == 'U') variable = 'u'
1156       IF (variable == 'V') variable = 'v'
1157       IF (variable == 'M') variable = 'm'
1158       IF (variable == 'H') variable = 'h'
1159
1160       ibs = ids
1161       ibe = ide-1
1162       itf = min(ite,ide-1)
1163       jbs = jds
1164       jbe = jde-1
1165       jtf = min(jte,jde-1)
1166       ktf = kde-1
1167       IF (variable == 'u') ibe = ide
1168       IF (variable == 'u') itf = min(ite,ide)
1169       IF (variable == 'v') jbe = jde
1170       IF (variable == 'v') jtf = min(jte,jde)
1171       IF (variable == 'm') ktf = kte
1172       IF (variable == 'h') ktf = kte
1173
1174       IF (jts - jbs .lt. relax_zone) THEN
1175 ! Y-start boundary
1176         DO j = max(jts,jbs+spec_zone), min(jtf,jbs+relax_zone-1)
1177           b_dist = j - jbs
1178           b_limit = b_dist
1179           IF(periodic_x)b_limit = 0
1180           DO k = kts, ktf
1181             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1182               im1 = max(i-1,ibs)
1183               ip1 = min(i+1,ibe)
1184               fls0 = field_bdy_ys(i, k, b_dist+1) &
1185                    + dtbc * field_bdy_tend_ys(i, k, b_dist+1) &
1186                    - field(i,k,j)
1187               fls1 = field_bdy_ys(im1, k, b_dist+1) &
1188                    + dtbc * field_bdy_tend_ys(im1, k, b_dist+1) &
1189                    - field(im1,k,j)
1190               fls2 = field_bdy_ys(ip1, k, b_dist+1) &
1191                    + dtbc * field_bdy_tend_ys(ip1, k, b_dist+1) &
1192                    - field(ip1,k,j)
1193               fls3 = field_bdy_ys(i, k, b_dist) &
1194                    + dtbc * field_bdy_tend_ys(i, k, b_dist) &
1195                    - field(i,k,j-1)
1196               fls4 = field_bdy_ys(i, k, b_dist+2) &
1197                    + dtbc * field_bdy_tend_ys(i, k, b_dist+2) &
1198                    - field(i,k,j+1)
1199               field_tend(i,k,j) = field_tend(i,k,j) &
1200                                 + fcx(b_dist+1)*fls0 &
1201                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1202             ENDDO
1203           ENDDO
1204         ENDDO
1205       ENDIF
1206
1207       IF (jbe - jtf .lt. relax_zone) THEN
1208 ! Y-end boundary
1209         DO j = max(jts,jbe-relax_zone+1), min(jtf,jbe-spec_zone)
1210           b_dist = jbe - j
1211           b_limit = b_dist
1212           IF(periodic_x)b_limit = 0
1213           DO k = kts, ktf
1214             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1215               im1 = max(i-1,ibs)
1216               ip1 = min(i+1,ibe)
1217               fls0 = field_bdy_ye(i, k, b_dist+1) &
1218                    + dtbc * field_bdy_tend_ye(i, k, b_dist+1) &
1219                    - field(i,k,j)
1220               fls1 = field_bdy_ye(im1, k, b_dist+1) &
1221                    + dtbc * field_bdy_tend_ye(im1, k, b_dist+1) &
1222                    - field(im1,k,j)
1223               fls2 = field_bdy_ye(ip1, k, b_dist+1) &
1224                    + dtbc * field_bdy_tend_ye(ip1, k, b_dist+1) &
1225                    - field(ip1,k,j)
1226               fls3 = field_bdy_ye(i, k, b_dist) &
1227                    + dtbc * field_bdy_tend_ye(i, k, b_dist) &
1228                    - field(i,k,j+1)
1229               fls4 = field_bdy_ye(i, k, b_dist+2) &
1230                    + dtbc * field_bdy_tend_ye(i, k, b_dist+2) &
1231                    - field(i,k,j-1)
1232               field_tend(i,k,j) = field_tend(i,k,j) &
1233                                 + fcx(b_dist+1)*fls0 &
1234                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1235
1236             ENDDO
1237           ENDDO
1238         ENDDO
1239       ENDIF
1240
1241     IF(.NOT.periodic_x)THEN
1242       IF (its - ibs .lt. relax_zone) THEN
1243 ! X-start boundary
1244         DO i = max(its,ibs+spec_zone), min(itf,ibs+relax_zone-1)
1245           b_dist = i - ibs
1246           DO k = kts, ktf
1247             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1248               fls0 = field_bdy_xs(j, k, b_dist+1) &
1249                    + dtbc * field_bdy_tend_xs(j, k, b_dist+1) &
1250                    - field(i,k,j)
1251               fls1 = field_bdy_xs(j-1, k, b_dist+1) &
1252                    + dtbc * field_bdy_tend_xs(j-1, k, b_dist+1) &
1253                    - field(i,k,j-1)
1254               fls2 = field_bdy_xs(j+1, k, b_dist+1) &
1255                    + dtbc * field_bdy_tend_xs(j+1, k, b_dist+1) &
1256                    - field(i,k,j+1)
1257               fls3 = field_bdy_xs(j, k, b_dist) &
1258                    + dtbc * field_bdy_tend_xs(j, k, b_dist) &
1259                    - field(i-1,k,j)
1260               fls4 = field_bdy_xs(j, k, b_dist+2) &
1261                    + dtbc * field_bdy_tend_xs(j, k, b_dist+2) &
1262                    - field(i+1,k,j)
1263               field_tend(i,k,j) = field_tend(i,k,j) &
1264                                 + fcx(b_dist+1)*fls0 &
1265                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1266
1267             ENDDO
1268           ENDDO
1269         ENDDO
1270       ENDIF
1271
1272       IF (ibe - itf .lt. relax_zone) THEN
1273 ! X-end boundary
1274         DO i = max(its,ibe-relax_zone+1), min(itf,ibe-spec_zone)
1275           b_dist = ibe - i
1276           DO k = kts, ktf
1277             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1278               fls0 = field_bdy_xe(j, k, b_dist+1) &
1279                    + dtbc * field_bdy_tend_xe(j, k, b_dist+1) &
1280                    - field(i,k,j)
1281               fls1 = field_bdy_xe(j-1, k, b_dist+1) &
1282                    + dtbc * field_bdy_tend_xe(j-1, k, b_dist+1) &
1283                    - field(i,k,j-1)
1284               fls2 = field_bdy_xe(j+1, k, b_dist+1) &
1285                    + dtbc * field_bdy_tend_xe(j+1, k, b_dist+1) &
1286                    - field(i,k,j+1)
1287               fls3 = field_bdy_xe(j, k, b_dist) &
1288                    + dtbc * field_bdy_tend_xe(j, k, b_dist) &
1289                    - field(i+1,k,j)
1290               fls4 = field_bdy_xe(j, k, b_dist+2) &
1291                    + dtbc * field_bdy_tend_xe(j, k, b_dist+2) &
1292                    - field(i-1,k,j)
1293               field_tend(i,k,j) = field_tend(i,k,j) &
1294                                 + fcx(b_dist+1)*fls0 &
1295                                 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
1296             ENDDO
1297           ENDDO
1298         ENDDO
1299       ENDIF
1300     ENDIF
1301
1302
1303    END SUBROUTINE relax_bdytend
1304 !------------------------------------------------------------------------
1305
1306    SUBROUTINE spec_bdytend   ( field_tend,                           &
1307                                field_bdy_xs, field_bdy_xe,           &
1308                                field_bdy_ys, field_bdy_ye,           &
1309                                field_bdy_tend_xs, field_bdy_tend_xe, &
1310                                field_bdy_tend_ys, field_bdy_tend_ye, &
1311                                variable_in, config_flags, &
1312                                spec_bdy_width, spec_zone, &
1313                                ids,ide, jds,jde, kds,kde,  & ! domain dims
1314                                ims,ime, jms,jme, kms,kme,  & ! memory dims
1315                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
1316                                its,ite, jts,jte, kts,kte )
1317
1318 !  This subroutine sets the tendencies in the boundary specified region.
1319 !  spec_bdy_width is only used to dimension the boundary arrays.
1320 !  spec_zone is the width of the outer specified b.c.s that are set here.
1321 !  (JD July 2000)
1322
1323       IMPLICIT NONE
1324
1325       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
1326       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
1327       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
1328       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
1329       INTEGER,      INTENT(IN   )    :: spec_bdy_width, spec_zone
1330       CHARACTER,    INTENT(IN   )    :: variable_in
1331
1332
1333       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT  ) :: field_tend
1334       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_xs, field_bdy_xe
1335       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_ys, field_bdy_ye
1336       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_xs, field_bdy_tend_xe
1337       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_ys, field_bdy_tend_ye
1338       TYPE( grid_config_rec_type ) config_flags
1339
1340       CHARACTER  :: variable
1341       INTEGER    :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1342       INTEGER    :: b_dist, b_limit
1343       LOGICAL    :: periodic_x
1344
1345       periodic_x = config_flags%periodic_x
1346
1347       variable = variable_in
1348
1349       IF (variable == 'U') variable = 'u'
1350       IF (variable == 'V') variable = 'v'
1351       IF (variable == 'M') variable = 'm'
1352       IF (variable == 'H') variable = 'h'
1353
1354       ibs = ids
1355       ibe = ide-1
1356       itf = min(ite,ide-1)
1357       jbs = jds
1358       jbe = jde-1
1359       jtf = min(jte,jde-1)
1360       ktf = kde-1
1361       IF (variable == 'u') ibe = ide
1362       IF (variable == 'u') itf = min(ite,ide)
1363       IF (variable == 'v') jbe = jde
1364       IF (variable == 'v') jtf = min(jte,jde)
1365       IF (variable == 'm') ktf = kte
1366       IF (variable == 'h') ktf = kte
1367
1368       IF (jts - jbs .lt. spec_zone) THEN
1369 ! Y-start boundary
1370         DO j = jts, min(jtf,jbs+spec_zone-1)
1371           b_dist = j - jbs
1372           b_limit = b_dist
1373           IF(periodic_x)b_limit = 0
1374           DO k = kts, ktf
1375             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1376               field_tend(i,k,j) = field_bdy_tend_ys(i, k, b_dist+1)
1377             ENDDO
1378           ENDDO
1379         ENDDO
1380       ENDIF
1381       IF (jbe - jtf .lt. spec_zone) THEN
1382 ! Y-end boundary
1383         DO j = max(jts,jbe-spec_zone+1), jtf
1384           b_dist = jbe - j
1385           b_limit = b_dist
1386           IF(periodic_x)b_limit = 0
1387           DO k = kts, ktf
1388             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1389               field_tend(i,k,j) = field_bdy_tend_ye(i, k, b_dist+1)
1390             ENDDO
1391           ENDDO
1392         ENDDO
1393       ENDIF
1394
1395     IF(.NOT.periodic_x)THEN
1396       IF (its - ibs .lt. spec_zone) THEN
1397 ! X-start boundary
1398         DO i = its, min(itf,ibs+spec_zone-1)
1399           b_dist = i - ibs
1400           DO k = kts, ktf
1401             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1402               field_tend(i,k,j) = field_bdy_tend_xs(j, k, b_dist+1)
1403             ENDDO
1404           ENDDO
1405         ENDDO
1406       ENDIF
1407
1408       IF (ibe - itf .lt. spec_zone) THEN
1409 ! X-end boundary
1410         DO i = max(its,ibe-spec_zone+1), itf
1411           b_dist = ibe - i
1412           DO k = kts, ktf
1413             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1414               field_tend(i,k,j) = field_bdy_tend_xe(j, k, b_dist+1)
1415             ENDDO
1416           ENDDO
1417         ENDDO
1418       ENDIF
1419     ENDIF
1420
1421    END SUBROUTINE spec_bdytend
1422 !------------------------------------------------------------------------
1423
1424    SUBROUTINE spec_bdyfield   ( field,                     &
1425                                field_bdy_xs, field_bdy_xe,           &
1426                                field_bdy_ys, field_bdy_ye,           &
1427                                variable_in, config_flags,  &
1428                                spec_bdy_width, spec_zone, &
1429                                ids,ide, jds,jde, kds,kde,  & ! domain dims
1430                                ims,ime, jms,jme, kms,kme,  & ! memory dims
1431                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
1432                                its,ite, jts,jte, kts,kte )
1433
1434 !  This subroutine sets the tendencies in the boundary specified region.
1435 !  spec_bdy_width is only used to dimension the boundary arrays.
1436 !  spec_zone is the width of the outer specified b.c.s that are set here.
1437 !  (JD July 2000)
1438
1439       IMPLICIT NONE
1440
1441       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
1442       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
1443       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
1444       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
1445       INTEGER,      INTENT(IN   )    :: spec_bdy_width, spec_zone
1446       CHARACTER,    INTENT(IN   )    :: variable_in
1447
1448
1449       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT  ) :: field
1450       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_xs, field_bdy_xe
1451       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_ys, field_bdy_ye
1452       TYPE( grid_config_rec_type ) config_flags
1453
1454       CHARACTER  :: variable
1455       INTEGER    :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1456       INTEGER    :: b_dist, b_limit
1457       LOGICAL    :: periodic_x
1458
1459       periodic_x = config_flags%periodic_x
1460
1461       variable = variable_in
1462
1463       IF (variable == 'U') variable = 'u'
1464       IF (variable == 'V') variable = 'v'
1465       IF (variable == 'M') variable = 'm'
1466       IF (variable == 'H') variable = 'h'
1467
1468       ibs = ids
1469       ibe = ide-1
1470       itf = min(ite,ide-1)
1471       jbs = jds
1472       jbe = jde-1
1473       jtf = min(jte,jde-1)
1474       ktf = kde-1
1475       IF (variable == 'u') ibe = ide
1476       IF (variable == 'u') itf = min(ite,ide)
1477       IF (variable == 'v') jbe = jde
1478       IF (variable == 'v') jtf = min(jte,jde)
1479       IF (variable == 'm') ktf = kte
1480       IF (variable == 'h') ktf = kte
1481
1482       IF (jts - jbs .lt. spec_zone) THEN
1483 ! Y-start boundary
1484         DO j = jts, min(jtf,jbs+spec_zone-1)
1485           b_dist = j - jbs
1486           b_limit = b_dist
1487           IF(periodic_x)b_limit = 0
1488           DO k = kts, ktf
1489             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1490               field(i,k,j) = field_bdy_ys(i, k, b_dist+1)
1491             ENDDO
1492           ENDDO
1493         ENDDO
1494       ENDIF
1495       IF (jbe - jtf .lt. spec_zone) THEN
1496 ! Y-end boundary
1497         DO j = max(jts,jbe-spec_zone+1), jtf
1498           b_dist = jbe - j
1499           b_limit = b_dist
1500           IF(periodic_x)b_limit = 0
1501           DO k = kts, ktf
1502             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1503               field(i,k,j) = field_bdy_ye(i, k, b_dist+1)
1504             ENDDO
1505           ENDDO
1506         ENDDO
1507       ENDIF
1508
1509     IF(.NOT.periodic_x)THEN
1510       IF (its - ibs .lt. spec_zone) THEN
1511 ! X-start boundary
1512         DO i = its, min(itf,ibs+spec_zone-1)
1513           b_dist = i - ibs
1514           DO k = kts, ktf
1515             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1516               field(i,k,j) = field_bdy_xs(j, k, b_dist+1)
1517             ENDDO
1518           ENDDO
1519         ENDDO
1520       ENDIF
1521
1522       IF (ibe - itf .lt. spec_zone) THEN
1523 ! X-end boundary
1524         DO i = max(its,ibe-spec_zone+1), itf
1525           b_dist = ibe - i
1526           DO k = kts, ktf
1527             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1528               field(i,k,j) = field_bdy_xe(j, k, b_dist+1)
1529             ENDDO
1530           ENDDO
1531         ENDDO
1532       ENDIF
1533     ENDIF
1534
1535    END SUBROUTINE spec_bdyfield
1536 !------------------------------------------------------------------------
1537
1538    SUBROUTINE spec_bdyupdate(  field,      &
1539                                field_tend, dt,            &
1540                                variable_in, config_flags, &
1541                                spec_zone,                  &
1542                                ids,ide, jds,jde, kds,kde,  & ! domain dims
1543                                ims,ime, jms,jme, kms,kme,  & ! memory dims
1544                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
1545                                its,ite, jts,jte, kts,kte )
1546
1547 !  This subroutine adds the tendencies in the boundary specified region.
1548 !  spec_zone is the width of the outer specified b.c.s that are set here.
1549 !  (JD August 2000)
1550
1551       IMPLICIT NONE
1552
1553       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
1554       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
1555       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
1556       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
1557       INTEGER,      INTENT(IN   )    :: spec_zone
1558       CHARACTER,    INTENT(IN   )    :: variable_in
1559       REAL,         INTENT(IN   )    :: dt
1560
1561
1562       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1563       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN   ) :: field_tend
1564       TYPE( grid_config_rec_type ) config_flags
1565
1566       CHARACTER  :: variable
1567       INTEGER    :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
1568       INTEGER    :: b_dist, b_limit
1569       LOGICAL    :: periodic_x
1570
1571       periodic_x = config_flags%periodic_x
1572
1573       variable = variable_in
1574
1575       IF (variable == 'U') variable = 'u'
1576       IF (variable == 'V') variable = 'v'
1577       IF (variable == 'M') variable = 'm'
1578       IF (variable == 'H') variable = 'h'
1579
1580       ibs = ids
1581       ibe = ide-1
1582       itf = min(ite,ide-1)
1583       jbs = jds
1584       jbe = jde-1
1585       jtf = min(jte,jde-1)
1586       ktf = kde-1
1587       IF (variable == 'u') ibe = ide
1588       IF (variable == 'u') itf = min(ite,ide)
1589       IF (variable == 'v') jbe = jde
1590       IF (variable == 'v') jtf = min(jte,jde)
1591       IF (variable == 'm') ktf = kte
1592       IF (variable == 'h') ktf = kte
1593
1594       IF (jts - jbs .lt. spec_zone) THEN
1595 ! Y-start boundary
1596         DO j = jts, min(jtf,jbs+spec_zone-1)
1597           b_dist = j - jbs
1598           b_limit = b_dist
1599           IF(periodic_x)b_limit = 0
1600           DO k = kts, ktf
1601             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1602               field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1603             ENDDO
1604           ENDDO
1605         ENDDO
1606       ENDIF
1607       IF (jbe - jtf .lt. spec_zone) THEN
1608 ! Y-end boundary
1609         DO j = max(jts,jbe-spec_zone+1), jtf
1610           b_dist = jbe - j
1611           b_limit = b_dist
1612           IF(periodic_x)b_limit = 0
1613           DO k = kts, ktf
1614             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1615               field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1616             ENDDO
1617           ENDDO
1618         ENDDO
1619       ENDIF
1620
1621     IF(.NOT.periodic_x)THEN
1622       IF (its - ibs .lt. spec_zone) THEN
1623 ! X-start boundary
1624         DO i = its, min(itf,ibs+spec_zone-1)
1625           b_dist = i - ibs
1626           DO k = kts, ktf
1627             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1628               field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1629             ENDDO
1630           ENDDO
1631         ENDDO
1632       ENDIF
1633
1634       IF (ibe - itf .lt. spec_zone) THEN
1635 ! X-end boundary
1636         DO i = max(its,ibe-spec_zone+1), itf
1637           b_dist = ibe - i
1638           DO k = kts, ktf
1639             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1640               field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
1641             ENDDO
1642           ENDDO
1643         ENDDO
1644       ENDIF
1645     ENDIF
1646
1647    END SUBROUTINE spec_bdyupdate
1648 !------------------------------------------------------------------------
1649
1650    SUBROUTINE zero_grad_bdy (  field,                     &
1651                                variable_in, config_flags, &
1652                                spec_zone,                  &
1653                                ids,ide, jds,jde, kds,kde,  & ! domain dims
1654                                ims,ime, jms,jme, kms,kme,  & ! memory dims
1655                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
1656                                its,ite, jts,jte, kts,kte )
1657
1658 !  This subroutine sets zero gradient conditions in the boundary specified region.
1659 !  spec_zone is the width of the outer specified b.c.s that are set here.
1660 !  (JD August 2000)
1661
1662       IMPLICIT NONE
1663
1664       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
1665       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
1666       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
1667       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
1668       INTEGER,      INTENT(IN   )    :: spec_zone
1669       CHARACTER,    INTENT(IN   )    :: variable_in
1670
1671
1672       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1673       TYPE( grid_config_rec_type ) config_flags
1674
1675       CHARACTER  :: variable
1676       INTEGER    :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1677       INTEGER    :: b_dist, b_limit
1678       LOGICAL    :: periodic_x
1679
1680       periodic_x = config_flags%periodic_x
1681
1682       variable = variable_in
1683
1684       IF (variable == 'U') variable = 'u'
1685       IF (variable == 'V') variable = 'v'
1686
1687       ibs = ids
1688       ibe = ide-1
1689       itf = min(ite,ide-1)
1690       jbs = jds
1691       jbe = jde-1
1692       jtf = min(jte,jde-1)
1693       ktf = kde-1
1694       IF (variable == 'u') ibe = ide
1695       IF (variable == 'u') itf = min(ite,ide)
1696       IF (variable == 'v') jbe = jde
1697       IF (variable == 'v') jtf = min(jte,jde)
1698       IF (variable == 'w') ktf = kde
1699
1700       IF (jts - jbs .lt. spec_zone) THEN
1701 ! Y-start boundary
1702         DO j = jts, min(jtf,jbs+spec_zone-1)
1703           b_dist = j - jbs
1704           b_limit = b_dist
1705           IF(periodic_x)b_limit = 0
1706           DO k = kts, ktf
1707             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1708               i_inner = max(i,ibs+spec_zone)
1709               i_inner = min(i_inner,ibe-spec_zone)
1710               IF(periodic_x)i_inner = i
1711               field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1712             ENDDO
1713           ENDDO
1714         ENDDO
1715       ENDIF
1716       IF (jbe - jtf .lt. spec_zone) THEN
1717 ! Y-end boundary
1718         DO j = max(jts,jbe-spec_zone+1), jtf
1719           b_dist = jbe - j
1720           b_limit = b_dist
1721           IF(periodic_x)b_limit = 0
1722           DO k = kts, ktf
1723             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1724               i_inner = max(i,ibs+spec_zone)
1725               i_inner = min(i_inner,ibe-spec_zone)
1726               IF(periodic_x)i_inner = i
1727               field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1728             ENDDO
1729           ENDDO
1730         ENDDO
1731       ENDIF
1732
1733     IF(.NOT.periodic_x)THEN
1734       IF (its - ibs .lt. spec_zone) THEN
1735 ! X-start boundary
1736         DO i = its, min(itf,ibs+spec_zone-1)
1737           b_dist = i - ibs
1738           DO k = kts, ktf
1739             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1740               j_inner = max(j,jbs+spec_zone)
1741               j_inner = min(j_inner,jbe-spec_zone)
1742               field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1743             ENDDO
1744           ENDDO
1745         ENDDO
1746       ENDIF
1747
1748       IF (ibe - itf .lt. spec_zone) THEN
1749 ! X-end boundary
1750         DO i = max(its,ibe-spec_zone+1), itf
1751           b_dist = ibe - i
1752           DO k = kts, ktf
1753             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1754               j_inner = max(j,jbs+spec_zone)
1755               j_inner = min(j_inner,jbe-spec_zone)
1756               field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1757             ENDDO
1758           ENDDO
1759         ENDDO
1760       ENDIF
1761     ENDIF
1762
1763    END SUBROUTINE zero_grad_bdy
1764 !------------------------------------------------------------------------
1765
1766    SUBROUTINE flow_dep_bdy  (  field,                     &
1767                                u, v, config_flags, &
1768                                spec_zone,                  &
1769                                ids,ide, jds,jde, kds,kde,  & ! domain dims
1770                                ims,ime, jms,jme, kms,kme,  & ! memory dims
1771                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
1772                                its,ite, jts,jte, kts,kte )
1773
1774 !  This subroutine sets zero gradient conditions for outflow and zero value
1775 !  for inflow in the boundary specified region. Note that field must be unstaggered.
1776 !  The velocities, u and v, will only be used to check their sign (coupled vels OK)
1777 !  spec_zone is the width of the outer specified b.c.s that are set here.
1778 !  (JD August 2000)
1779
1780       IMPLICIT NONE
1781
1782       INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
1783       INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
1784       INTEGER,      INTENT(IN   )    :: ips,ipe, jps,jpe, kps,kpe
1785       INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
1786       INTEGER,      INTENT(IN   )    :: spec_zone
1787
1788
1789       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
1790       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN   ) :: u
1791       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN   ) :: v
1792       TYPE( grid_config_rec_type ) config_flags
1793
1794       INTEGER    :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
1795       INTEGER    :: b_dist, b_limit
1796       LOGICAL    :: periodic_x
1797
1798       periodic_x = config_flags%periodic_x
1799
1800       ibs = ids
1801       ibe = ide-1
1802       itf = min(ite,ide-1)
1803       jbs = jds
1804       jbe = jde-1
1805       jtf = min(jte,jde-1)
1806       ktf = kde-1
1807
1808       IF (jts - jbs .lt. spec_zone) THEN
1809 ! Y-start boundary
1810         DO j = jts, min(jtf,jbs+spec_zone-1)
1811           b_dist = j - jbs
1812           b_limit = b_dist
1813           IF(periodic_x)b_limit = 0
1814           DO k = kts, ktf
1815             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1816               i_inner = max(i,ibs+spec_zone)
1817               i_inner = min(i_inner,ibe-spec_zone)
1818               IF(periodic_x)i_inner = i
1819               IF(v(i,k,j) .lt. 0.)THEN
1820                 field(i,k,j) = field(i_inner,k,jbs+spec_zone)
1821               ELSE
1822                 field(i,k,j) = 0.
1823               ENDIF
1824             ENDDO
1825           ENDDO
1826         ENDDO
1827       ENDIF
1828       IF (jbe - jtf .lt. spec_zone) THEN
1829 ! Y-end boundary
1830         DO j = max(jts,jbe-spec_zone+1), jtf
1831           b_dist = jbe - j
1832           b_limit = b_dist
1833           IF(periodic_x)b_limit = 0
1834           DO k = kts, ktf
1835             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
1836               i_inner = max(i,ibs+spec_zone)
1837               i_inner = min(i_inner,ibe-spec_zone)
1838               IF(periodic_x)i_inner = i
1839               IF(v(i,k,j+1) .gt. 0.)THEN
1840                 field(i,k,j) = field(i_inner,k,jbe-spec_zone)
1841               ELSE
1842                 field(i,k,j) = 0.
1843               ENDIF
1844             ENDDO
1845           ENDDO
1846         ENDDO
1847       ENDIF
1848
1849     IF(.NOT.periodic_x)THEN
1850       IF (its - ibs .lt. spec_zone) THEN
1851 ! X-start boundary
1852         DO i = its, min(itf,ibs+spec_zone-1)
1853           b_dist = i - ibs
1854           DO k = kts, ktf
1855             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1856               j_inner = max(j,jbs+spec_zone)
1857               j_inner = min(j_inner,jbe-spec_zone)
1858               IF(u(i,k,j) .lt. 0.)THEN
1859                 field(i,k,j) = field(ibs+spec_zone,k,j_inner)
1860               ELSE
1861                 field(i,k,j) = 0.
1862               ENDIF
1863             ENDDO
1864           ENDDO
1865         ENDDO
1866       ENDIF
1867
1868       IF (ibe - itf .lt. spec_zone) THEN
1869 ! X-end boundary
1870         DO i = max(its,ibe-spec_zone+1), itf
1871           b_dist = ibe - i
1872           DO k = kts, ktf
1873             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
1874               j_inner = max(j,jbs+spec_zone)
1875               j_inner = min(j_inner,jbe-spec_zone)
1876               IF(u(i+1,k,j) .gt. 0.)THEN
1877                 field(i,k,j) = field(ibe-spec_zone,k,j_inner)
1878               ELSE
1879                 field(i,k,j) = 0.
1880               ENDIF
1881             ENDDO
1882           ENDDO
1883         ENDDO
1884       ENDIF
1885     ENDIF
1886
1887    END SUBROUTINE flow_dep_bdy
1888
1889 !------------------------------------------------------------------------------
1890
1891  SUBROUTINE stuff_bdy_new ( data3d , space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
1892                              char_stagger , &
1893                              spec_bdy_width , &
1894                              ids, ide, jds, jde, kds, kde , &
1895                              ims, ime, jms, jme, kms, kme , &
1896                              its, ite, jts, jte, kts, kte )
1897
1898  !  This routine puts the data in the 3d arrays into the proper locations
1899  !  for the lateral boundary arrays.
1900
1901     USE module_state_description
1902
1903     IMPLICIT NONE
1904
1905     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1906     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1907     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1908     INTEGER , INTENT(IN) :: spec_bdy_width
1909     REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d
1910     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
1911     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
1912     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1913
1914     INTEGER :: i , ii , j , jj , k
1915
1916     !  There are four lateral boundary locations that are stored.
1917
1918     !  X start boundary
1919
1920     IF ( char_stagger .EQ. 'W' ) THEN
1921        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1922        DO k = kds , kde
1923        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1924           space_bdy_xs(j,k,i) = data3d(i,k,j)
1925        END DO
1926        END DO
1927        END DO
1928     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1929        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1930        DO k = kds , kde
1931        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1932           space_bdy_xs(j,k,i) = data3d(i,k,j)
1933        END DO
1934        END DO
1935        END DO
1936     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1937        DO j = MAX(jds,jts) , MIN(jde,jte)
1938        DO k = kds , kde - 1
1939        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1940           space_bdy_xs(j,k,i) = data3d(i,k,j)
1941        END DO
1942        END DO
1943        END DO
1944     ELSE
1945        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1946        DO k = kds , kde - 1
1947        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1948           space_bdy_xs(j,k,i) = data3d(i,k,j)
1949        END DO
1950        END DO
1951        END DO
1952     END IF
1953
1954     !  X end boundary
1955
1956     IF      ( char_stagger .EQ. 'U' ) THEN
1957        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1958        DO k = kds , kde - 1
1959        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
1960           ii = ide - i + 1
1961           space_bdy_xe(j,k,ii) = data3d(i,k,j)
1962        END DO
1963        END DO
1964        END DO
1965     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1966        DO j = MAX(jds,jts) , MIN(jde,jte)
1967        DO k = kds , kde - 1
1968        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1969           ii = ide - i
1970           space_bdy_xe(j,k,ii) = data3d(i,k,j)
1971        END DO
1972        END DO
1973        END DO
1974     ELSE IF ( char_stagger .EQ. 'W' ) THEN
1975        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1976        DO k = kds , kde
1977        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1978           ii = ide - i
1979           space_bdy_xe(j,k,ii) = data3d(i,k,j)
1980        END DO
1981        END DO
1982        END DO
1983     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1984        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1985        DO k = kds , kde
1986        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1987           ii = ide - i
1988           space_bdy_xe(j,k,ii) = data3d(i,k,j)
1989        END DO
1990        END DO
1991        END DO
1992     ELSE
1993        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1994        DO k = kds , kde - 1
1995        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1996           ii = ide - i
1997           space_bdy_xe(j,k,ii) = data3d(i,k,j)
1998        END DO
1999        END DO
2000        END DO
2001     END IF
2002
2003     !  Y start boundary
2004
2005     IF ( char_stagger .EQ. 'W' ) THEN
2006        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2007        DO k = kds , kde
2008        DO i = MAX(ids,its) , MIN(ide-1,ite)
2009           space_bdy_ys(i,k,j) = data3d(i,k,j)
2010        END DO
2011        END DO
2012        END DO
2013     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2014        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2015        DO k = kds , kde
2016        DO i = MAX(ids,its) , MIN(ide-1,ite)
2017           space_bdy_ys(i,k,j) = data3d(i,k,j)
2018        END DO
2019        END DO
2020        END DO
2021     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2022        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2023        DO k = kds , kde - 1
2024        DO i = MAX(ids,its) , MIN(ide,ite)
2025           space_bdy_ys(i,k,j) = data3d(i,k,j)
2026        END DO
2027        END DO
2028        END DO
2029     ELSE
2030        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2031        DO k = kds , kde - 1
2032        DO i = MAX(ids,its) , MIN(ide-1,ite)
2033           space_bdy_ys(i,k,j) = data3d(i,k,j)
2034        END DO
2035        END DO
2036        END DO
2037     END IF
2038
2039     !  Y end boundary
2040
2041     IF      ( char_stagger .EQ. 'V' ) THEN
2042        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2043        DO k = kds , kde - 1
2044        DO i = MAX(ids,its) , MIN(ide-1,ite)
2045           jj = jde - j + 1
2046           space_bdy_ye(i,k,jj) = data3d(i,k,j)
2047        END DO
2048        END DO
2049        END DO
2050     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2051        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2052        DO k = kds , kde - 1
2053        DO i = MAX(ids,its) , MIN(ide,ite)
2054           jj = jde - j
2055           space_bdy_ye(i,k,jj) = data3d(i,k,j)
2056        END DO
2057        END DO
2058        END DO
2059     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2060        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2061        DO k = kds , kde
2062        DO i = MAX(ids,its) , MIN(ide-1,ite)
2063           jj = jde - j
2064           space_bdy_ye(i,k,jj) = data3d(i,k,j)
2065        END DO
2066        END DO
2067        END DO
2068     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2069        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2070        DO k = kds , kde
2071        DO i = MAX(ids,its) , MIN(ide-1,ite)
2072           jj = jde - j
2073           space_bdy_ye(i,k,jj) = data3d(i,k,j)
2074        END DO
2075        END DO
2076        END DO
2077     ELSE
2078        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2079        DO k = kds , kde - 1
2080        DO i = MAX(ids,its) , MIN(ide-1,ite)
2081           jj = jde - j
2082           space_bdy_ye(i,k,jj) = data3d(i,k,j)
2083        END DO
2084        END DO
2085        END DO
2086     END IF
2087
2088  END SUBROUTINE stuff_bdy_new
2089
2090  SUBROUTINE stuff_bdytend_new ( data3dnew , data3dold , time_diff , &
2091                              space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
2092                              char_stagger , &
2093                              spec_bdy_width , &
2094                              ids, ide, jds, jde, kds, kde , &
2095                              ims, ime, jms, jme, kms, kme , &
2096                              its, ite, jts, jte, kts, kte )
2097
2098  !  This routine puts the tendency data into the proper locations
2099  !  for the lateral boundary arrays.
2100
2101     USE module_state_description
2102
2103     IMPLICIT NONE
2104
2105     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2106     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2107     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2108     INTEGER , INTENT(IN) :: spec_bdy_width
2109     REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2110     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2111     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2112     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2113     REAL , INTENT(IN) :: time_diff ! seconds
2114
2115     INTEGER :: i , ii , j , jj , k
2116
2117     !  There are four lateral boundary locations that are stored.
2118
2119     !  X start boundary
2120
2121     IF ( char_stagger .EQ. 'W' ) THEN
2122        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2123        DO k = kds , kde
2124        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2125           space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2126        END DO
2127        END DO
2128        END DO
2129     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2130        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2131        DO k = kds , kde
2132        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2133           space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2134        END DO
2135        END DO
2136        END DO
2137     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2138        DO j = MAX(jds,jts) , MIN(jde,jte)
2139        DO k = kds , kde - 1
2140        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2141           space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2142        END DO
2143        END DO
2144        END DO
2145     ELSE
2146        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2147        DO k = kds , kde - 1
2148        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2149           space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2150        END DO
2151        END DO
2152        END DO
2153     END IF
2154
2155     !  X end boundary
2156
2157     IF      ( char_stagger .EQ. 'U' ) THEN
2158        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2159        DO k = kds , kde - 1
2160        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2161           ii = ide - i + 1
2162           space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2163        END DO
2164        END DO
2165        END DO
2166     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2167        DO j = MAX(jds,jts) , MIN(jde,jte)
2168        DO k = kds , kde - 1
2169        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2170           ii = ide - i
2171           space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2172        END DO
2173        END DO
2174        END DO
2175     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2176        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2177        DO k = kds , kde
2178        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2179           ii = ide - i
2180           space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2181        END DO
2182        END DO
2183        END DO
2184     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2185        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2186        DO k = kds , kde
2187        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2188           ii = ide - i
2189           space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2190        END DO
2191        END DO
2192        END DO
2193     ELSE
2194        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2195        DO k = kds , kde - 1
2196        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2197           ii = ide - i
2198           space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2199        END DO
2200        END DO
2201        END DO
2202     END IF
2203
2204     !  Y start boundary
2205
2206     IF ( char_stagger .EQ. 'W' ) THEN
2207        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2208        DO k = kds , kde
2209        DO i = MAX(ids,its) , MIN(ide-1,ite)
2210           space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2211        END DO
2212        END DO
2213        END DO
2214     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2215        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2216        DO k = kds , kde
2217        DO i = MAX(ids,its) , MIN(ide-1,ite)
2218           space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2219        END DO
2220        END DO
2221        END DO
2222     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2223        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2224        DO k = kds , kde - 1
2225        DO i = MAX(ids,its) , MIN(ide,ite)
2226           space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2227        END DO
2228        END DO
2229        END DO
2230     ELSE
2231        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2232        DO k = kds , kde - 1
2233        DO i = MAX(ids,its) , MIN(ide-1,ite)
2234           space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2235        END DO
2236        END DO
2237        END DO
2238     END IF
2239
2240     !  Y end boundary
2241
2242     IF      ( char_stagger .EQ. 'V' ) THEN
2243        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2244        DO k = kds , kde - 1
2245        DO i = MAX(ids,its) , MIN(ide-1,ite)
2246           jj = jde - j + 1
2247           space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2248        END DO
2249        END DO
2250        END DO
2251     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2252        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2253        DO k = kds , kde - 1
2254        DO i = MAX(ids,its) , MIN(ide,ite)
2255           jj = jde - j
2256           space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2257        END DO
2258        END DO
2259        END DO
2260     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2261        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2262        DO k = kds , kde
2263        DO i = MAX(ids,its) , MIN(ide-1,ite)
2264           jj = jde - j
2265           space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2266        END DO
2267        END DO
2268        END DO
2269     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2270        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2271        DO k = kds , kde
2272        DO i = MAX(ids,its) , MIN(ide-1,ite)
2273           jj = jde - j
2274           space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2275        END DO
2276        END DO
2277        END DO
2278     ELSE
2279        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2280        DO k = kds , kde - 1
2281        DO i = MAX(ids,its) , MIN(ide-1,ite)
2282           jj = jde - j
2283           space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2284        END DO
2285        END DO
2286        END DO
2287     END IF
2288
2289  END SUBROUTINE stuff_bdytend_new
2290
2291 !--- old versions for use with modules that use the old bdy data structures ---
2292
2293  SUBROUTINE stuff_bdy_old ( data3d , space_bdy , char_stagger , &
2294                              ijds , ijde , spec_bdy_width , &
2295                              ids, ide, jds, jde, kds, kde , &
2296                              ims, ime, jms, jme, kms, kme , &
2297                              its, ite, jts, jte, kts, kte )
2298
2299  !  This routine puts the data in the 3d arrays into the proper locations
2300  !  for the lateral boundary arrays.
2301
2302     USE module_state_description
2303
2304     IMPLICIT NONE
2305
2306     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2307     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2308     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2309     INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
2310     REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d
2311     REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy
2312     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2313
2314     INTEGER :: i , ii , j , jj , k
2315
2316     !  There are four lateral boundary locations that are stored.
2317
2318     !  X start boundary
2319
2320     IF ( char_stagger .EQ. 'W' ) THEN
2321        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2322        DO k = kds , kde
2323        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2324           space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2325        END DO
2326        END DO
2327        END DO
2328     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2329        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2330        DO k = kds , kde
2331        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2332           space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2333        END DO
2334        END DO
2335        END DO
2336     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2337        DO j = MAX(jds,jts) , MIN(jde,jte)
2338        DO k = kds , kde - 1
2339        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2340           space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2341        END DO
2342        END DO
2343        END DO
2344     ELSE
2345        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2346        DO k = kds , kde - 1
2347        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2348           space_bdy(j,k,i,P_XSB) = data3d(i,k,j)
2349        END DO
2350        END DO
2351        END DO
2352     END IF
2353
2354     !  X end boundary
2355
2356     IF      ( char_stagger .EQ. 'U' ) THEN
2357        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2358        DO k = kds , kde - 1
2359        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2360           ii = ide - i + 1
2361           space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2362        END DO
2363        END DO
2364        END DO
2365     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2366        DO j = MAX(jds,jts) , MIN(jde,jte)
2367        DO k = kds , kde - 1
2368        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2369           ii = ide - i
2370           space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2371        END DO
2372        END DO
2373        END DO
2374     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2375        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2376        DO k = kds , kde
2377        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2378           ii = ide - i
2379           space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2380        END DO
2381        END DO
2382        END DO
2383     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2384        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2385        DO k = kds , kde
2386        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2387           ii = ide - i
2388           space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2389        END DO
2390        END DO
2391        END DO
2392     ELSE
2393        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2394        DO k = kds , kde - 1
2395        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2396           ii = ide - i
2397           space_bdy(j,k,ii,P_XEB) = data3d(i,k,j)
2398        END DO
2399        END DO
2400        END DO
2401     END IF
2402
2403     !  Y start boundary
2404
2405     IF ( char_stagger .EQ. 'W' ) THEN
2406        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2407        DO k = kds , kde
2408        DO i = MAX(ids,its) , MIN(ide-1,ite)
2409           space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2410        END DO
2411        END DO
2412        END DO
2413     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2414        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2415        DO k = kds , kde
2416        DO i = MAX(ids,its) , MIN(ide-1,ite)
2417           space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2418        END DO
2419        END DO
2420        END DO
2421     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2422        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2423        DO k = kds , kde - 1
2424        DO i = MAX(ids,its) , MIN(ide,ite)
2425           space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2426        END DO
2427        END DO
2428        END DO
2429     ELSE
2430        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2431        DO k = kds , kde - 1
2432        DO i = MAX(ids,its) , MIN(ide-1,ite)
2433           space_bdy(i,k,j,P_YSB) = data3d(i,k,j)
2434        END DO
2435        END DO
2436        END DO
2437     END IF
2438
2439     !  Y end boundary
2440
2441     IF      ( char_stagger .EQ. 'V' ) THEN
2442        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2443        DO k = kds , kde - 1
2444        DO i = MAX(ids,its) , MIN(ide-1,ite)
2445           jj = jde - j + 1
2446           space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2447        END DO
2448        END DO
2449        END DO
2450     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2451        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2452        DO k = kds , kde - 1
2453        DO i = MAX(ids,its) , MIN(ide,ite)
2454           jj = jde - j
2455           space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2456        END DO
2457        END DO
2458        END DO
2459     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2460        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2461        DO k = kds , kde
2462        DO i = MAX(ids,its) , MIN(ide-1,ite)
2463           jj = jde - j
2464           space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2465        END DO
2466        END DO
2467        END DO
2468     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2469        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2470        DO k = kds , kde
2471        DO i = MAX(ids,its) , MIN(ide-1,ite)
2472           jj = jde - j
2473           space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2474        END DO
2475        END DO
2476        END DO
2477     ELSE
2478        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2479        DO k = kds , kde - 1
2480        DO i = MAX(ids,its) , MIN(ide-1,ite)
2481           jj = jde - j
2482           space_bdy(i,k,jj,P_YEB) = data3d(i,k,j)
2483        END DO
2484        END DO
2485        END DO
2486     END IF
2487
2488  END SUBROUTINE stuff_bdy_old
2489
2490  SUBROUTINE stuff_bdytend_old ( data3dnew , data3dold , time_diff , space_bdy , char_stagger , &
2491                              ijds , ijde , spec_bdy_width , &
2492                              ids, ide, jds, jde, kds, kde , &
2493                              ims, ime, jms, jme, kms, kme , &
2494                              its, ite, jts, jte, kts, kte )
2495
2496  !  This routine puts the tendency data into the proper locations
2497  !  for the lateral boundary arrays.
2498
2499     USE module_state_description
2500
2501     IMPLICIT NONE
2502
2503     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2504     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2505     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2506     INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width
2507     REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2508 !    REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
2509     REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy
2510     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2511     REAL , INTENT(IN) :: time_diff ! seconds
2512
2513     INTEGER :: i , ii , j , jj , k
2514
2515     !  There are four lateral boundary locations that are stored.
2516
2517     !  X start boundary
2518
2519     IF ( char_stagger .EQ. 'W' ) THEN
2520        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2521        DO k = kds , kde
2522        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2523           space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2524 !         space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2525        END DO
2526        END DO
2527        END DO
2528     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2529        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2530        DO k = kds , kde
2531        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2532           space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2533 !         space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2534        END DO
2535        END DO
2536        END DO
2537     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2538        DO j = MAX(jds,jts) , MIN(jde,jte)
2539        DO k = kds , kde - 1
2540        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2541           space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2542 !         space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2543        END DO
2544        END DO
2545        END DO
2546     ELSE
2547        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2548        DO k = kds , kde - 1
2549        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2550           space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2551 !         space_bdy(j,k,i,P_XSB) = 0. ! zeroout
2552        END DO
2553        END DO
2554        END DO
2555     END IF
2556
2557     !  X end boundary
2558
2559     IF      ( char_stagger .EQ. 'U' ) THEN
2560        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2561        DO k = kds , kde - 1
2562        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2563           ii = ide - i + 1
2564           space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2565 !         space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2566        END DO
2567        END DO
2568        END DO
2569     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2570        DO j = MAX(jds,jts) , MIN(jde,jte)
2571        DO k = kds , kde - 1
2572        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2573           ii = ide - i
2574           space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2575 !         space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2576        END DO
2577        END DO
2578        END DO
2579     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2580        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2581        DO k = kds , kde
2582        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2583           ii = ide - i
2584           space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2585 !         space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2586        END DO
2587        END DO
2588        END DO
2589     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2590        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2591        DO k = kds , kde
2592        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2593           ii = ide - i
2594           space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2595 !         space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2596        END DO
2597        END DO
2598        END DO
2599     ELSE
2600        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2601        DO k = kds , kde - 1
2602        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2603           ii = ide - i
2604           space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2605 !         space_bdy(j,k,ii,P_XEB) = 0. ! zeroout
2606        END DO
2607        END DO
2608        END DO
2609     END IF
2610
2611     !  Y start boundary
2612
2613     IF ( char_stagger .EQ. 'W' ) THEN
2614        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2615        DO k = kds , kde
2616        DO i = MAX(ids,its) , MIN(ide-1,ite)
2617           space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2618 !         space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2619        END DO
2620        END DO
2621        END DO
2622     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2623        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2624        DO k = kds , kde
2625        DO i = MAX(ids,its) , MIN(ide-1,ite)
2626           space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2627 !         space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2628        END DO
2629        END DO
2630        END DO
2631     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2632        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2633        DO k = kds , kde - 1
2634        DO i = MAX(ids,its) , MIN(ide,ite)
2635           space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2636 !         space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2637        END DO
2638        END DO
2639        END DO
2640     ELSE
2641        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2642        DO k = kds , kde - 1
2643        DO i = MAX(ids,its) , MIN(ide-1,ite)
2644           space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2645 !         space_bdy(i,k,j,P_YSB) = 0. ! zeroout
2646        END DO
2647        END DO
2648        END DO
2649     END IF
2650
2651     !  Y end boundary
2652
2653     IF      ( char_stagger .EQ. 'V' ) THEN
2654        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2655        DO k = kds , kde - 1
2656        DO i = MAX(ids,its) , MIN(ide-1,ite)
2657           jj = jde - j + 1
2658           space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2659 !         space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2660        END DO
2661        END DO
2662        END DO
2663     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2664        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2665        DO k = kds , kde - 1
2666        DO i = MAX(ids,its) , MIN(ide,ite)
2667           jj = jde - j
2668           space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2669 !         space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2670        END DO
2671        END DO
2672        END DO
2673     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2674        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2675        DO k = kds , kde
2676        DO i = MAX(ids,its) , MIN(ide-1,ite)
2677           jj = jde - j
2678           space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2679 !         space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2680        END DO
2681        END DO
2682        END DO
2683     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2684        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2685        DO k = kds , kde
2686        DO i = MAX(ids,its) , MIN(ide-1,ite)
2687           jj = jde - j
2688           space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2689 !         space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2690        END DO
2691        END DO
2692        END DO
2693     ELSE
2694        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2695        DO k = kds , kde - 1
2696        DO i = MAX(ids,its) , MIN(ide-1,ite)
2697           jj = jde - j
2698           space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff
2699 !         space_bdy(i,k,jj,P_YEB) = 0. ! zeroout
2700        END DO
2701        END DO
2702        END DO
2703     END IF
2704
2705  END SUBROUTINE stuff_bdytend_old
2706
2707  SUBROUTINE stuff_bdy_ijk ( data3d , space_bdy_xs, space_bdy_xe, &
2708                              space_bdy_ys, space_bdy_ye, &
2709                              char_stagger , spec_bdy_width, &
2710                              ids, ide, jds, jde, kds, kde , &
2711                              ims, ime, jms, jme, kms, kme , &
2712                              its, ite, jts, jte, kts, kte )
2713
2714  !  This routine puts the data in the 3d arrays into the proper locations
2715  !  for the lateral boundary arrays.
2716
2717     USE module_state_description
2718
2719     IMPLICIT NONE
2720
2721     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2722     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2723     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2724     INTEGER , INTENT(IN) :: spec_bdy_width
2725     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: data3d
2726 !    REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy
2727 !    REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4,1) , INTENT(OUT) :: space_bdy
2728     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2729     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2730     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2731
2732     INTEGER :: i , ii , j , jj , k
2733
2734     !  There are four lateral boundary locations that are stored.
2735
2736     !  X start boundary
2737
2738     IF ( char_stagger .EQ. 'W' ) THEN
2739        DO k = kds , kde
2740        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2741        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2742           space_bdy_xs(j,k,i) = data3d(i,j,k)
2743        END DO
2744        END DO
2745        END DO
2746     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2747        DO k = kds , kde
2748        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2749        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2750           space_bdy_xs(j,k,i) = data3d(i,j,k)
2751        END DO
2752        END DO
2753        END DO
2754     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2755        DO k = kds , kde - 1
2756        DO j = MAX(jds,jts) , MIN(jde,jte)
2757        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2758           space_bdy_xs(j,k,i) = data3d(i,j,k)
2759        END DO
2760        END DO
2761        END DO
2762     ELSE
2763        DO k = kds , kde - 1
2764        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2765        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2766           space_bdy_xs(j,k,i) = data3d(i,j,k)
2767        END DO
2768        END DO
2769        END DO
2770     END IF
2771
2772     !  X end boundary
2773
2774     IF      ( char_stagger .EQ. 'U' ) THEN
2775        DO k = kds , kde - 1
2776        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2777        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2778           ii = ide - i + 1
2779           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2780        END DO
2781        END DO
2782        END DO
2783     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2784        DO k = kds , kde - 1
2785        DO j = MAX(jds,jts) , MIN(jde,jte)
2786        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2787           ii = ide - i
2788           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2789        END DO
2790        END DO
2791        END DO
2792     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2793        DO k = kds , kde
2794        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2795        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2796           ii = ide - i
2797           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2798        END DO
2799        END DO
2800        END DO
2801     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2802        DO k = kds , kde
2803        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2804        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2805           ii = ide - i
2806           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2807        END DO
2808        END DO
2809        END DO
2810     ELSE
2811        DO k = kds , kde - 1
2812        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2813        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2814           ii = ide - i
2815           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2816        END DO
2817        END DO
2818        END DO
2819     END IF
2820
2821     !  Y start boundary
2822
2823     IF ( char_stagger .EQ. 'W' ) THEN
2824        DO k = kds , kde
2825        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2826        DO i = MAX(ids,its) , MIN(ide-1,ite)
2827           space_bdy_ys(i,k,j) = data3d(i,j,k)
2828        END DO
2829        END DO
2830        END DO
2831     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2832        DO k = kds , kde
2833        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2834        DO i = MAX(ids,its) , MIN(ide-1,ite)
2835           space_bdy_ys(i,k,j) = data3d(i,j,k)
2836        END DO
2837        END DO
2838        END DO
2839     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2840        DO k = kds , kde - 1
2841        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2842        DO i = MAX(ids,its) , MIN(ide,ite)
2843           space_bdy_ys(i,k,j) = data3d(i,j,k)
2844        END DO
2845        END DO
2846        END DO
2847     ELSE
2848        DO k = kds , kde - 1
2849        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2850        DO i = MAX(ids,its) , MIN(ide-1,ite)
2851           space_bdy_ys(i,k,j) = data3d(i,j,k)
2852        END DO
2853        END DO
2854        END DO
2855     END IF
2856
2857     !  Y end boundary
2858
2859     IF      ( char_stagger .EQ. 'V' ) THEN
2860        DO k = kds , kde - 1
2861        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2862        DO i = MAX(ids,its) , MIN(ide-1,ite)
2863           jj = jde - j + 1
2864           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2865        END DO
2866        END DO
2867        END DO
2868     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2869        DO k = kds , kde - 1
2870        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2871        DO i = MAX(ids,its) , MIN(ide,ite)
2872           jj = jde - j
2873           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2874        END DO
2875        END DO
2876        END DO
2877     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2878        DO k = kds , kde
2879        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2880        DO i = MAX(ids,its) , MIN(ide-1,ite)
2881           jj = jde - j
2882           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2883        END DO
2884        END DO
2885        END DO
2886     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2887        DO k = kds , kde
2888        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2889        DO i = MAX(ids,its) , MIN(ide-1,ite)
2890           jj = jde - j
2891           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2892        END DO
2893        END DO
2894        END DO
2895     ELSE
2896        DO k = kds , kde - 1
2897        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2898        DO i = MAX(ids,its) , MIN(ide-1,ite)
2899           jj = jde - j
2900           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2901 !        if (K .eq. 54 .and. I .eq. 369) then
2902 !       write(0,*) 'N bound i,k,jj,P_YEB,data3d,space_bdy: ', i,k,jj,P_YEB,data3d(I,j,k),space_bdy(i,k,jj,P_YEB,1)
2903 !       endif
2904
2905        END DO
2906        END DO
2907        END DO
2908     END IF
2909
2910  END SUBROUTINE stuff_bdy_ijk
2911
2912  SUBROUTINE stuff_bdytend_ijk ( data3dnew , data3dold , time_diff , &
2913                              space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
2914                              char_stagger , &
2915                              spec_bdy_width , &
2916                              ids, ide, jds, jde, kds, kde , &
2917                              ims, ime, jms, jme, kms, kme , &
2918                              its, ite, jts, jte, kts, kte )
2919
2920  !  This routine puts the tendency data into the proper locations
2921  !  for the lateral boundary arrays.
2922
2923     USE module_state_description
2924
2925     IMPLICIT NONE
2926
2927     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
2928     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
2929     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
2930     INTEGER , INTENT(IN) :: spec_bdy_width
2931 !    REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold
2932     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: data3dnew , data3dold
2933     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe
2934     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye
2935
2936     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
2937     REAL , INTENT(IN) :: time_diff ! seconds
2938
2939     INTEGER :: i , ii , j , jj , k
2940
2941     !  There are four lateral boundary locations that are stored.
2942
2943     !  X start boundary
2944
2945     IF ( char_stagger .EQ. 'W' ) THEN
2946        DO k = kds , kde
2947        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2948        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2949           space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2950        END DO
2951        END DO
2952        END DO
2953     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2954        DO k = kds , kde
2955        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2956        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2957           space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2958        END DO
2959        END DO
2960        END DO
2961     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2962        DO k = kds , kde - 1
2963        DO j = MAX(jds,jts) , MIN(jde,jte)
2964        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2965           space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2966        END DO
2967        END DO
2968        END DO
2969     ELSE
2970        DO k = kds , kde - 1
2971        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2972        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
2973           space_bdy_xs(j,k,i) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2974        END DO
2975        END DO
2976        END DO
2977     END IF
2978
2979     !  X end boundary
2980
2981     IF      ( char_stagger .EQ. 'U' ) THEN
2982        DO k = kds , kde - 1
2983        DO j = MAX(jds,jts) , MIN(jde-1,jte)
2984        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
2985           ii = ide - i + 1
2986           space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2987        END DO
2988        END DO
2989        END DO
2990     ELSE IF ( char_stagger .EQ. 'V' ) THEN
2991        DO k = kds , kde - 1
2992        DO j = MAX(jds,jts) , MIN(jde,jte)
2993        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2994           ii = ide - i
2995           space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
2996        END DO
2997        END DO
2998        END DO
2999     ELSE IF ( char_stagger .EQ. 'W' ) THEN
3000        DO k = kds , kde
3001        DO j = MAX(jds,jts) , MIN(jde-1,jte)
3002        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
3003           ii = ide - i
3004           space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3005        END DO
3006        END DO
3007        END DO
3008     ELSE IF ( char_stagger .EQ. 'M' ) THEN
3009        DO k = kds , kde
3010        DO j = MAX(jds,jts) , MIN(jde-1,jte)
3011        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
3012           ii = ide - i
3013           space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3014        END DO
3015        END DO
3016        END DO
3017     ELSE
3018        DO k = kds , kde - 1
3019        DO j = MAX(jds,jts) , MIN(jde-1,jte)
3020        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
3021           ii = ide - i
3022           space_bdy_xe(j,k,ii) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3023        END DO
3024        END DO
3025        END DO
3026     END IF
3027
3028     !  Y start boundary
3029
3030     IF ( char_stagger .EQ. 'W' ) THEN
3031        DO k = kds , kde
3032        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3033        DO i = MAX(ids,its) , MIN(ide-1,ite)
3034           space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3035        END DO
3036        END DO
3037        END DO
3038     ELSE IF ( char_stagger .EQ. 'M' ) THEN
3039        DO k = kds , kde
3040        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3041        DO i = MAX(ids,its) , MIN(ide-1,ite)
3042           space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3043        END DO
3044        END DO
3045        END DO
3046     ELSE IF ( char_stagger .EQ. 'U' ) THEN
3047        DO k = kds , kde - 1
3048        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3049        DO i = MAX(ids,its) , MIN(ide,ite)
3050           space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3051        END DO
3052        END DO
3053        END DO
3054     ELSE
3055        DO k = kds , kde - 1
3056        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
3057        DO i = MAX(ids,its) , MIN(ide-1,ite)
3058           space_bdy_ys(i,k,j) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3059        END DO
3060        END DO
3061        END DO
3062     END IF
3063
3064     !  Y end boundary
3065
3066     IF      ( char_stagger .EQ. 'V' ) THEN
3067        DO k = kds , kde - 1
3068        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
3069        DO i = MAX(ids,its) , MIN(ide-1,ite)
3070           jj = jde - j + 1
3071           space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3072        END DO
3073        END DO
3074        END DO
3075     ELSE IF ( char_stagger .EQ. 'U' ) THEN
3076        DO k = kds , kde - 1
3077        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3078        DO i = MAX(ids,its) , MIN(ide,ite)
3079           jj = jde - j
3080           space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3081        END DO
3082        END DO
3083        END DO
3084     ELSE IF ( char_stagger .EQ. 'W' ) THEN
3085        DO k = kds , kde
3086        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3087        DO i = MAX(ids,its) , MIN(ide-1,ite)
3088           jj = jde - j
3089           space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3090        END DO
3091        END DO
3092        END DO
3093     ELSE IF ( char_stagger .EQ. 'M' ) THEN
3094        DO k = kds , kde
3095        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3096        DO i = MAX(ids,its) , MIN(ide-1,ite)
3097           jj = jde - j
3098           space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3099        END DO
3100        END DO
3101        END DO
3102     ELSE
3103        DO k = kds , kde - 1
3104        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
3105        DO i = MAX(ids,its) , MIN(ide-1,ite)
3106           jj = jde - j
3107           space_bdy_ye(i,k,jj) = ( data3dnew(i,j,k) - data3dold(i,j,k) ) / time_diff
3108 !        if (K .eq. 54 .and. I .eq. 369) then
3109 !       write(0,*) 'N bound i,k,jj,data3dnew,data3dold: ', i,k,jj,data3dnew(I,j,k),data3dold(i,j,k)
3110 !       endif
3111        END DO
3112        END DO
3113        END DO
3114     END IF
3115
3116  END SUBROUTINE stuff_bdytend_ijk
3117
3118 END MODULE module_bc
3119
3120 SUBROUTINE get_bdyzone_x ( bzx )
3121   USE module_bc
3122   IMPLICIT NONE
3123   INTEGER bzx
3124   bzx = bdyzone_x
3125 END SUBROUTINE get_bdyzone_x
3126
3127 SUBROUTINE get_bdyzone_y ( bzy)
3128   USE module_bc
3129   IMPLICIT NONE
3130   INTEGER bzy
3131   bzy = bdyzone_y
3132 END SUBROUTINE get_bdyzone_y
3133
3134 SUBROUTINE get_bdyzone ( bz)
3135   USE module_bc
3136   IMPLICIT NONE
3137   INTEGER bz
3138   bz = bdyzone
3139 END SUBROUTINE get_bdyzone