var/da/da_4dvar/da_4dvar_lbc.inc

   1  SUBROUTINE g_stuff_bdy ( g_data3d , g_space_bdy_xs, g_space_bdy_xe, g_space_bdy_ys, g_space_bdy_ye, &
   2                              char_stagger , &
   3                              spec_bdy_width , &
   4                              ids, ide, jds, jde, kds, kde , &
   5                              ims, ime, jms, jme, kms, kme , &
   6                              its, ite, jts, jte, kts, kte )
   7
   8 !-------------------------------------------------------------------------
   9 !  Derived from share/module_bc.F
  10 !  Author: Xin Zhang, 10/3/2010
  11 !-------------------------------------------------------------------------
  12  !  This routine puts the data in the 3d arrays into the proper locations
  13  !  for the lateral boundary arrays.
  14
  15     IMPLICIT NONE
  16
  17     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
  18     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
  19     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
  20     INTEGER , INTENT(IN) :: spec_bdy_width
  21     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: g_data3d
  22     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: g_space_bdy_xs, g_space_bdy_xe
  23     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: g_space_bdy_ys, g_space_bdy_ye
  24     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
  25
  26     INTEGER :: i , ii , j , jj , k
  27
  28     !  There are four lateral boundary locations that are stored.
  29
  30     !  X start boundary
  31
  32     IF ( char_stagger .EQ. 'W' ) THEN
  33        DO k = kds , kde
  34        DO j = MAX(jds,jts) , MIN(jde-1,jte)
  35        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
  36           g_space_bdy_xs(j,k,i) = g_data3d(i,j,k)
  37        END DO
  38        END DO
  39        END DO
  40     ELSE IF ( char_stagger .EQ. 'M' ) THEN
  41        DO k = kds , kde
  42        DO j = MAX(jds,jts) , MIN(jde-1,jte)
  43        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
  44           g_space_bdy_xs(j,k,i) = g_data3d(i,j,k)
  45        END DO
  46        END DO
  47        END DO
  48     ELSE IF ( char_stagger .EQ. 'V' ) THEN
  49        DO k = kds , kde - 1
  50        DO j = MAX(jds,jts) , MIN(jde,jte)
  51        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
  52           g_space_bdy_xs(j,k,i) = g_data3d(i,j,k)
  53        END DO
  54        END DO
  55        END DO
  56     ELSE
  57        DO k = kds , kde - 1
  58        DO j = MAX(jds,jts) , MIN(jde-1,jte)
  59        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
  60           g_space_bdy_xs(j,k,i) = g_data3d(i,j,k)
  61        END DO
  62        END DO
  63        END DO
  64     END IF
  65
  66     !  X end boundary
  67
  68     IF      ( char_stagger .EQ. 'U' ) THEN
  69        DO k = kds , kde - 1
  70        DO j = MAX(jds,jts) , MIN(jde-1,jte)
  71        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
  72           ii = ide - i + 1
  73           g_space_bdy_xe(j,k,ii) = g_data3d(i,j,k)
  74        END DO
  75        END DO
  76        END DO
  77     ELSE IF ( char_stagger .EQ. 'V' ) THEN
  78        DO k = kds , kde - 1
  79        DO j = MAX(jds,jts) , MIN(jde,jte)
  80        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
  81           ii = ide - i
  82           g_space_bdy_xe(j,k,ii) = g_data3d(i,j,k)
  83        END DO
  84        END DO
  85        END DO
  86     ELSE IF ( char_stagger .EQ. 'W' ) THEN
  87        DO k = kds , kde
  88        DO j = MAX(jds,jts) , MIN(jde-1,jte)
  89        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
  90           ii = ide - i
  91           g_space_bdy_xe(j,k,ii) = g_data3d(i,j,k)
  92        END DO
  93        END DO
  94        END DO
  95     ELSE IF ( char_stagger .EQ. 'M' ) THEN
  96        DO k = kds , kde
  97        DO j = MAX(jds,jts) , MIN(jde-1,jte)
  98        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
  99           ii = ide - i
 100           g_space_bdy_xe(j,k,ii) = g_data3d(i,j,k)
 101        END DO
 102        END DO
 103        END DO
 104     ELSE
 105        DO k = kds , kde - 1
 106        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 107        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 108           ii = ide - i
 109           g_space_bdy_xe(j,k,ii) = g_data3d(i,j,k)
 110        END DO
 111        END DO
 112        END DO
 113     END IF
 114
 115     !  Y start boundary
 116
 117     IF ( char_stagger .EQ. 'W' ) THEN
 118        DO k = kds , kde
 119        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 120        DO i = MAX(ids,its) , MIN(ide-1,ite)
 121           g_space_bdy_ys(i,k,j) = g_data3d(i,j,k)
 122        END DO
 123        END DO
 124        END DO
 125     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 126        DO k = kds , kde
 127        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 128        DO i = MAX(ids,its) , MIN(ide-1,ite)
 129           g_space_bdy_ys(i,k,j) = g_data3d(i,j,k)
 130        END DO
 131        END DO
 132        END DO
 133     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 134        DO k = kds , kde - 1
 135        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 136        DO i = MAX(ids,its) , MIN(ide,ite)
 137           g_space_bdy_ys(i,k,j) = g_data3d(i,j,k)
 138        END DO
 139        END DO
 140        END DO
 141     ELSE
 142        DO k = kds , kde - 1
 143        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 144        DO i = MAX(ids,its) , MIN(ide-1,ite)
 145           g_space_bdy_ys(i,k,j) = g_data3d(i,j,k)
 146        END DO
 147        END DO
 148        END DO
 149     END IF
 150
 151     !  Y end boundary
 152
 153     IF      ( char_stagger .EQ. 'V' ) THEN
 154        DO k = kds , kde - 1
 155        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
 156        DO i = MAX(ids,its) , MIN(ide-1,ite)
 157           jj = jde - j + 1
 158           g_space_bdy_ye(i,k,jj) = g_data3d(i,j,k)
 159        END DO
 160        END DO
 161        END DO
 162     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 163        DO k = kds , kde - 1
 164        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 165        DO i = MAX(ids,its) , MIN(ide,ite)
 166           jj = jde - j
 167           g_space_bdy_ye(i,k,jj) = g_data3d(i,j,k)
 168        END DO
 169        END DO
 170        END DO
 171     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 172        DO k = kds , kde
 173        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 174        DO i = MAX(ids,its) , MIN(ide-1,ite)
 175           jj = jde - j
 176           g_space_bdy_ye(i,k,jj) = g_data3d(i,j,k)
 177        END DO
 178        END DO
 179        END DO
 180     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 181        DO k = kds , kde
 182        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 183        DO i = MAX(ids,its) , MIN(ide-1,ite)
 184           jj = jde - j
 185           g_space_bdy_ye(i,k,jj) = g_data3d(i,j,k)
 186        END DO
 187        END DO
 188        END DO
 189     ELSE
 190        DO k = kds , kde - 1
 191        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 192        DO i = MAX(ids,its) , MIN(ide-1,ite)
 193           jj = jde - j
 194           g_space_bdy_ye(i,k,jj) = g_data3d(i,j,k)
 195        END DO
 196        END DO
 197        END DO
 198     END IF
 199
 200  END SUBROUTINE g_stuff_bdy
 201
 202  SUBROUTINE a_stuff_bdy ( a_data3d , a_space_bdy_xs, a_space_bdy_xe, a_space_bdy_ys, a_space_bdy_ye, &
 203                              char_stagger , &
 204                              spec_bdy_width , &
 205                              ids, ide, jds, jde, kds, kde , &
 206                              ims, ime, jms, jme, kms, kme , &
 207                              its, ite, jts, jte, kts, kte )
 208
 209 !-------------------------------------------------------------------------
 210 !  Derived from share/module_bc.F
 211 !  Author: Xin Zhang, 10/3/2010
 212 !-------------------------------------------------------------------------
 213  !  This routine puts the data in the 3d arrays into the proper locations
 214  !  for the lateral boundary arrays.
 215
 216     IMPLICIT NONE
 217
 218     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
 219     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
 220     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
 221     INTEGER , INTENT(IN) :: spec_bdy_width
 222     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT) :: a_data3d
 223     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(INOUT) :: a_space_bdy_xs, a_space_bdy_xe
 224     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(INOUT) :: a_space_bdy_ys, a_space_bdy_ye
 225     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
 226
 227     INTEGER :: i , ii , j , jj , k
 228
 229     !  There are four lateral boundary locations that are stored.
 230
 231     !  X start boundary
 232
 233     IF ( char_stagger .EQ. 'W' ) THEN
 234        DO k = kds , kde
 235        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 236        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 237           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xs(j,k,i)
 238           a_space_bdy_xs(j,k,i) = 0.0
 239        END DO
 240        END DO
 241        END DO
 242     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 243        DO k = kds , kde
 244        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 245        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 246           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xs(j,k,i)
 247           a_space_bdy_xs(j,k,i) = 0.0
 248        END DO
 249        END DO
 250        END DO
 251     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 252        DO k = kds , kde - 1
 253        DO j = MAX(jds,jts) , MIN(jde,jte)
 254        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 255           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xs(j,k,i)
 256           a_space_bdy_xs(j,k,i) = 0.0
 257        END DO
 258        END DO
 259        END DO
 260     ELSE
 261        DO k = kds , kde - 1
 262        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 263        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 264           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xs(j,k,i)
 265           a_space_bdy_xs(j,k,i) = 0.0
 266        END DO
 267        END DO
 268        END DO
 269     END IF
 270
 271     !  X end boundary
 272
 273     IF      ( char_stagger .EQ. 'U' ) THEN
 274        DO k = kds , kde - 1
 275        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 276        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
 277           ii = ide - i + 1
 278           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xe(j,k,ii)
 279           a_space_bdy_xe(j,k,ii) = 0.0
 280        END DO
 281        END DO
 282        END DO
 283     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 284        DO k = kds , kde - 1
 285        DO j = MAX(jds,jts) , MIN(jde,jte)
 286        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 287           ii = ide - i
 288           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xe(j,k,ii)
 289           a_space_bdy_xe(j,k,ii) = 0.0
 290        END DO
 291        END DO
 292        END DO
 293     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 294        DO k = kds , kde
 295        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 296        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 297           ii = ide - i
 298           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xe(j,k,ii)
 299           a_space_bdy_xe(j,k,ii) = 0.0
 300        END DO
 301        END DO
 302        END DO
 303     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 304        DO k = kds , kde
 305        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 306        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 307           ii = ide - i
 308           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xe(j,k,ii)
 309           a_space_bdy_xe(j,k,ii) = 0.0
 310        END DO
 311        END DO
 312        END DO
 313     ELSE
 314        DO k = kds , kde - 1
 315        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 316        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 317           ii = ide - i
 318           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_xe(j,k,ii)
 319           a_space_bdy_xe(j,k,ii) = 0.0
 320        END DO
 321        END DO
 322        END DO
 323     END IF
 324
 325     !  Y start boundary
 326
 327     IF ( char_stagger .EQ. 'W' ) THEN
 328        DO k = kds , kde
 329        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 330        DO i = MAX(ids,its) , MIN(ide-1,ite)
 331           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ys(i,k,j)
 332           a_space_bdy_ys(i,k,j) = 0.0
 333        END DO
 334        END DO
 335        END DO
 336     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 337        DO k = kds , kde
 338        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 339        DO i = MAX(ids,its) , MIN(ide-1,ite)
 340           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ys(i,k,j)
 341           a_space_bdy_ys(i,k,j) = 0.0
 342        END DO
 343        END DO
 344        END DO
 345     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 346        DO k = kds , kde - 1
 347        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 348        DO i = MAX(ids,its) , MIN(ide,ite)
 349           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ys(i,k,j)
 350           a_space_bdy_ys(i,k,j) = 0.0
 351        END DO
 352        END DO
 353        END DO
 354     ELSE
 355        DO k = kds , kde - 1
 356        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 357        DO i = MAX(ids,its) , MIN(ide-1,ite)
 358           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ys(i,k,j)
 359           a_space_bdy_ys(i,k,j) = 0.0
 360        END DO
 361        END DO
 362        END DO
 363     END IF
 364
 365     !  Y end boundary
 366
 367     IF      ( char_stagger .EQ. 'V' ) THEN
 368        DO k = kds , kde - 1
 369        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
 370        DO i = MAX(ids,its) , MIN(ide-1,ite)
 371           jj = jde - j + 1
 372           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ye(i,k,jj)
 373           a_space_bdy_ye(i,k,jj) = 0.0
 374        END DO
 375        END DO
 376        END DO
 377     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 378        DO k = kds , kde - 1
 379        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 380        DO i = MAX(ids,its) , MIN(ide,ite)
 381           jj = jde - j
 382           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ye(i,k,jj)
 383           a_space_bdy_ye(i,k,jj) = 0.0
 384        END DO
 385        END DO
 386        END DO
 387     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 388        DO k = kds , kde
 389        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 390        DO i = MAX(ids,its) , MIN(ide-1,ite)
 391           jj = jde - j
 392           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ye(i,k,jj)
 393           a_space_bdy_ye(i,k,jj) = 0.0
 394        END DO
 395        END DO
 396        END DO
 397     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 398        DO k = kds , kde
 399        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 400        DO i = MAX(ids,its) , MIN(ide-1,ite)
 401           jj = jde - j
 402           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ye(i,k,jj)
 403           a_space_bdy_ye(i,k,jj) = 0.0
 404        END DO
 405        END DO
 406        END DO
 407     ELSE
 408        DO k = kds , kde - 1
 409        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 410        DO i = MAX(ids,its) , MIN(ide-1,ite)
 411           jj = jde - j
 412           a_data3d(i,j,k) = a_data3d(i,j,k) + a_space_bdy_ye(i,k,jj)
 413           a_space_bdy_ye(i,k,jj) = 0.0
 414        END DO
 415        END DO
 416        END DO
 417     END IF
 418
 419  END SUBROUTINE a_stuff_bdy
 420
 421  SUBROUTINE g_stuff_bdytend ( g_data3dnew , g_data3dold , time_diff , &
 422                              g_space_bdy_xs, g_space_bdy_xe, g_space_bdy_ys, g_space_bdy_ye, &
 423                              char_stagger , &
 424                              spec_bdy_width , &
 425                              ids, ide, jds, jde, kds, kde , &
 426                              ims, ime, jms, jme, kms, kme , &
 427                              its, ite, jts, jte, kts, kte )
 428
 429 !-------------------------------------------------------------------------
 430 !  Derived from share/module_bc.F
 431 !  Author: Xin Zhang, 10/3/2010
 432 !-------------------------------------------------------------------------
 433  !  This routine puts the tendency data into the proper locations
 434  !  for the lateral boundary arrays.
 435
 436     IMPLICIT NONE
 437
 438     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
 439     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
 440     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
 441     INTEGER , INTENT(IN) :: spec_bdy_width
 442     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN) :: g_data3dnew , g_data3dold
 443     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: g_space_bdy_xs, g_space_bdy_xe
 444     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: g_space_bdy_ys, g_space_bdy_ye
 445     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
 446     REAL , INTENT(IN) :: time_diff ! seconds
 447
 448     INTEGER :: i , ii , j , jj , k
 449
 450     !  There are four lateral boundary locations that are stored.
 451
 452     !  X start boundary
 453
 454     IF ( char_stagger .EQ. 'W' ) THEN
 455        DO k = kds , kde
 456        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 457        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 458           g_space_bdy_xs(j,k,i) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 459        END DO
 460        END DO
 461        END DO
 462     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 463        DO k = kds , kde
 464        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 465        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 466           g_space_bdy_xs(j,k,i) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 467        END DO
 468        END DO
 469        END DO
 470     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 471        DO k = kds , kde - 1
 472        DO j = MAX(jds,jts) , MIN(jde,jte)
 473        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 474           g_space_bdy_xs(j,k,i) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 475        END DO
 476        END DO
 477        END DO
 478     ELSE
 479        DO k = kds , kde - 1
 480        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 481        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 482           g_space_bdy_xs(j,k,i) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 483        END DO
 484        END DO
 485        END DO
 486     END IF
 487
 488     !  X end boundary
 489
 490     IF      ( char_stagger .EQ. 'U' ) THEN
 491        DO k = kds , kde - 1
 492        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 493        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
 494           ii = ide - i + 1
 495           g_space_bdy_xe(j,k,ii) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 496        END DO
 497        END DO
 498        END DO
 499     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 500        DO k = kds , kde - 1
 501        DO j = MAX(jds,jts) , MIN(jde,jte)
 502        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 503           ii = ide - i
 504           g_space_bdy_xe(j,k,ii) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 505        END DO
 506        END DO
 507        END DO
 508     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 509        DO k = kds , kde
 510        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 511        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 512           ii = ide - i
 513           g_space_bdy_xe(j,k,ii) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 514        END DO
 515        END DO
 516        END DO
 517     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 518        DO k = kds , kde
 519        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 520        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 521           ii = ide - i
 522           g_space_bdy_xe(j,k,ii) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 523        END DO
 524        END DO
 525        END DO
 526     ELSE
 527        DO k = kds , kde - 1
 528        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 529        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 530           ii = ide - i
 531           g_space_bdy_xe(j,k,ii) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 532        END DO
 533        END DO
 534        END DO
 535     END IF
 536
 537     !  Y start boundary
 538
 539     IF ( char_stagger .EQ. 'W' ) THEN
 540        DO k = kds , kde
 541        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 542        DO i = MAX(ids,its) , MIN(ide-1,ite)
 543           g_space_bdy_ys(i,k,j) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 544        END DO
 545        END DO
 546        END DO
 547     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 548        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 549        DO k = kds , kde
 550        DO i = MAX(ids,its) , MIN(ide-1,ite)
 551           g_space_bdy_ys(i,k,j) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 552        END DO
 553        END DO
 554        END DO
 555     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 556        DO k = kds , kde - 1
 557        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 558        DO i = MAX(ids,its) , MIN(ide,ite)
 559           g_space_bdy_ys(i,k,j) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 560        END DO
 561        END DO
 562        END DO
 563     ELSE
 564        DO k = kds , kde - 1
 565        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 566        DO i = MAX(ids,its) , MIN(ide-1,ite)
 567           g_space_bdy_ys(i,k,j) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 568        END DO
 569        END DO
 570        END DO
 571     END IF
 572
 573     !  Y end boundary
 574
 575     IF      ( char_stagger .EQ. 'V' ) THEN
 576        DO k = kds , kde - 1
 577        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
 578        DO i = MAX(ids,its) , MIN(ide-1,ite)
 579           jj = jde - j + 1
 580           g_space_bdy_ye(i,k,jj) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 581        END DO
 582        END DO
 583        END DO
 584     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 585        DO k = kds , kde - 1
 586        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 587        DO i = MAX(ids,its) , MIN(ide,ite)
 588           jj = jde - j
 589           g_space_bdy_ye(i,k,jj) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 590        END DO
 591        END DO
 592        END DO
 593     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 594        DO k = kds , kde
 595        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 596        DO i = MAX(ids,its) , MIN(ide-1,ite)
 597           jj = jde - j
 598           g_space_bdy_ye(i,k,jj) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 599        END DO
 600        END DO
 601        END DO
 602     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 603        DO k = kds , kde
 604        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 605        DO i = MAX(ids,its) , MIN(ide-1,ite)
 606           jj = jde - j
 607           g_space_bdy_ye(i,k,jj) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 608        END DO
 609        END DO
 610        END DO
 611     ELSE
 612        DO k = kds , kde - 1
 613        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 614        DO i = MAX(ids,its) , MIN(ide-1,ite)
 615           jj = jde - j
 616           g_space_bdy_ye(i,k,jj) = ( g_data3dnew(i,j,k) - g_data3dold(i,j,k) ) / time_diff
 617        END DO
 618        END DO
 619        END DO
 620     END IF
 621
 622  END SUBROUTINE g_stuff_bdytend
 623
 624  SUBROUTINE a_stuff_bdytend_new ( a_data3dnew , time_diff , &
 625                              a_space_bdy_xs, a_space_bdy_xe, a_space_bdy_ys, a_space_bdy_ye, &
 626                              char_stagger , &
 627                              spec_bdy_width , &
 628                              ids, ide, jds, jde, kds, kde , &
 629                              ims, ime, jms, jme, kms, kme , &
 630                              its, ite, jts, jte, kts, kte )
 631
 632 !-------------------------------------------------------------------------
 633 !  Derived from share/module_bc.F
 634 !  Author: Xin Zhang, 10/3/2010
 635 !-------------------------------------------------------------------------
 636  !  This routine puts the tendency data into the proper locations
 637  !  for the lateral boundary arrays.
 638
 639     IMPLICIT NONE
 640
 641     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
 642     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
 643     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
 644     INTEGER , INTENT(IN) :: spec_bdy_width
 645     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT) :: a_data3dnew
 646     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(IN) :: a_space_bdy_xs, a_space_bdy_xe
 647     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(IN) :: a_space_bdy_ys, a_space_bdy_ye
 648     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
 649     REAL , INTENT(IN) :: time_diff ! seconds
 650
 651     INTEGER :: i , ii , j , jj , k
 652
 653     !  There are four lateral boundary locations that are stored.
 654
 655     !  X start boundary
 656
 657     IF ( char_stagger .EQ. 'W' ) THEN
 658        DO k = kds , kde
 659        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 660        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 661           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xs(j,k,i) / time_diff
 662        END DO
 663        END DO
 664        END DO
 665     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 666        DO k = kds , kde
 667        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 668        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 669           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xs(j,k,i) / time_diff
 670        END DO
 671        END DO
 672        END DO
 673     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 674        DO k = kds , kde - 1
 675        DO j = MAX(jds,jts) , MIN(jde,jte)
 676        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 677           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xs(j,k,i) / time_diff
 678        END DO
 679        END DO
 680        END DO
 681     ELSE
 682        DO k = kds , kde - 1
 683        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 684        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 685           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xs(j,k,i) / time_diff
 686        END DO
 687        END DO
 688        END DO
 689     END IF
 690
 691     !  X end boundary
 692
 693     IF      ( char_stagger .EQ. 'U' ) THEN
 694        DO k = kds , kde - 1
 695        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 696        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
 697           ii = ide - i + 1
 698           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xe(j,k,ii) / time_diff
 699        END DO
 700        END DO
 701        END DO
 702     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 703        DO k = kds , kde - 1
 704        DO j = MAX(jds,jts) , MIN(jde,jte)
 705        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 706           ii = ide - i
 707           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xe(j,k,ii) / time_diff
 708        END DO
 709        END DO
 710        END DO
 711     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 712        DO k = kds , kde
 713        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 714        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 715           ii = ide - i
 716           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xe(j,k,ii) / time_diff
 717        END DO
 718        END DO
 719        END DO
 720     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 721        DO k = kds , kde
 722        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 723        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 724           ii = ide - i
 725           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xe(j,k,ii) / time_diff
 726        END DO
 727        END DO
 728        END DO
 729     ELSE
 730        DO k = kds , kde - 1
 731        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 732        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 733           ii = ide - i
 734           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_xe(j,k,ii) / time_diff
 735        END DO
 736        END DO
 737        END DO
 738     END IF
 739
 740     !  Y start boundary
 741
 742     IF ( char_stagger .EQ. 'W' ) THEN
 743        DO k = kds , kde
 744        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 745        DO i = MAX(ids,its) , MIN(ide-1,ite)
 746           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ys(i,k,j) / time_diff
 747        END DO
 748        END DO
 749        END DO
 750     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 751        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 752        DO k = kds , kde
 753        DO i = MAX(ids,its) , MIN(ide-1,ite)
 754           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ys(i,k,j) / time_diff
 755        END DO
 756        END DO
 757        END DO
 758     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 759        DO k = kds , kde - 1
 760        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 761        DO i = MAX(ids,its) , MIN(ide,ite)
 762           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ys(i,k,j) / time_diff
 763        END DO
 764        END DO
 765        END DO
 766     ELSE
 767        DO k = kds , kde - 1
 768        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 769        DO i = MAX(ids,its) , MIN(ide-1,ite)
 770           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ys(i,k,j) / time_diff
 771        END DO
 772        END DO
 773        END DO
 774     END IF
 775
 776     !  Y end boundary
 777
 778     IF      ( char_stagger .EQ. 'V' ) THEN
 779        DO k = kds , kde - 1
 780        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
 781        DO i = MAX(ids,its) , MIN(ide-1,ite)
 782           jj = jde - j + 1
 783           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ye(i,k,jj) / time_diff
 784        END DO
 785        END DO
 786        END DO
 787     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 788        DO k = kds , kde - 1
 789        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 790        DO i = MAX(ids,its) , MIN(ide,ite)
 791           jj = jde - j
 792           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ye(i,k,jj) / time_diff
 793        END DO
 794        END DO
 795        END DO
 796     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 797        DO k = kds , kde
 798        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 799        DO i = MAX(ids,its) , MIN(ide-1,ite)
 800           jj = jde - j
 801           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ye(i,k,jj) / time_diff
 802        END DO
 803        END DO
 804        END DO
 805     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 806        DO k = kds , kde
 807        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 808        DO i = MAX(ids,its) , MIN(ide-1,ite)
 809           jj = jde - j
 810           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ye(i,k,jj) / time_diff
 811        END DO
 812        END DO
 813        END DO
 814     ELSE
 815        DO k = kds , kde - 1
 816        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
 817        DO i = MAX(ids,its) , MIN(ide-1,ite)
 818           jj = jde - j
 819           a_data3dnew(i,j,k) = a_data3dnew(i,j,k) + a_space_bdy_ye(i,k,jj) / time_diff
 820        END DO
 821        END DO
 822        END DO
 823     END IF
 824
 825  END SUBROUTINE a_stuff_bdytend_new
 826
 827  SUBROUTINE a_stuff_bdytend_old ( a_data3dold , time_diff , &
 828                              a_space_bdy_xs, a_space_bdy_xe, a_space_bdy_ys, a_space_bdy_ye, &
 829                              char_stagger , &
 830                              spec_bdy_width , &
 831                              ids, ide, jds, jde, kds, kde , &
 832                              ims, ime, jms, jme, kms, kme , &
 833                              its, ite, jts, jte, kts, kte )
 834
 835 !-------------------------------------------------------------------------
 836 !  Derived from share/module_bc.F
 837 !  Author: Xin Zhang, 10/3/2010
 838 !-------------------------------------------------------------------------
 839  !  This routine puts the tendency data into the proper locations
 840  !  for the lateral boundary arrays.
 841
 842     IMPLICIT NONE
 843
 844     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
 845     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
 846     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
 847     INTEGER , INTENT(IN) :: spec_bdy_width
 848     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT) :: a_data3dold
 849     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(INOUT) :: a_space_bdy_xs, a_space_bdy_xe
 850     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(INOUT) :: a_space_bdy_ys, a_space_bdy_ye
 851     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
 852     REAL , INTENT(IN) :: time_diff ! seconds
 853
 854     INTEGER :: i , ii , j , jj , k
 855
 856     !  There are four lateral boundary locations that are stored.
 857
 858     !  X start boundary
 859
 860     IF ( char_stagger .EQ. 'W' ) THEN
 861        DO k = kds , kde
 862        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 863        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 864           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xs(j,k,i) / time_diff
 865           a_space_bdy_xs(j,k,i) = 0.0
 866        END DO
 867        END DO
 868        END DO
 869     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 870        DO k = kds , kde
 871        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 872        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 873           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xs(j,k,i) / time_diff
 874           a_space_bdy_xs(j,k,i) = 0.0
 875        END DO
 876        END DO
 877        END DO
 878     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 879        DO k = kds , kde - 1
 880        DO j = MAX(jds,jts) , MIN(jde,jte)
 881        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 882           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xs(j,k,i) / time_diff
 883           a_space_bdy_xs(j,k,i) = 0.0
 884        END DO
 885        END DO
 886        END DO
 887     ELSE
 888        DO k = kds , kde - 1
 889        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 890        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
 891           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xs(j,k,i) / time_diff
 892           a_space_bdy_xs(j,k,i) = 0.0
 893        END DO
 894        END DO
 895        END DO
 896     END IF
 897
 898     !  X end boundary
 899
 900     IF      ( char_stagger .EQ. 'U' ) THEN
 901        DO k = kds , kde - 1
 902        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 903        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
 904           ii = ide - i + 1
 905           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xe(j,k,ii) / time_diff
 906           a_space_bdy_xe(j,k,ii) = 0.0
 907        END DO
 908        END DO
 909        END DO
 910     ELSE IF ( char_stagger .EQ. 'V' ) THEN
 911        DO k = kds , kde - 1
 912        DO j = MAX(jds,jts) , MIN(jde,jte)
 913        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 914           ii = ide - i
 915           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xe(j,k,ii) / time_diff
 916           a_space_bdy_xe(j,k,ii) = 0.0
 917        END DO
 918        END DO
 919        END DO
 920     ELSE IF ( char_stagger .EQ. 'W' ) THEN
 921        DO k = kds , kde
 922        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 923        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 924           ii = ide - i
 925           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xe(j,k,ii) / time_diff
 926           a_space_bdy_xe(j,k,ii) = 0.0
 927        END DO
 928        END DO
 929        END DO
 930     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 931        DO k = kds , kde
 932        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 933        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 934           ii = ide - i
 935           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xe(j,k,ii) / time_diff
 936           a_space_bdy_xe(j,k,ii) = 0.0
 937        END DO
 938        END DO
 939        END DO
 940     ELSE
 941        DO k = kds , kde - 1
 942        DO j = MAX(jds,jts) , MIN(jde-1,jte)
 943        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
 944           ii = ide - i
 945           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_xe(j,k,ii) / time_diff
 946           a_space_bdy_xe(j,k,ii) = 0.0
 947        END DO
 948        END DO
 949        END DO
 950     END IF
 951
 952     !  Y start boundary
 953
 954     IF ( char_stagger .EQ. 'W' ) THEN
 955        DO k = kds , kde
 956        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 957        DO i = MAX(ids,its) , MIN(ide-1,ite)
 958           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ys(i,k,j) / time_diff
 959           a_space_bdy_ys(i,k,j) = 0.0
 960        END DO
 961        END DO
 962        END DO
 963     ELSE IF ( char_stagger .EQ. 'M' ) THEN
 964        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 965        DO k = kds , kde
 966        DO i = MAX(ids,its) , MIN(ide-1,ite)
 967           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ys(i,k,j) / time_diff
 968           a_space_bdy_ys(i,k,j) = 0.0
 969        END DO
 970        END DO
 971        END DO
 972     ELSE IF ( char_stagger .EQ. 'U' ) THEN
 973        DO k = kds , kde - 1
 974        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 975        DO i = MAX(ids,its) , MIN(ide,ite)
 976           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ys(i,k,j) / time_diff
 977           a_space_bdy_ys(i,k,j) = 0.0
 978        END DO
 979        END DO
 980        END DO
 981     ELSE
 982        DO k = kds , kde - 1
 983        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
 984        DO i = MAX(ids,its) , MIN(ide-1,ite)
 985           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ys(i,k,j) / time_diff
 986           a_space_bdy_ys(i,k,j) = 0.0
 987        END DO
 988        END DO
 989        END DO
 990     END IF
 991
 992     !  Y end boundary
 993
 994     IF      ( char_stagger .EQ. 'V' ) THEN
 995        DO k = kds , kde - 1
 996        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
 997        DO i = MAX(ids,its) , MIN(ide-1,ite)
 998           jj = jde - j + 1
 999           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ye(i,k,jj) / time_diff
1000           a_space_bdy_ye(i,k,jj) = 0.0
1001        END DO
1002        END DO
1003        END DO
1004     ELSE IF ( char_stagger .EQ. 'U' ) THEN
1005        DO k = kds , kde - 1
1006        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1007        DO i = MAX(ids,its) , MIN(ide,ite)
1008           jj = jde - j
1009           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ye(i,k,jj) / time_diff
1010           a_space_bdy_ye(i,k,jj) = 0.0
1011        END DO
1012        END DO
1013        END DO
1014     ELSE IF ( char_stagger .EQ. 'W' ) THEN
1015        DO k = kds , kde
1016        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1017        DO i = MAX(ids,its) , MIN(ide-1,ite)
1018           jj = jde - j
1019           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ye(i,k,jj) / time_diff
1020           a_space_bdy_ye(i,k,jj) = 0.0
1021        END DO
1022        END DO
1023        END DO
1024     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1025        DO k = kds , kde
1026        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1027        DO i = MAX(ids,its) , MIN(ide-1,ite)
1028           jj = jde - j
1029           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ye(i,k,jj) / time_diff
1030           a_space_bdy_ye(i,k,jj) = 0.0
1031        END DO
1032        END DO
1033        END DO
1034     ELSE
1035        DO k = kds , kde - 1
1036        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1037        DO i = MAX(ids,its) , MIN(ide-1,ite)
1038           jj = jde - j
1039           a_data3dold(i,j,k) = a_data3dold(i,j,k) - a_space_bdy_ye(i,k,jj) / time_diff
1040           a_space_bdy_ye(i,k,jj) = 0.0
1041        END DO
1042        END DO
1043        END DO
1044     END IF
1045
1046  END SUBROUTINE a_stuff_bdytend_old
1047
1048 SUBROUTINE g_couple ( config_flags, mu, g_mu, mub, g_rfield, field, &
1049                     g_field, name, msf,               &
1050                     ids, ide, jds, jde, kds, kde, &
1051                     ims, ime, jms, jme, kms, kme, &
1052                     its, ite, jts, jte, kts, kte )
1053
1054 !-------------------------------------------------------------------------
1055 !  Derived from dyn_em/module_big_step_utilities_em.F
1056 !  Author: Xin Zhang, 10/2/2010
1057 !-------------------------------------------------------------------------
1058    IMPLICIT NONE
1059
1060    ! Input data
1061
1062    TYPE(grid_config_rec_type   ) ,   INTENT(IN   ) :: config_flags
1063
1064    INTEGER ,             INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1065                                           ims, ime, jms, jme, kms, kme, &
1066                                           its, ite, jts, jte, kts, kte
1067
1068    CHARACTER(LEN=1) ,     INTENT(IN   ) :: name
1069
1070    REAL , DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(  OUT) :: g_rfield
1071
1072    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mu, g_mu, mub, msf
1073
1074    REAL , DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(IN   ) :: field, g_field
1075
1076    ! Local data
1077
1078    INTEGER :: i, j, k, itf, jtf, ktf
1079    REAL , DIMENSION(ims:ime,jms:jme) :: muu , muv
1080    REAL , DIMENSION(ims:ime,jms:jme) :: g_muu , g_muv
1081
1082 !<DESCRIPTION>
1083 !
1084 ! subroutine couple couples the input variable with the dry-air
1085 ! column mass (mu).
1086 !
1087 !</DESCRIPTION>
1088
1089    ktf=MIN(kte,kde-1)
1090
1091    IF (name .EQ. 'u')THEN
1092
1093       muu = 0.0
1094       muv = 0.0
1095       g_muu = 0.0
1096       g_muv = 0.0
1097
1098       CALL g_calc_mu_uv ( config_flags, mu, g_mu, mub, &
1099                           muu, g_muu, muv, g_muv,      &
1100                           ids, ide, jds, jde, kds, kde, &
1101                           ims, ime, jms, jme, kms, kme, &
1102                           its, ite, jts, jte, kts, kte )
1103
1104       itf=ite
1105       jtf=MIN(jte,jde-1)
1106
1107       DO k=kts,ktf
1108       DO j=jts,jtf
1109       DO i=its,itf
1110          g_rfield(i,j,k)=g_field(i,j,k)*muu(i,j)/msf(i,j) + &
1111                          field(i,j,k)*g_muu(i,j)/msf(i,j)
1112       ENDDO
1113       ENDDO
1114       ENDDO
1115
1116    ELSE IF (name .EQ. 'v')THEN
1117
1118       muu = 0.0
1119       muv = 0.0
1120       g_muu = 0.0
1121       g_muv = 0.0
1122
1123       CALL g_calc_mu_uv ( config_flags, mu, g_mu, mub, &
1124                           muu, g_muu, muv, g_muv,      &
1125                           ids, ide, jds, jde, kds, kde, &
1126                           ims, ime, jms, jme, kms, kme, &
1127                           its, ite, jts, jte, kts, kte )
1128
1129       itf=ite
1130       itf=MIN(ite,ide-1)
1131       jtf=jte
1132
1133       DO k=kts,ktf
1134       DO j=jts,jtf
1135       DO i=its,itf
1136            g_rfield(i,j,k)=g_field(i,j,k)*muv(i,j)/msf(i,j) + &
1137                          field(i,j,k)*g_muv(i,j)/msf(i,j)
1138       ENDDO
1139       ENDDO
1140       ENDDO
1141
1142    ELSE IF (name .EQ. 'w')THEN
1143       itf=MIN(ite,ide-1)
1144       jtf=MIN(jte,jde-1)
1145       DO k=kts,kte
1146       DO j=jts,jtf
1147       DO i=its,itf
1148          g_rfield(i,j,k)=g_field(i,j,k)*(mu(i,j)+mub(i,j))/msf(i,j) + &
1149                        field(i,j,k)*g_mu(i,j)/msf(i,j)
1150       ENDDO
1151       ENDDO
1152       ENDDO
1153
1154    ELSE IF (name .EQ. 'h')THEN
1155       itf=MIN(ite,ide-1)
1156       jtf=MIN(jte,jde-1)
1157       DO k=kts,kte
1158       DO j=jts,jtf
1159       DO i=its,itf
1160          g_rfield(i,j,k)=g_field(i,j,k)*(mu(i,j)+mub(i,j)) + &
1161                        field(i,j,k)*g_mu(i,j)
1162       ENDDO
1163       ENDDO
1164       ENDDO
1165
1166    ELSE
1167       itf=MIN(ite,ide-1)
1168       jtf=MIN(jte,jde-1)
1169       DO k=kts,ktf
1170       DO j=jts,jtf
1171       DO i=its,itf
1172          g_rfield(i,j,k)=g_field(i,j,k)*(mu(i,j)+mub(i,j)) + &
1173                        field(i,j,k)*g_mu(i,j)
1174       ENDDO
1175       ENDDO
1176       ENDDO
1177
1178    ENDIF
1179
1180 END SUBROUTINE g_couple
1181
1182 SUBROUTINE a_couple ( config_flags, mu, a_mu, mub, a_rfield, field, &
1183                     a_field, name, msf,               &
1184                     ids, ide, jds, jde, kds, kde, &
1185                     ims, ime, jms, jme, kms, kme, &
1186                     its, ite, jts, jte, kts, kte )
1187
1188 !-------------------------------------------------------------------------
1189 !  Derived from dyn_em/module_big_step_utilities_em.F
1190 !  Author: Xin Zhang, 10/2/2010
1191 !-------------------------------------------------------------------------
1192    IMPLICIT NONE
1193
1194    ! Input data
1195
1196    TYPE(grid_config_rec_type   ) ,   INTENT(IN   ) :: config_flags
1197
1198    INTEGER ,             INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1199                                           ims, ime, jms, jme, kms, kme, &
1200                                           its, ite, jts, jte, kts, kte
1201
1202    CHARACTER(LEN=1) ,     INTENT(IN   ) :: name
1203
1204    REAL , DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(INOUT) :: a_rfield
1205
1206    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mu,  mub, msf
1207    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: a_mu
1208
1209    REAL , DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(IN   ) :: field
1210    REAL , DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(INOUT) :: a_field
1211
1212    ! Local data
1213
1214    INTEGER :: i, j, k, itf, jtf, ktf
1215    REAL , DIMENSION(ims:ime,jms:jme) :: muu , muv
1216    REAL , DIMENSION(ims:ime,jms:jme) :: a_muu , a_muv
1217
1218 !<DESCRIPTION>
1219 !
1220 ! subroutine couple couples the input variable with the dry-air
1221 ! column mass (mu).
1222 !
1223 !</DESCRIPTION>
1224
1225    ktf=MIN(kte,kde-1)
1226
1227    IF (name .EQ. 'u')THEN
1228
1229       muu = 0.0
1230       muv = 0.0
1231       a_muu = 0.0
1232       a_muv = 0.0
1233
1234       CALL calc_mu_uv ( config_flags,                 &
1235                         mu, mub, muu, muv,            &
1236                         ids, ide, jds, jde, kds, kde, &
1237                         ims, ime, jms, jme, kms, kme, &
1238                         its, ite, jts, jte, kts, kte )
1239
1240       itf=ite
1241       jtf=MIN(jte,jde-1)
1242
1243       DO k=kts,ktf
1244       DO j=jts,jtf
1245       DO i=its,itf
1246          a_field(i,j,k)=a_field(i,j,k) + a_rfield(i,j,k)*muu(i,j)/msf(i,j)
1247          a_muu(i,j)=a_muu(i,j) + a_rfield(i,j,k)*field(i,j,k)/msf(i,j)
1248          a_rfield(i,j,k) = 0.0
1249       ENDDO
1250       ENDDO
1251       ENDDO
1252
1253       CALL a_calc_mu_uv ( config_flags,                 &
1254                           a_mu, a_muu, a_muv,  &
1255                           ids, ide, jds, jde, kds, kde, &
1256                           ims, ime, jms, jme, kms, kme, &
1257                           its, ite, jts, jte, kts, kte )
1258
1259    ELSE IF (name .EQ. 'v')THEN
1260
1261       muu = 0.0
1262       muv = 0.0
1263       a_muu = 0.0
1264       a_muv = 0.0
1265
1266       CALL calc_mu_uv ( config_flags,                 &
1267                         mu, mub, muu, muv,            &
1268                         ids, ide, jds, jde, kds, kde, &
1269                         ims, ime, jms, jme, kms, kme, &
1270                         its, ite, jts, jte, kts, kte )
1271
1272       itf=ite
1273       itf=MIN(ite,ide-1)
1274       jtf=jte
1275
1276       DO k=kts,ktf
1277       DO j=jts,jtf
1278       DO i=its,itf
1279          a_field(i,j,k)=a_field(i,j,k) + a_rfield(i,j,k)*muv(i,j)/msf(i,j)
1280          a_muv(i,j)=a_muv(i,j) + a_rfield(i,j,k)*field(i,j,k)/msf(i,j)
1281          a_rfield(i,j,k) = 0.0
1282       ENDDO
1283       ENDDO
1284       ENDDO
1285
1286       CALL a_calc_mu_uv ( config_flags,                 &
1287                           a_mu, a_muu, a_muv,  &
1288                           ids, ide, jds, jde, kds, kde, &
1289                           ims, ime, jms, jme, kms, kme, &
1290                           its, ite, jts, jte, kts, kte )
1291
1292    ELSE IF (name .EQ. 'w')THEN
1293       itf=MIN(ite,ide-1)
1294       jtf=MIN(jte,jde-1)
1295       DO k=kts,kte
1296       DO j=jts,jtf
1297       DO i=its,itf
1298          a_field(i,j,k)=a_field(i,j,k) + a_rfield(i,j,k)*(mu(i,j)+mub(i,j))/msf(i,j)
1299          a_mu(i,j)=a_mu(i,j) + a_rfield(i,j,k)*field(i,j,k)/msf(i,j)
1300          a_rfield(i,j,k) = 0.0
1301       ENDDO
1302       ENDDO
1303       ENDDO
1304
1305    ELSE IF (name .EQ. 'h')THEN
1306       itf=MIN(ite,ide-1)
1307       jtf=MIN(jte,jde-1)
1308       DO k=kts,kte
1309       DO j=jts,jtf
1310       DO i=its,itf
1311          a_field(i,j,k)=a_field(i,j,k) + a_rfield(i,j,k)*(mu(i,j)+mub(i,j))
1312          a_mu(i,j)=a_mu(i,j) + a_rfield(i,j,k)*field(i,j,k)
1313          a_rfield(i,j,k) = 0.0
1314       ENDDO
1315       ENDDO
1316       ENDDO
1317
1318    ELSE
1319       itf=MIN(ite,ide-1)
1320       jtf=MIN(jte,jde-1)
1321       DO k=kts,ktf
1322       DO j=jts,jtf
1323       DO i=its,itf
1324          a_field(i,j,k)=a_field(i,j,k) + a_rfield(i,j,k)*(mu(i,j)+mub(i,j))
1325          a_mu(i,j)=a_mu(i,j) + a_rfield(i,j,k)*field(i,j,k)
1326          a_rfield(i,j,k) = 0.0
1327       ENDDO
1328       ENDDO
1329       ENDDO
1330
1331    ENDIF
1332
1333 END SUBROUTINE a_couple
1334
1335  SUBROUTINE da_calc_2nd_fg ( data3d , space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
1336                              space_bdy_txs, space_bdy_txe, space_bdy_tys, space_bdy_tye, &
1337                              time_diff, char_stagger , &
1338                              spec_bdy_width , &
1339                              ids, ide, jds, jde, kds, kde , &
1340                              ims, ime, jms, jme, kms, kme , &
1341                              its, ite, jts, jte, kts, kte )
1342
1343 !-------------------------------------------------------------------------
1344 !  Calculate the first guess at the end of thr time window
1345 !  Author: Xin Zhang, 10/7/2010
1346 !-------------------------------------------------------------------------
1347
1348     IMPLICIT NONE
1349
1350     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1351     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1352     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1353     INTEGER , INTENT(IN) :: spec_bdy_width
1354     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT) :: data3d
1355     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(IN) :: space_bdy_xs, space_bdy_xe
1356     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(IN) :: space_bdy_ys, space_bdy_ye
1357     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(IN) :: space_bdy_txs, space_bdy_txe
1358     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(IN) :: space_bdy_tys, space_bdy_tye
1359     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1360     REAL , INTENT(IN) :: time_diff
1361
1362     INTEGER :: i , ii , j , jj , k
1363
1364     !  There are four lateral boundary locations that are stored.
1365
1366     !  X start boundary
1367
1368     IF ( char_stagger .EQ. 'W' ) THEN
1369        DO k = kds , kde
1370        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1371        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1372           data3d(i,j,k) = space_bdy_xs(j,k,i) + time_diff * space_bdy_txs(j,k,i)
1373        END DO
1374        END DO
1375        END DO
1376     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1377        DO k = kds , kde
1378        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1379        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1380           data3d(i,j,k) = space_bdy_xs(j,k,i) + time_diff * space_bdy_txs(j,k,i)
1381        END DO
1382        END DO
1383        END DO
1384     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1385        DO k = kds , kde - 1
1386        DO j = MAX(jds,jts) , MIN(jde,jte)
1387        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1388           data3d(i,j,k) = space_bdy_xs(j,k,i) + time_diff * space_bdy_txs(j,k,i)
1389        END DO
1390        END DO
1391        END DO
1392     ELSE
1393        DO k = kds , kde - 1
1394        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1395        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1396           data3d(i,j,k) = space_bdy_xs(j,k,i) + time_diff * space_bdy_txs(j,k,i)
1397        END DO
1398        END DO
1399        END DO
1400     END IF
1401
1402     !  X end boundary
1403
1404     IF      ( char_stagger .EQ. 'U' ) THEN
1405        DO k = kds , kde - 1
1406        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1407        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
1408           ii = ide - i + 1
1409           data3d(i,j,k) = space_bdy_xe(j,k,ii) + time_diff * space_bdy_txe(j,k,ii)
1410        END DO
1411        END DO
1412        END DO
1413     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1414        DO k = kds , kde - 1
1415        DO j = MAX(jds,jts) , MIN(jde,jte)
1416        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1417           ii = ide - i
1418           data3d(i,j,k) = space_bdy_xe(j,k,ii) + time_diff * space_bdy_txe(j,k,ii)
1419        END DO
1420        END DO
1421        END DO
1422     ELSE IF ( char_stagger .EQ. 'W' ) THEN
1423        DO k = kds , kde
1424        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1425        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1426           ii = ide - i
1427           data3d(i,j,k) = space_bdy_xe(j,k,ii) + time_diff * space_bdy_txe(j,k,ii)
1428        END DO
1429        END DO
1430        END DO
1431     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1432        DO k = kds , kde
1433        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1434        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1435           ii = ide - i
1436           data3d(i,j,k) = space_bdy_xe(j,k,ii) + time_diff * space_bdy_txe(j,k,ii)
1437        END DO
1438        END DO
1439        END DO
1440     ELSE
1441        DO k = kds , kde - 1
1442        DO j = MAX(jds,jts) , MIN(jde-1,jte)
1443        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1444           ii = ide - i
1445           data3d(i,j,k) = space_bdy_xe(j,k,ii) + time_diff * space_bdy_txe(j,k,ii)
1446        END DO
1447        END DO
1448        END DO
1449     END IF
1450
1451     !  Y start boundary
1452
1453     IF ( char_stagger .EQ. 'W' ) THEN
1454        DO k = kds , kde
1455        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1456        DO i = MAX(ids,its) , MIN(ide-1,ite)
1457           data3d(i,j,k) = space_bdy_ys(i,k,j) + time_diff * space_bdy_tys(i,k,j)
1458        END DO
1459        END DO
1460        END DO
1461     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1462        DO k = kds , kde
1463        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1464        DO i = MAX(ids,its) , MIN(ide-1,ite)
1465           data3d(i,j,k) = space_bdy_ys(i,k,j) + time_diff * space_bdy_tys(i,k,j)
1466        END DO
1467        END DO
1468        END DO
1469     ELSE IF ( char_stagger .EQ. 'U' ) THEN
1470        DO k = kds , kde - 1
1471        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1472        DO i = MAX(ids,its) , MIN(ide,ite)
1473           data3d(i,j,k) = space_bdy_ys(i,k,j) + time_diff * space_bdy_tys(i,k,j)
1474        END DO
1475        END DO
1476        END DO
1477     ELSE
1478        DO k = kds , kde - 1
1479        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1480        DO i = MAX(ids,its) , MIN(ide-1,ite)
1481           data3d(i,j,k) = space_bdy_ys(i,k,j) + time_diff * space_bdy_tys(i,k,j)
1482        END DO
1483        END DO
1484        END DO
1485     END IF
1486
1487     !  Y end boundary
1488
1489     IF      ( char_stagger .EQ. 'V' ) THEN
1490        DO k = kds , kde - 1
1491        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
1492        DO i = MAX(ids,its) , MIN(ide-1,ite)
1493           jj = jde - j + 1
1494           data3d(i,j,k) = space_bdy_ye(i,k,jj) + time_diff * space_bdy_tye(i,k,jj)
1495        END DO
1496        END DO
1497        END DO
1498     ELSE IF ( char_stagger .EQ. 'U' ) THEN
1499        DO k = kds , kde - 1
1500        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1501        DO i = MAX(ids,its) , MIN(ide,ite)
1502           jj = jde - j
1503           data3d(i,j,k) = space_bdy_ye(i,k,jj) + time_diff * space_bdy_tye(i,k,jj)
1504        END DO
1505        END DO
1506        END DO
1507     ELSE IF ( char_stagger .EQ. 'W' ) THEN
1508        DO k = kds , kde
1509        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1510        DO i = MAX(ids,its) , MIN(ide-1,ite)
1511           jj = jde - j
1512           data3d(i,j,k) = space_bdy_ye(i,k,jj) + time_diff * space_bdy_tye(i,k,jj)
1513        END DO
1514        END DO
1515        END DO
1516     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1517        DO k = kds , kde
1518        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1519        DO i = MAX(ids,its) , MIN(ide-1,ite)
1520           jj = jde - j
1521           data3d(i,j,k) = space_bdy_ye(i,k,jj) + time_diff * space_bdy_tye(i,k,jj)
1522        END DO
1523        END DO
1524        END DO
1525     ELSE
1526        DO k = kds , kde - 1
1527        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1528        DO i = MAX(ids,its) , MIN(ide-1,ite)
1529           jj = jde - j
1530           data3d(i,j,k) = space_bdy_ye(i,k,jj) + time_diff * space_bdy_tye(i,k,jj)
1531        END DO
1532        END DO
1533        END DO
1534     END IF
1535
1536  END SUBROUTINE da_calc_2nd_fg
1537
1538 SUBROUTINE decouple ( mu, mub, field, name, &
1539                     msf,                          &
1540                     ids, ide, jds, jde, kds, kde, &
1541                     ims, ime, jms, jme, kms, kme, &
1542                     its, ite, jts, jte, kts, kte )
1543
1544 !-------------------------------------------------------------------------
1545 !  Decouple variables
1546 !  Author: Xin Zhang, 10/7/2010
1547 !-------------------------------------------------------------------------
1548    IMPLICIT NONE
1549
1550    ! Input data
1551
1552    INTEGER ,             INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1553                                           ims, ime, jms, jme, kms, kme, &
1554                                           its, ite, jts, jte, kts, kte
1555
1556    CHARACTER(LEN=1) ,     INTENT(IN   ) :: name
1557
1558    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mu, mub, msf
1559    REAL , DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(INOUT) :: field
1560
1561    ! Local data
1562
1563    INTEGER :: i, j, k, itf, jtf, ktf
1564    REAL , DIMENSION(ims:ime,jms:jme) :: muu , muv
1565
1566 !<DESCRIPTION>
1567 !
1568 ! subroutine couple couples the input variable with the dry-air
1569 ! column mass (mu).
1570 !
1571 !</DESCRIPTION>
1572
1573
1574    ktf=MIN(kte,kde-1)
1575
1576    IF (name .EQ. 'u')THEN
1577
1578       CALL calc_mu_uv ( config_flags,                 &
1579                         mu, mub, muu, muv,            &
1580                         ids, ide, jds, jde, kds, kde, &
1581                         ims, ime, jms, jme, kms, kme, &
1582                         its, ite, jts, jte, kts, kte )
1583
1584       itf=ite
1585       jtf=MIN(jte,jde-1)
1586
1587       DO k=kts,ktf
1588       DO j=jts,jtf
1589       DO i=its,itf
1590          field(i,j,k)=field(i,j,k)/muu(i,j)*msf(i,j)
1591       ENDDO
1592       ENDDO
1593       ENDDO
1594
1595    ELSE IF (name .EQ. 'v')THEN
1596
1597       CALL calc_mu_uv ( config_flags,                 &
1598                         mu, mub, muu, muv,            &
1599                         ids, ide, jds, jde, kds, kde, &
1600                         ims, ime, jms, jme, kms, kme, &
1601                         its, ite, jts, jte, kts, kte )
1602
1603       itf=ite
1604       itf=MIN(ite,ide-1)
1605       jtf=jte
1606
1607       DO k=kts,ktf
1608       DO j=jts,jtf
1609       DO i=its,itf
1610            field(i,j,k)=field(i,j,k)/muv(i,j)*msf(i,j)
1611       ENDDO
1612       ENDDO
1613       ENDDO
1614
1615    ELSE IF (name .EQ. 'w')THEN
1616       itf=MIN(ite,ide-1)
1617       jtf=MIN(jte,jde-1)
1618       DO k=kts,kte
1619       DO j=jts,jtf
1620       DO i=its,itf
1621          field(i,j,k)=field(i,j,k)/(mu(i,j)+mub(i,j))*msf(i,j)
1622       ENDDO
1623       ENDDO
1624       ENDDO
1625
1626    ELSE IF (name .EQ. 'h')THEN
1627       itf=MIN(ite,ide-1)
1628       jtf=MIN(jte,jde-1)
1629       DO k=kts,kte
1630       DO j=jts,jtf
1631       DO i=its,itf
1632          field(i,j,k)=field(i,j,k)/(mu(i,j)+mub(i,j))
1633       ENDDO
1634       ENDDO
1635       ENDDO
1636
1637    ELSE
1638       itf=MIN(ite,ide-1)
1639       jtf=MIN(jte,jde-1)
1640       DO k=kts,ktf
1641       DO j=jts,jtf
1642       DO i=its,itf
1643          field(i,j,k)=field(i,j,k)/(mu(i,j)+mub(i,j))
1644       ENDDO
1645       ENDDO
1646       ENDDO
1647
1648    ENDIF
1649
1650 END SUBROUTINE decouple
1651
1652 SUBROUTINE da_model_lbc_off
1653
1654    CALL nl_set_io_form_boundary( head_grid%id, 0 )
1655
1656 END SUBROUTINE da_model_lbc_off
1657
1658 SUBROUTINE da_bdy_fields_halo (data3du, data3dv, data3dt, data3dph, data3dmu, &
1659                              data3dm, dir, xy, spec_bdy_width,              &
1660                              u_bxs,  u_bxe,  u_bys,  u_bye,                 &
1661                              v_bxs,  v_bxe,  v_bys,  v_bye,                 &
1662                              t_bxs,  t_bxe,  t_bys,  t_bye,                 &
1663                              ph_bxs, ph_bxe, ph_bys, ph_bye,                &
1664                              mu_bxs, mu_bxe, mu_bys, mu_bye,                &
1665                              moist_bxs, moist_bxe, moist_bys, moist_bye,    &
1666                              ids, ide, jds, jde, kds, kde ,                 &
1667                              ims, ime, jms, jme, kms, kme ,                 &
1668                              its, ite, jts, jte, kts, kte )
1669
1670     USE module_state_description
1671
1672     IMPLICIT NONE
1673
1674     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1675     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1676     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1677     INTEGER , INTENT(IN) :: spec_bdy_width
1678     INTEGER , INTENT(IN) :: dir ! 0----pack ; 1----unpack
1679     INTEGER , INTENT(IN) :: xy  ! 0----X ; 1----Y
1680     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT) :: data3du , data3dv, data3dt, &
1681                                                                  data3dph, data3dm
1682     REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: data3dmu
1683     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(INOUT) :: u_bxs, u_bxe, v_bxs, v_bxe, &
1684                                                                         t_bxs, t_bxe, ph_bxs, ph_bxe, &
1685                                                                         moist_bxs, moist_bxe
1686     REAL , DIMENSION(jms:jme,1:1,spec_bdy_width) , INTENT(INOUT) :: mu_bxs, mu_bxe
1687     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(INOUT) :: u_bys, u_bye, v_bys, v_bye, &
1688                                                                         t_bys, t_bye, ph_bys, ph_bye, &
1689                                                                         moist_bys, moist_bye
1690     REAL , DIMENSION(ims:ime,1:1,spec_bdy_width) , INTENT(INOUT) :: mu_bys, mu_bye
1691
1692    CALL da_bdy_fields_pack ( data3du, u_bxs, u_bxe, u_bys, u_bye,        &
1693                                     'U' , dir, xy, spec_bdy_width,    &
1694                                     ids, ide, jds, jde, kds, kde,     &
1695                                     ims, ime, jms, jme, kms, kme,     &
1696                                     its, ite, jts, jte, kts, kte      )
1697
1698    CALL da_bdy_fields_pack ( data3dv, v_bxs, v_bxe, v_bys, v_bye,        &
1699                                     'V' , dir, xy, spec_bdy_width,    &
1700                                     ids, ide, jds, jde, kds, kde,     &
1701                                     ims, ime, jms, jme, kms, kme,     &
1702                                     its, ite, jts, jte, kts, kte      )
1703
1704    CALL da_bdy_fields_pack ( data3dt , t_bxs, t_bxe, t_bys, t_bye,       &
1705                                     'T' , dir, xy, spec_bdy_width,    &
1706                                     ids, ide, jds, jde, kds, kde,     &
1707                                     ims, ime, jms, jme, kms, kme,     &
1708                                     its, ite, jts, jte, kts, kte      )
1709
1710    CALL da_bdy_fields_pack ( data3dph , ph_bxs, ph_bxe, ph_bys, ph_bye,  &
1711                                     'W' , dir, xy, spec_bdy_width,    &
1712                                     ids, ide, jds, jde, kds, kde,     &
1713                                     ims, ime, jms, jme, kms, kme,     &
1714                                     its, ite, jts, jte, kts, kte      )
1715
1716    CALL da_bdy_fields_pack ( data3dmu , mu_bxs, mu_bxe, mu_bys, mu_bye,  &
1717                                     'M' , dir, xy, spec_bdy_width  ,  &
1718                                     ids, ide, jds, jde, 1  , 1  ,     &
1719                                     ims, ime, jms, jme, 1  , 1  ,     &
1720                                     its, ite, jts, jte, 1  , 1        )
1721
1722    CALL da_bdy_fields_pack ( data3dm , moist_bxs, moist_bxe, moist_bys, moist_bye,       &
1723                                     'T' , dir, xy, spec_bdy_width,    &
1724                                     ids, ide, jds, jde, kds, kde,     &
1725                                     ims, ime, jms, jme, kms, kme,     &
1726                                     its, ite, jts, jte, kts, kte      )
1727
1728
1729 END SUBROUTINE da_bdy_fields_halo
1730
1731 SUBROUTINE da_bdy_fields_pack ( data3d , space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, &
1732                              char_stagger , dir , xy ,&
1733                              spec_bdy_width , &
1734                              ids, ide, jds, jde, kds, kde , &
1735                              ims, ime, jms, jme, kms, kme , &
1736                              its, ite, jts, jte, kts, kte )
1737
1738 !-------------------------------------------------------------------------
1739 !  Calculate the first guess at the end of thr time window
1740 !  Author: Xin Zhang, 10/7/2010
1741 !-------------------------------------------------------------------------
1742
1743     IMPLICIT NONE
1744
1745     INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde
1746     INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme
1747     INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte
1748     INTEGER , INTENT(IN) :: spec_bdy_width
1749     REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT) :: data3d
1750     REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(INOUT) :: space_bdy_xs, space_bdy_xe
1751     REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(INOUT) :: space_bdy_ys, space_bdy_ye
1752     CHARACTER (LEN=1) , INTENT(IN) :: char_stagger
1753     INTEGER , INTENT(IN) :: dir ! 0----pack ; 1----unpack
1754     INTEGER , INTENT(IN) :: xy  ! 0----X ; 1----Y
1755
1756     INTEGER :: i , ii , j , jj , k
1757
1758     !  There are four lateral boundary locations that are stored.
1759
1760 IF (dir == 0 ) THEN  ! ----Pack
1761    IF ( xy == 0 ) THEN  ! ----X
1762
1763     !  X start boundary
1764
1765     IF ( char_stagger .EQ. 'W' ) THEN
1766        DO k = kds , kde
1767        DO j = jms, jme
1768        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1769           data3d(i,j,k) = space_bdy_xs(j,k,i)
1770        END DO
1771        END DO
1772        END DO
1773     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1774        DO k = kds , kde
1775        DO j = jms, jme
1776        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1777           data3d(i,j,k) = space_bdy_xs(j,k,i)
1778        END DO
1779        END DO
1780        END DO
1781     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1782        DO k = kds , kde - 1
1783        DO j = jms, jme
1784        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1785           data3d(i,j,k) = space_bdy_xs(j,k,i)
1786        END DO
1787        END DO
1788        END DO
1789     ELSE
1790        DO k = kds , kde - 1
1791        DO j = jms, jme
1792        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1793           data3d(i,j,k) = space_bdy_xs(j,k,i)
1794        END DO
1795        END DO
1796        END DO
1797     END IF
1798
1799     !  X end boundary
1800
1801     IF      ( char_stagger .EQ. 'U' ) THEN
1802        DO k = kds , kde - 1
1803        DO j = jms, jme
1804        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
1805           ii = ide - i + 1
1806           data3d(i,j,k) = space_bdy_xe(j,k,ii)
1807        END DO
1808        END DO
1809        END DO
1810     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1811        DO k = kds , kde - 1
1812        DO j = jms, jme
1813        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1814           ii = ide - i
1815           data3d(i,j,k) = space_bdy_xe(j,k,ii)
1816        END DO
1817        END DO
1818        END DO
1819     ELSE IF ( char_stagger .EQ. 'W' ) THEN
1820        DO k = kds , kde
1821        DO j = jms, jme
1822        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1823           ii = ide - i
1824           data3d(i,j,k) = space_bdy_xe(j,k,ii)
1825        END DO
1826        END DO
1827        END DO
1828     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1829        DO k = kds , kde
1830        DO j = jms, jme
1831        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1832           ii = ide - i
1833           data3d(i,j,k) = space_bdy_xe(j,k,ii)
1834        END DO
1835        END DO
1836        END DO
1837     ELSE
1838        DO k = kds , kde - 1
1839        DO j = jms, jme
1840        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1841           ii = ide - i
1842           data3d(i,j,k) = space_bdy_xe(j,k,ii)
1843        END DO
1844        END DO
1845        END DO
1846     END IF
1847
1848 ELSE    !    Y
1849     !  Y start boundary
1850
1851     IF ( char_stagger .EQ. 'W' ) THEN
1852        DO k = kds , kde
1853        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1854        DO i = ims, ime
1855           data3d(i,j,k) = space_bdy_ys(i,k,j)
1856        END DO
1857        END DO
1858        END DO
1859     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1860        DO k = kds , kde
1861        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1862        DO i = ims, ime
1863           data3d(i,j,k) = space_bdy_ys(i,k,j)
1864        END DO
1865        END DO
1866        END DO
1867     ELSE IF ( char_stagger .EQ. 'U' ) THEN
1868        DO k = kds , kde - 1
1869        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1870        DO i = ims, ime
1871           data3d(i,j,k) = space_bdy_ys(i,k,j)
1872        END DO
1873        END DO
1874        END DO
1875     ELSE
1876        DO k = kds , kde - 1
1877        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
1878        DO i = ims, ime
1879           data3d(i,j,k) = space_bdy_ys(i,k,j)
1880        END DO
1881        END DO
1882        END DO
1883     END IF
1884
1885     !  Y end boundary
1886
1887     IF      ( char_stagger .EQ. 'V' ) THEN
1888        DO k = kds , kde - 1
1889        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
1890        DO i = ims, ime
1891           jj = jde - j + 1
1892           data3d(i,j,k) = space_bdy_ye(i,k,jj)
1893        END DO
1894        END DO
1895        END DO
1896     ELSE IF ( char_stagger .EQ. 'U' ) THEN
1897        DO k = kds , kde - 1
1898        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1899        DO i = ims, ime
1900           jj = jde - j
1901           data3d(i,j,k) = space_bdy_ye(i,k,jj)
1902        END DO
1903        END DO
1904        END DO
1905     ELSE IF ( char_stagger .EQ. 'W' ) THEN
1906        DO k = kds , kde
1907        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1908        DO i = ims, ime
1909           jj = jde - j
1910           data3d(i,j,k) = space_bdy_ye(i,k,jj)
1911        END DO
1912        END DO
1913        END DO
1914     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1915        DO k = kds , kde
1916        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1917        DO i = ims, ime
1918           jj = jde - j
1919           data3d(i,j,k) = space_bdy_ye(i,k,jj)
1920        END DO
1921        END DO
1922        END DO
1923     ELSE
1924        DO k = kds , kde - 1
1925        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
1926        DO i = ims, ime
1927           jj = jde - j
1928           data3d(i,j,k) = space_bdy_ye(i,k,jj)
1929        END DO
1930        END DO
1931        END DO
1932     END IF
1933
1934    END IF
1935 END IF
1936
1937 IF ( dir == 1 ) THEN  ! ---- Unpack
1938    IF ( xy == 0 ) THEN !----- X
1939
1940     !  X start boundary
1941
1942     IF ( char_stagger .EQ. 'W' ) THEN
1943        DO k = kds , kde
1944        DO j = jms, jme
1945        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1946           space_bdy_xs(j,k,i) = data3d(i,j,k)
1947        END DO
1948        END DO
1949        END DO
1950     ELSE IF ( char_stagger .EQ. 'M' ) THEN
1951        DO k = kds , kde
1952        DO j = jms, jme
1953        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1954           space_bdy_xs(j,k,i) = data3d(i,j,k)
1955        END DO
1956        END DO
1957        END DO
1958     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1959        DO k = kds , kde - 1
1960        DO j = jms, jme
1961        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1962           space_bdy_xs(j,k,i) = data3d(i,j,k)
1963        END DO
1964        END DO
1965        END DO
1966     ELSE
1967        DO k = kds , kde - 1
1968        DO j = jms, jme
1969        DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite)
1970           space_bdy_xs(j,k,i) = data3d(i,j,k)
1971        END DO
1972        END DO
1973        END DO
1974     END IF
1975
1976     !  X end boundary
1977
1978     IF      ( char_stagger .EQ. 'U' ) THEN
1979        DO k = kds , kde - 1
1980        DO j = jms, jme
1981        DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1
1982           ii = ide - i + 1
1983           space_bdy_xe(j,k,ii) = data3d(i,j,k)
1984        END DO
1985        END DO
1986        END DO
1987     ELSE IF ( char_stagger .EQ. 'V' ) THEN
1988        DO k = kds , kde - 1
1989        DO j = jms, jme
1990        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
1991           ii = ide - i
1992           space_bdy_xe(j,k,ii) = data3d(i,j,k)
1993        END DO
1994        END DO
1995        END DO
1996     ELSE IF ( char_stagger .EQ. 'W' ) THEN
1997        DO k = kds , kde
1998        DO j = jms, jme
1999        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2000           ii = ide - i
2001           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2002        END DO
2003        END DO
2004        END DO
2005     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2006        DO k = kds , kde
2007        DO j = jms, jme
2008        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2009           ii = ide - i
2010           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2011        END DO
2012        END DO
2013        END DO
2014     ELSE
2015        DO k = kds , kde - 1
2016        DO j = jms, jme
2017        DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1
2018           ii = ide - i
2019           space_bdy_xe(j,k,ii) = data3d(i,j,k)
2020        END DO
2021        END DO
2022        END DO
2023     END IF
2024
2025 ELSE   !  Y
2026     !  Y start boundary
2027
2028     IF ( char_stagger .EQ. 'W' ) THEN
2029        DO k = kds , kde
2030        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2031        DO i = ims, ime
2032           space_bdy_ys(i,k,j) = data3d(i,j,k)
2033        END DO
2034        END DO
2035        END DO
2036     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2037        DO k = kds , kde
2038        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2039        DO i = ims, ime
2040           space_bdy_ys(i,k,j) = data3d(i,j,k)
2041        END DO
2042        END DO
2043        END DO
2044     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2045        DO k = kds , kde - 1
2046        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2047        DO i = ims, ime
2048           space_bdy_ys(i,k,j) = data3d(i,j,k)
2049        END DO
2050        END DO
2051        END DO
2052     ELSE
2053        DO k = kds , kde - 1
2054        DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte)
2055        DO i = ims, ime
2056           space_bdy_ys(i,k,j) = data3d(i,j,k)
2057        END DO
2058        END DO
2059        END DO
2060     END IF
2061
2062     !  Y end boundary
2063
2064     IF      ( char_stagger .EQ. 'V' ) THEN
2065        DO k = kds , kde - 1
2066        DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1
2067        DO i = ims, ime
2068           jj = jde - j + 1
2069           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2070        END DO
2071        END DO
2072        END DO
2073     ELSE IF ( char_stagger .EQ. 'U' ) THEN
2074        DO k = kds , kde - 1
2075        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2076        DO i = ims, ime
2077           jj = jde - j
2078           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2079        END DO
2080        END DO
2081        END DO
2082     ELSE IF ( char_stagger .EQ. 'W' ) THEN
2083        DO k = kds , kde
2084        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2085        DO i = ims, ime
2086           jj = jde - j
2087           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2088        END DO
2089        END DO
2090        END DO
2091     ELSE IF ( char_stagger .EQ. 'M' ) THEN
2092        DO k = kds , kde
2093        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2094        DO i = ims, ime
2095           jj = jde - j
2096           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2097        END DO
2098        END DO
2099        END DO
2100     ELSE
2101        DO k = kds , kde - 1
2102        DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1
2103        DO i = ims, ime
2104           jj = jde - j
2105           space_bdy_ye(i,k,jj) = data3d(i,j,k)
2106        END DO
2107        END DO
2108        END DO
2109     END IF
2110
2111    END IF
2112 END IF
2113
2114 END SUBROUTINE da_bdy_fields_pack