WPS/geogrid/src/smooth_module.f90

   1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   2 ! MODULE SMOOTH_MODULE
   3 !
   4 ! This module provides routines for smoothing.
   5 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   6 module smooth_module
   7
   8    use parallel_module
   9
  10
  11    contains
  12
  13
  14    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  15    ! Name: one_two_one
  16    !
  17    ! Purpose: Apply the 1-2-1 smoother from the MM5 program TERRAIN
  18    !   (found in smth121.F) to array.
  19    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  20    subroutine one_two_one(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, &
  21                           start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval)
  22
  23       implicit none
  24
  25       ! Arguments
  26       integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z
  27       integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z
  28       integer, intent(in) :: npass
  29       real, intent(in) :: msgval
  30       real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(inout) :: array
  31
  32       ! Local variables
  33       integer :: ix, iy, iz, ipass
  34       real, pointer, dimension(:,:,:) :: scratch
  35
  36       allocate(scratch(start_x+1:end_x-1, start_y:end_y, start_z:end_z))
  37
  38       do ipass=1,npass
  39
  40          do iy=start_y,end_y
  41             do ix=start_x+1,end_x-1
  42                do iz=start_z,end_z
  43                   scratch(ix,iy,iz) = 0.50*array(ix,iy,iz)+0.25*(array(ix-1,iy,iz)+array(ix+1,iy,iz))
  44                end do
  45             end do
  46          end do
  47
  48          do iy=start_y+1,end_y-1
  49             do ix=start_x+1,end_x-1
  50                do iz=start_z,end_z
  51                   array(ix,iy,iz) = 0.50*scratch(ix,iy,iz)+0.25*(scratch(ix,iy-1,iz)+scratch(ix,iy+1,iz))
  52                end do
  53              end do
  54           end do
  55
  56          call exchange_halo_r(array, &
  57                               start_x, end_x, start_y, end_y, start_z, end_z, &
  58                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
  59
  60       end do
  61
  62       deallocate(scratch)
  63
  64    end subroutine one_two_one
  65
  66
  67    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  68    ! Name: smth_desmth
  69    !
  70    ! Purpose: Apply the smoother-desmoother from the MM5 program TERRAIN
  71    !   (found in smther.F) to array.
  72    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  73    subroutine smth_desmth(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, &
  74                           start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval)
  75
  76       implicit none
  77
  78       ! Arguments
  79       integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z
  80       integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z
  81       integer, intent(in) :: npass
  82       real, intent(in) :: msgval
  83       real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(inout) :: array
  84
  85       ! Local variables
  86       integer :: ix, iy, iz, ipass
  87       real, pointer, dimension(:,:,:) :: scratch
  88
  89       allocate(scratch(start_x+1:end_x-1, start_y:end_y, start_z:end_z))
  90
  91       do ipass=1,npass
  92
  93          !
  94          ! Smoothing pass
  95          !
  96          do iy=start_y,end_y
  97             do ix=start_x+1,end_x-1
  98                do iz=start_z,end_z
  99                   scratch(ix,iy,iz) = 0.5*array(ix,iy,iz) + 0.25*(array(ix-1,iy,iz)+array(ix+1,iy,iz))
 100                end do
 101             end do
 102          end do
 103
 104          do iy=start_y+1,end_y-1
 105             do ix=start_x+1,end_x-1
 106                do iz=start_z,end_z
 107                   array(ix,iy,iz) = 0.5*scratch(ix,iy,iz) + 0.25*(scratch(ix,iy-1,iz)+scratch(ix,iy+1,iz))
 108                end do
 109             end do
 110          end do
 111
 112          call exchange_halo_r(array, &
 113                               start_x, end_x, start_y, end_y, start_z, end_z, &
 114                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
 115
 116          !
 117          ! Desmoothing pass
 118          !
 119          do iy=start_y,end_y
 120             do ix=start_x+1,end_x-1
 121                do iz=start_z,end_z
 122                   scratch(ix,iy,iz) = 1.52*array(ix,iy,iz) - 0.26*(array(ix-1,iy,iz)+array(ix+1,iy,iz))
 123                end do
 124             end do
 125          end do
 126
 127          do iy=start_y+1,end_y-1
 128             do ix=start_x+1,end_x-1
 129                do iz=start_z,end_z
 130                   array(ix,iy,iz) = 1.52*scratch(ix,iy,iz) - 0.26*(scratch(ix,iy-1,iz)+scratch(ix,iy+1,iz))
 131                end do
 132             end do
 133          end do
 134
 135          call exchange_halo_r(array, &
 136                               start_x, end_x, start_y, end_y, start_z, end_z, &
 137                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
 138
 139       end do
 140
 141       deallocate(scratch)
 142
 143    end subroutine smth_desmth
 144
 145
 146    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 147    ! Name: smth_desmth_special
 148    !
 149    ! Purpose: Apply the smoother-desmoother from the MM5 program TERRAIN
 150    !   (found in smther.F) to array; however, any grid points that were not
 151    !   originally negative but which have been smoothed to a negative value
 152    !   will be restored to their original values.
 153    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 154    subroutine smth_desmth_special(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, &
 155                                   start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval)
 156
 157       implicit none
 158
 159       ! Arguments
 160       integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z
 161       integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z
 162       integer, intent(in) :: npass
 163       real, intent(in) :: msgval
 164       real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(inout) :: array
 165
 166       ! Local variables
 167       integer :: ix, iy, iz, ipass
 168       real, pointer, dimension(:,:,:) :: scratch, orig_array
 169
 170       allocate(scratch(start_x+1:end_x-1, start_y:end_y, start_z:end_z))
 171       allocate(orig_array(start_x:end_x, start_y:end_y, start_z:end_z))
 172
 173       orig_array = array
 174
 175       do ipass=1,npass
 176
 177          !
 178          ! Smoothing pass
 179          !
 180          do iy=start_y,end_y
 181             do ix=start_x+1,end_x-1
 182                do iz=start_z,end_z
 183                   scratch(ix,iy,iz) = 0.5*array(ix,iy,iz) + 0.25*(array(ix-1,iy,iz)+array(ix+1,iy,iz))
 184                end do
 185             end do
 186          end do
 187
 188          do iy=start_y+1,end_y-1
 189             do ix=start_x+1,end_x-1
 190                do iz=start_z,end_z
 191                   array(ix,iy,iz) = 0.5*scratch(ix,iy,iz) + 0.25*(scratch(ix,iy-1,iz)+scratch(ix,iy+1,iz))
 192                end do
 193             end do
 194          end do
 195
 196          call exchange_halo_r(array, &
 197                               start_x, end_x, start_y, end_y, start_z, end_z, &
 198                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
 199
 200          !
 201          ! Desmoothing pass
 202          !
 203          do iy=start_y,end_y
 204             do ix=start_x+1,end_x-1
 205                do iz=start_z,end_z
 206                   scratch(ix,iy,iz) = 1.52*array(ix,iy,iz) - 0.26*(array(ix-1,iy,iz)+array(ix+1,iy,iz))
 207                end do
 208             end do
 209          end do
 210
 211          do iy=start_y+1,end_y-1
 212             do ix=start_x+1,end_x-1
 213                do iz=start_z,end_z
 214                   array(ix,iy,iz) = 1.52*scratch(ix,iy,iz) - 0.26*(scratch(ix,iy-1,iz)+scratch(ix,iy+1,iz))
 215                end do
 216             end do
 217          end do
 218
 219          call exchange_halo_r(array, &
 220                               start_x, end_x, start_y, end_y, start_z, end_z, &
 221                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
 222
 223       end do
 224
 225       ! Remove artificially negative values
 226       do iy=start_y,end_y
 227          do ix=start_x,end_x
 228             do iz=start_z,end_z
 229                if (array(ix,iy,iz) < 0. .and. orig_array(ix,iy,iz) >= 0.) then
 230                   array(ix,iy,iz) = orig_array(ix,iy,iz)
 231                end if
 232             end do
 233          end do
 234       end do
 235
 236       deallocate(scratch)
 237       deallocate(orig_array)
 238
 239    end subroutine smth_desmth_special
 240
 241
 242    !
 243    ! Smoothing routines for E-grid, contributed by Matthew Pyle
 244    !
 245
 246    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 247    ! Name: one_two_one_egrid
 248    !
 249    ! Purpose: Apply the 1-2-1 smoother from the MM5 program TERRAIN
 250    !   (found in smth121.F) to array.
 251    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 252    subroutine one_two_one_egrid(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, &
 253                                 start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval, hflag)
 254
 255       implicit none
 256
 257       ! Arguments
 258       integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z
 259       integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z
 260       integer, intent(in) :: npass
 261       real, intent(in) :: msgval, hflag
 262       real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(inout) :: array
 263
 264       ! Local variables
 265       integer :: ix, iy, iz, ipass
 266       real, pointer, dimension(:,:,:) :: scratch
 267       integer, dimension(start_y:end_y) :: ihe, ihw, istart
 268
 269       allocate(scratch(start_x:end_x, start_y:end_y, start_z:end_z))
 270
 271       do iy=start_y,end_y
 272          if (hflag == 1.0) then
 273             ihe(iy) = abs(mod(iy+1,2))
 274             ihw(iy) = ihe(iy)-1
 275          else
 276             ! assign ive,ivw equivs to ihe,ihw
 277             ihe(iy) = abs(mod(iy,2))
 278             ihw(iy) = ihe(iy)-1
 279          end if
 280       end do
 281
 282       do iy=start_y,end_y
 283          if (hflag == 1.0) then
 284             if (mod(iy,2) == 0) then
 285                istart(iy) = start_x
 286             else
 287                istart(iy) = start_x+1
 288             end if
 289          else ! v points
 290             if (abs(mod(iy,2)) == 1) then
 291                istart(iy) = start_x
 292             else
 293                istart(iy) = start_x+1
 294             end if
 295          end if
 296       end do
 297
 298       do ipass=1,npass
 299
 300          do iy=start_y,end_y
 301             do ix=start_x,end_x
 302                scratch(ix,iy,1) = array(ix,iy,1) ! for points used in 2nd computation but not defined in 1st computation
 303             end do
 304          end do
 305
 306          ! SW-NE direction
 307          do iy=start_y+1,end_y-1
 308             do ix=istart(iy),end_x-1
 309                do iz=start_z,end_z
 310                   if ( (msgval == 1.0 .and. array(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then
 311                      scratch(ix,iy,iz) = 0.50*array(ix,iy,iz)+ &
 312                                       0.25*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz))
 313                   end if
 314                end do
 315             end do
 316          end do
 317
 318          ! NW-SE direction
 319          do iy=start_y+1,end_y-1
 320             do ix=istart(iy),end_x-1
 321                do iz=start_z,end_z
 322                   if ( (msgval == 1.0 .and. array(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then
 323                      array(ix,iy,iz) = 0.50*scratch(ix,iy,iz)+ &
 324                                     0.25*(scratch(ix+ihe(iy),iy-1,iz)+scratch(ix+ihw(iy),iy+1,iz))
 325                   end if
 326                end do
 327             end do
 328          end do
 329
 330          call exchange_halo_r(array, &
 331                               start_x, end_x, start_y, end_y, start_z, end_z, &
 332                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
 333
 334       end do
 335
 336       deallocate(scratch)
 337
 338    end subroutine one_two_one_egrid
 339
 340
 341    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 342    ! Name: smth_desmth_egrid_old
 343    !
 344    ! Purpose: Apply the smoother-desmoother for E grid
 345    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 346    subroutine smth_desmth_egrid_old(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, &
 347                                     start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval, hflag)
 348
 349       implicit none
 350
 351       ! Arguments
 352       integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z
 353       integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z
 354       integer, intent(in) :: npass
 355       real, intent(in) :: msgval, hflag
 356       real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
 357                intent(inout) :: array
 358
 359       ! Local variables
 360       integer :: ix, iy, iz, ipass
 361       real, pointer, dimension(:,:,:) :: scratch
 362       integer, dimension(start_y:end_y) :: ihe, ihw, istart
 363       real, parameter:: cenwgt = 1.52
 364       real, parameter:: endwgt = 0.13
 365
 366       allocate(scratch(start_x:end_x, start_y:end_y, start_z:end_z))
 367
 368       do iy=start_y,end_y
 369          if (hflag == 1.0) then
 370             ihe(iy) = abs(mod(iy+1,2))
 371             ihw(iy) = ihe(iy)-1
 372          else
 373             ! assign ive,ivw equivs to ihe,ihw
 374             ihe(iy) = abs(mod(iy,2))
 375             ihw(iy) = ihe(iy)-1
 376          end if
 377       end do
 378
 379       do iy=start_y,end_y
 380          if (hflag == 1.0) then
 381             if (mod(iy,2) == 0) then
 382                istart(iy) = start_x
 383             else
 384                istart(iy) = start_x+1
 385             endif
 386          else ! v points
 387             if (abs(mod(iy,2)) == 1) then
 388                istart(iy) = start_x
 389             else
 390                istart(iy) = start_x+1
 391             endif
 392          endif
 393       end do
 394
 395       do ipass=1,npass
 396
 397          !
 398          ! Smoothing pass
 399          !
 400
 401          do iy=start_y,end_y
 402             do ix=start_x,end_x
 403                scratch(ix,iy,1) = array(ix,iy,1)
 404             end do
 405          end do
 406
 407          do iy=start_y+1,end_y-1
 408             do ix=istart(iy),end_x-1
 409                do iz=start_z,end_z
 410                   if ( (msgval == 1.0 .and. array(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then
 411                      scratch(ix,iy,iz) = 0.50*array(ix,iy,iz)+ &
 412                                       0.125*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz)+ &
 413                                              array(ix+ihw(iy),iy+1,iz)+array(ix+ihe(iy),iy-1,iz))
 414                   end if
 415                end do
 416             end do
 417          end do
 418
 419
 420          !
 421          ! Desmoothing pass
 422          !
 423
 424          do iy=start_y+2,end_y-2
 425             do ix=istart(iy),end_x-1
 426                do iz=start_z,end_z
 427                   if ( (msgval == 1.0 .and. scratch(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then
 428                      array(ix,iy,iz) = cenwgt*scratch(ix,iy,iz) - &
 429                                       endwgt*(scratch(ix+ihw(iy),iy-1,iz)+scratch(ix+ihe(iy),iy+1,iz) + &
 430                                               scratch(ix+ihw(iy),iy+1,iz)+scratch(ix+ihe(iy),iy-1,iz))
 431                   end if
 432                end do
 433             end do
 434          end do
 435
 436       end do
 437
 438       deallocate(scratch)
 439
 440    end subroutine smth_desmth_egrid_old
 441
 442
 443    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 444    ! Name: smth_desmth_egrid
 445    !
 446    ! Purpose: Apply the smoother-desmoother for E grid
 447    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 448    subroutine smth_desmth_egrid(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, &
 449                                 start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval, hflag)
 450
 451       implicit none
 452
 453       ! Arguments
 454       integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z
 455       integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z
 456       integer, intent(in) :: npass
 457       real, intent(in) :: msgval, hflag
 458       real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
 459                intent(inout) :: array
 460
 461       ! Local variables
 462       integer :: ix, iy, iz, ipass
 463       real, pointer, dimension(:,:,:) :: scratch
 464       integer, dimension(start_y:end_y) :: ihe, ihw, istart
 465       real, parameter :: cenwgt = 1.52
 466       real, parameter :: endwgt = 0.26
 467
 468       allocate(scratch(start_x:end_x, start_y:end_y, start_z:end_z))
 469
 470       do iy=start_y,end_y
 471
 472          if (hflag .eq. 1.0) then
 473             ihe(iy)=abs(mod(iy+1,2))
 474             ihw(iy)=ihe(iy)-1
 475
 476          ! assign ive,ivw equivs to ihe,ihw
 477          else
 478             ihe(iy)=abs(mod(iy,2))
 479             ihw(iy)=ihe(iy)-1
 480
 481          end if
 482
 483       end do
 484
 485       do iy=start_y,end_y
 486
 487          if (hflag .eq. 1.0) then
 488             if (mod(iy,2) .eq. 0) then
 489                istart(iy)=start_x
 490             else
 491                istart(iy)=start_x+1
 492             endif
 493
 494          else ! v points
 495             if (abs(mod(iy,2)) .eq. 1) then
 496                istart(iy)=start_x
 497             else
 498                istart(iy)=start_x+1
 499             end if
 500
 501          end if
 502
 503       end do
 504
 505
 506       do ipass=1,npass
 507
 508          !
 509          ! Smoothing pass
 510          !
 511
 512          do iy=start_y,end_y
 513          do ix=start_x,end_x
 514             scratch(ix,iy,1)=array(ix,iy,1) ! for points used in 2nd computation but
 515                                             !    not defined in 1st
 516          end do
 517          end do
 518
 519          ! SW-NE direction
 520          do iy=start_y+1,end_y-1
 521             do ix=istart(iy),end_x-1
 522                do iz=start_z,end_z
 523                   if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then
 524                      scratch(ix,iy,iz) = 0.50*array(ix,iy,iz)+ &
 525                      0.25*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz))
 526                   end if
 527                end do
 528             end do
 529          end do
 530
 531          ! NW-SE direction
 532          do iy=start_y+1,end_y-1
 533             do ix=istart(iy),end_x-1
 534                do iz=start_z,end_z
 535                   if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then
 536                      array(ix,iy,iz) = 0.50*scratch(ix,iy,iz)+ &
 537                      0.25*(scratch(ix+ihe(iy),iy-1,iz)+scratch(ix+ihw(iy),iy+1,iz))
 538                   end if
 539                end do
 540             end do
 541          end do
 542
 543          call exchange_halo_r(array, &
 544                               start_x, end_x, start_y, end_y, start_z, end_z, &
 545                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
 546
 547
 548
 549          !
 550          ! Desmoothing pass
 551          !
 552
 553          ! SW-NE direction
 554          do iy=start_y+2,end_y-2
 555             do ix=istart(iy),end_x-1
 556                do iz=start_z,end_z
 557                   if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then
 558                      scratch(ix,iy,iz) = cenwgt*array(ix,iy,iz) - &
 559                        endwgt*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz))
 560                   end if
 561                end do
 562             end do
 563          end do
 564
 565          ! NW-SE direction
 566          do iy=start_y+2,end_y-2
 567             do ix=istart(iy),end_x-1
 568                do iz=start_z,end_z
 569                   if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then
 570                      array(ix,iy,iz) = cenwgt*scratch(ix,iy,iz) - &
 571                        endwgt*(scratch(ix+ihe(iy),iy-1,iz)+scratch(ix+ihw(iy),iy+1,iz))
 572                   end if
 573                end do
 574             end do
 575          end do
 576
 577          call exchange_halo_r(array, &
 578                               start_x, end_x, start_y, end_y, start_z, end_z, &
 579                               start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z)
 580
 581       end do
 582
 583       deallocate(scratch)
 584
 585    end subroutine smth_desmth_egrid
 586
 587 end module smooth_module