dyn_em/couple_or_uncouple_em.F

   1 !WRF:MEDIATION_LAYER:couple_uncouple_utility
   2
   3 SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple &
   4 !
   5 #include "dummy_new_args.inc"
   6 !
   7                  )
   8
   9
  10 !  #undef DM_PARALLEL
  11
  12 ! Driver layer modules
  13    USE module_domain, ONLY : domain, get_ijk_from_grid
  14    USE module_configure, ONLY : grid_config_rec_type
  15    USE module_driver_constants
  16    USE module_machine
  17    USE module_tiles
  18 #ifdef DM_PARALLEL
  19    USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic
  20    USE module_comm_dm, ONLY : halo_em_couple_a_sub,halo_em_couple_b_sub,period_em_couple_a_sub,period_em_couple_b_sub
  21 #else
  22    USE module_dm
  23 #endif
  24    USE module_bc
  25 ! Mediation layer modules
  26 ! Registry generated module
  27    USE module_state_description
  28
  29    IMPLICIT NONE
  30
  31    !  Subroutine interface block.
  32
  33    TYPE(domain) , TARGET         :: grid
  34
  35    !  Definitions of dummy arguments to solve
  36 #include "dummy_new_decl.inc"
  37
  38    !  WRF state bcs
  39    TYPE (grid_config_rec_type) , INTENT(IN)          :: config_flags
  40
  41    LOGICAL, INTENT(   IN) :: couple
  42
  43    ! Local data
  44
  45    INTEGER                         :: k_start , k_end
  46    INTEGER                         :: ids , ide , jds , jde , kds , kde , &
  47                                       ims , ime , jms , jme , kms , kme , &
  48                                       ips , ipe , jps , jpe , kps , kpe
  49
  50    INTEGER                         :: i,j,k, im
  51    INTEGER                         :: num_3d_c, num_3d_m, num_3d_s
  52    REAL                            :: mu_factor
  53
  54    REAL, DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: mutf_2, muth_2, muut_2, muvt_2, muwt_2
  55
  56 !  De-reference dimension information stored in the grid data structure.
  57    IF ( .NOT. grid%active_this_task ) RETURN
  58
  59    CALL get_ijk_from_grid (  grid ,                   &
  60                              ids, ide, jds, jde, kds, kde,    &
  61                              ims, ime, jms, jme, kms, kme,    &
  62                              ips, ipe, jps, jpe, kps, kpe    )
  63
  64    num_3d_m        = num_moist
  65    num_3d_c        = num_chem
  66    num_3d_s        = num_scalar
  67
  68    !  couple or uncouple mass-point variables
  69    !  first, compute mu or its reciprical as necessary
  70
  71 !   write(6,*) ' in couple '
  72 !   write(6,*) ' x,y memory ', grid%sm31,grid%em31,grid%sm33,grid%em33
  73 !   write(6,*) ' x,y patch ', ips, ipe, jps, jpe
  74
  75
  76 !   if(couple) then
  77 !      write(6,*) ' coupling variables for grid ',grid%id
  78 !      write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe
  79 !   else
  80 !      write(6,*) ' uncoupling variables for grid ',grid%id
  81 !      write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe
  82 !      write(6,*) ' x, y, size ',size(mu_2,1),size(mu_2,2)
  83 !   end if
  84
  85
  86    IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
  87      CALL set_physical_bc2d( grid%mub, 't',  &
  88                              config_flags,           &
  89                              ids,ide, jds,jde,   & ! domain dims
  90                              ims,ime, jms,jme,   & ! memory dims
  91                              ips,ipe, jps,jpe,   & ! patch  dims
  92                              ips,ipe, jps,jpe   )
  93      CALL set_physical_bc2d( grid%mu_1, 't',  &
  94                              config_flags,           &
  95                              ids,ide, jds,jde,   & ! domain dims
  96                              ims,ime, jms,jme,   & ! memory dims
  97                              ips,ipe, jps,jpe,   & ! patch  dims
  98                              ips,ipe, jps,jpe   )
  99      CALL set_physical_bc2d( grid%mu_2, 't',  &
 100                              config_flags,           &
 101                              ids,ide, jds,jde,   & ! domain dims
 102                              ims,ime, jms,jme,   & ! memory dims
 103                              ips,ipe, jps,jpe,   & ! patch  dims
 104                              ips,ipe, jps,jpe   )
 105    ENDIF
 106
 107
 108 #ifdef DM_PARALLEL
 109 # include "HALO_EM_COUPLE_A.inc"
 110 # include "PERIOD_EM_COUPLE_A.inc"
 111 #endif
 112
 113    !  computations go out one row and column to avoid having to communicate before solver
 114
 115    IF( couple ) THEN
 116
 117 !     write(6,*) ' coupling: setting mu arrays '
 118
 119      DO j = max(jds,jps),min(jde-1,jpe)
 120      DO k = kps,kpe
 121      DO i = max(ids,ips),min(ide-1,ipe)
 122        mutf_2(i,k,j) = (grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)) + (grid%c1f(k)*grid%Mu_2(i,j))
 123        muwt_2(i,k,j) = ((grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)) + (grid%c1f(k)*grid%Mu_2(i,j)))/grid%msfty(i,j) ! w coupled with y
 124      ENDDO
 125      ENDDO
 126      ENDDO
 127
 128      DO j = max(jds,jps),min(jde-1,jpe)
 129      DO k = kps,kpe-1
 130      DO i = max(ids,ips),min(ide-1,ipe)
 131        muth_2(i,k,j) = (grid%c1h(k)*grid%mub(i,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j))
 132      ENDDO
 133      ENDDO
 134      ENDDO
 135
 136 !  need boundary condition fixes for u and v ???
 137
 138 !     write(6,*) ' coupling: setting muv and muv arrays '
 139
 140      DO j = max(jds,jps),min(jde-1,jpe)
 141      DO k = kps,kpe-1
 142      DO i = max(ids,ips),min(ide-1,ipe)
 143        muut_2(i,k,j) = 0.5*((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i-1,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i-1,j)))/grid%msfuy(i,j) ! u coupled with y
 144        muvt_2(i,k,j) = 0.5*((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i,j-1)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i,j-1)))/grid%msfvx(i,j) ! v coupled with x
 145      ENDDO
 146      ENDDO
 147      ENDDO
 148
 149      IF ( config_flags%nested .or. config_flags%specified .or. config_flags%polar ) THEN
 150
 151        IF ( jpe .eq. jde ) THEN
 152          j = jde
 153          DO k = kps,kpe-1
 154          DO i = max(ids,ips),min(ide-1,ipe)
 155            muvt_2(i,k,j) = ((grid%c1h(k)*grid%mub(i,j-1)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j-1)))/grid%msfvx(i,j) ! v coupled with x
 156          ENDDO
 157          ENDDO
 158        ENDIF
 159        IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
 160          i = ide
 161          DO j = max(jds,jps),min(jde-1,jpe)
 162          DO k = kps,kpe-1
 163            muut_2(i,k,j) = ((grid%c1h(k)*grid%mub(i-1,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i-1,j)))/grid%msfuy(i,j) ! u coupled with y
 164          ENDDO
 165          ENDDO
 166        ENDIF
 167
 168      ELSE
 169
 170        IF ( jpe .eq. jde ) THEN
 171          j = jde
 172          DO k = kps,kpe-1
 173          DO i = max(ids,ips),min(ide-1,ipe)
 174            muvt_2(i,k,j) = 0.5*((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i,j-1)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i,j-1)))/grid%msfvx(i,j) ! v coupled with x
 175          ENDDO
 176          ENDDO
 177        ENDIF
 178        IF ( ipe .eq. ide ) THEN
 179          i = ide
 180          DO j = max(jds,jps),min(jde-1,jpe)
 181          DO k = kps,kpe-1
 182            muut_2(i,k,j) = 0.5*((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i-1,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i-1,j)))/grid%msfuy(i,j) ! u coupled with y
 183          ENDDO
 184          ENDDO
 185        ENDIF
 186
 187      END IF
 188
 189    ELSE
 190
 191 !     write(6,*) ' uncoupling: setting mu arrays '
 192
 193      DO j = max(jds,jps),min(jde-1,jpe)
 194      DO k = kps,kpe
 195      DO i = max(ids,ips),min(ide-1,ipe)
 196        mutf_2(i,k,j) = 1./((grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)) + (grid%c1f(k)*grid%Mu_2(i,j)))
 197        muwt_2(i,k,j) = grid%msfty(i,j)/((grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)) + (grid%c1f(k)*grid%Mu_2(i,j))) ! w coupled with y
 198      ENDDO
 199      ENDDO
 200      ENDDO
 201
 202      DO j = max(jds,jps),min(jde-1,jpe)
 203      DO k = kps,kpe-1
 204      DO i = max(ids,ips),min(ide-1,ipe)
 205        muth_2(i,k,j) = 1./((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)))
 206      ENDDO
 207      ENDDO
 208      ENDDO
 209
 210 !     write(6,*) ' uncoupling: setting muv arrays '
 211
 212      DO j = max(jds,jps),min(jde-1,jpe)
 213      DO k = kps,kpe-1
 214      DO i = max(ids,ips),min(ide-1,ipe)
 215        muut_2(i,k,j) = 2.*grid%msfuy(i,j)/((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i-1,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i-1,j))) ! u coupled with y
 216      ENDDO
 217      ENDDO
 218      ENDDO
 219
 220      DO j = max(jds,jps),min(jde-1,jpe)
 221      DO k = kps,kpe-1
 222      DO i = max(ids,ips),min(ide-1,ipe)
 223        muvt_2(i,k,j) = 2.*grid%msfvx(i,j)/((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i,j-1)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i,j-1))) ! v coupled with x
 224      ENDDO
 225      ENDDO
 226      ENDDO
 227
 228      IF ( config_flags%nested .or. config_flags%specified .or. config_flags%polar ) THEN
 229
 230        IF ( jpe .eq. jde ) THEN
 231          j = jde
 232          DO k = kps,kpe-1
 233          DO i = max(ids,ips),min(ide-1,ipe)
 234            muvt_2(i,k,j) = grid%msfvx(i,j)/((grid%c1h(k)*grid%mub(i,j-1)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j-1))) ! v coupled with x
 235          ENDDO
 236          ENDDO
 237        ENDIF
 238        IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN
 239          i = ide
 240          DO j = max(jds,jps),min(jde-1,jpe)
 241          DO k = kps,kpe-1
 242            muut_2(i,k,j) = grid%msfuy(i,j)/((grid%c1h(k)*grid%mub(i-1,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i-1,j))) ! u coupled with y
 243          ENDDO
 244          ENDDO
 245        ENDIF
 246
 247      ELSE
 248
 249        IF ( jpe .eq. jde ) THEN
 250          j = jde
 251          DO k = kps,kpe-1
 252          DO i = max(ids,ips),min(ide-1,ipe)
 253            muvt_2(i,k,j) = 2.*grid%msfvx(i,j)/((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i,j-1)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i,j-1))) ! v coupled with x
 254          ENDDO
 255          ENDDO
 256        ENDIF
 257        IF ( ipe .eq. ide ) THEN
 258          i = ide
 259          DO j = max(jds,jps),min(jde-1,jpe)
 260          DO k = kps,kpe-1
 261            muut_2(i,k,j) = 2.*grid%msfuy(i,j)/((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mub(i-1,j)+grid%c2h(k)) + (grid%c1h(k)*grid%mu_2(i,j)) + (grid%c1h(k)*grid%mu_2(i-1,j))) ! u coupled with y
 262          ENDDO
 263          ENDDO
 264        ENDIF
 265
 266      END IF
 267
 268    END IF
 269
 270    !  couple/uncouple mu point variables
 271
 272    !$OMP PARALLEL DO   &
 273    !$OMP PRIVATE ( i,j,k,im )
 274    DO j = max(jds,jps),min(jde-1,jpe)
 275
 276      DO k = kps,kpe
 277      DO i = max(ids,ips),min(ide-1,ipe)
 278        grid%ph_2(i,k,j) = grid%ph_2(i,k,j)*mutf_2(i,k,j)
 279        grid%w_2(i,k,j)  =  grid%w_2(i,k,j)*muwt_2(i,k,j)
 280      ENDDO
 281      ENDDO
 282
 283      DO k = kps,kpe-1
 284      DO i = max(ids,ips),min(ide-1,ipe)
 285        grid%t_2(i,k,j)  =  grid%t_2(i,k,j)*muth_2(i,k,j)
 286      ENDDO
 287      ENDDO
 288
 289      IF (num_3d_m >= PARAM_FIRST_SCALAR )  THEN
 290        DO im = PARAM_FIRST_SCALAR, num_3d_m
 291          DO k = kps,kpe-1
 292          DO i = max(ids,ips),min(ide-1,ipe)
 293            moist(i,k,j,im)  =  moist(i,k,j,im)*muth_2(i,k,j)
 294          ENDDO
 295          ENDDO
 296        ENDDO
 297      END IF
 298
 299      IF (num_3d_c >= PARAM_FIRST_SCALAR )  THEN
 300        DO im = PARAM_FIRST_SCALAR, num_3d_c
 301          DO k = kps,kpe-1
 302          DO i = max(ids,ips),min(ide-1,ipe)
 303            chem(i,k,j,im)  =  chem(i,k,j,im)*muth_2(i,k,j)
 304          ENDDO
 305          ENDDO
 306        ENDDO
 307      END IF
 308
 309      IF (num_3d_s >= PARAM_FIRST_SCALAR )  THEN
 310        DO im = PARAM_FIRST_SCALAR, num_3d_s
 311          DO k = kps,kpe-1
 312          DO i = max(ids,ips),min(ide-1,ipe)
 313            scalar(i,k,j,im)  =  scalar(i,k,j,im)*muth_2(i,k,j)
 314          ENDDO
 315          ENDDO
 316        ENDDO
 317      END IF
 318
 319      IF (num_tracer >= PARAM_FIRST_SCALAR )  THEN
 320        DO im = PARAM_FIRST_SCALAR, num_tracer
 321          DO k = kps,kpe-1
 322          DO i = max(ids,ips),min(ide-1,ipe)
 323            tracer(i,k,j,im)  =  tracer(i,k,j,im)*muth_2(i,k,j)
 324          ENDDO
 325          ENDDO
 326        ENDDO
 327      END IF
 328
 329 !  do u and v
 330
 331      DO k = kps,kpe-1
 332      DO i = max(ids,ips),min(ide,ipe)
 333        grid%u_2(i,k,j)  =  grid%u_2(i,k,j)*muut_2(i,k,j)
 334      ENDDO
 335      ENDDO
 336
 337    ENDDO   ! j loop
 338    !$OMP END PARALLEL DO
 339
 340    !$OMP PARALLEL DO   &
 341    !$OMP PRIVATE ( i,j,k )
 342    DO j = max(jds,jps),min(jde,jpe)
 343      DO k = kps,kpe-1
 344      DO i = max(ids,ips),min(ide-1,ipe)
 345        grid%v_2(i,k,j)  =  grid%v_2(i,k,j)*muvt_2(i,k,j)
 346      ENDDO
 347      ENDDO
 348    ENDDO
 349    !$OMP END PARALLEL DO
 350
 351    IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
 352      CALL set_physical_bc3d( grid%ph_1, 'w',        &
 353                              config_flags,                   &
 354                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 355                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 356                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 357                              ips,ipe, jps,jpe, kps,kpe )
 358      CALL set_physical_bc3d( grid%ph_2, 'w',        &
 359                              config_flags,                   &
 360                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 361                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 362                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 363                              ips,ipe, jps,jpe, kps,kpe )
 364      CALL set_physical_bc3d( grid%w_1, 'w',        &
 365                              config_flags,                   &
 366                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 367                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 368                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 369                              ips,ipe, jps,jpe, kps,kpe )
 370      CALL set_physical_bc3d( grid%w_2, 'w',        &
 371                              config_flags,                   &
 372                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 373                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 374                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 375                              ips,ipe, jps,jpe, kps,kpe )
 376      CALL set_physical_bc3d( grid%t_1, 't',        &
 377                              config_flags,                   &
 378                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 379                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 380                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 381                              ips,ipe, jps,jpe, kps,kpe )
 382      CALL set_physical_bc3d( grid%t_2, 't',        &
 383                              config_flags,                   &
 384                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 385                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 386                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 387                              ips,ipe, jps,jpe, kps,kpe )
 388      CALL set_physical_bc3d( grid%u_1, 'u',        &
 389                              config_flags,                   &
 390                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 391                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 392                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 393                              ips,ipe, jps,jpe, kps,kpe )
 394      CALL set_physical_bc3d( grid%u_2, 'u',        &
 395                              config_flags,                   &
 396                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 397                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 398                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 399                              ips,ipe, jps,jpe, kps,kpe )
 400      CALL set_physical_bc3d( grid%v_1, 'v',        &
 401                              config_flags,                   &
 402                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 403                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 404                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 405                              ips,ipe, jps,jpe, kps,kpe )
 406      CALL set_physical_bc3d( grid%v_2, 'v',        &
 407                              config_flags,                   &
 408                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 409                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 410                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 411                              ips,ipe, jps,jpe, kps,kpe )
 412
 413      IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
 414        DO im = PARAM_FIRST_SCALAR , num_3d_m
 415
 416      CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p',        &
 417                              config_flags,                   &
 418                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 419                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 420                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 421                              ips,ipe, jps,jpe, kps,kpe )
 422        ENDDO
 423      ENDIF
 424
 425
 426      IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
 427        DO im = PARAM_FIRST_SCALAR , num_3d_c
 428
 429      CALL set_physical_bc3d( chem(ims,kms,jms,im), 'p',        &
 430                              config_flags,                   &
 431                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 432                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 433                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 434                              ips,ipe, jps,jpe, kps,kpe )
 435      ENDDO
 436      ENDIF
 437
 438      IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
 439        DO im = PARAM_FIRST_SCALAR , num_3d_s
 440
 441      CALL set_physical_bc3d( scalar(ims,kms,jms,im), 'p',        &
 442                              config_flags,                   &
 443                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 444                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 445                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 446                              ips,ipe, jps,jpe, kps,kpe )
 447      ENDDO
 448      ENDIF
 449
 450      IF (num_tracer >= PARAM_FIRST_SCALAR) THEN
 451        DO im = PARAM_FIRST_SCALAR , num_tracer
 452
 453      CALL set_physical_bc3d( tracer(ims,kms,jms,im), 'p',        &
 454                              config_flags,                   &
 455                              ids,ide, jds,jde, kds,kde,  & ! domain dims
 456                              ims,ime, jms,jme, kms,kme,  & ! memory dims
 457                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
 458                              ips,ipe, jps,jpe, kps,kpe )
 459      ENDDO
 460      ENDIF
 461
 462    ENDIF
 463
 464 #ifdef DM_PARALLEL
 465 # include "HALO_EM_COUPLE_B.inc"
 466 # include "PERIOD_EM_COUPLE_B.inc"
 467 #endif
 468
 469 END SUBROUTINE couple_or_uncouple_em
 470
 471 LOGICAL FUNCTION cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
 472    IMPLICIT NONE
 473    INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
 474    LOGICAL, INTENT(IN) :: xstag, ystag
 475
 476    INTEGER ioff, joff, spec_zone
 477
 478    CALL nl_get_spec_zone( 1, spec_zone )
 479    ioff = 0 ; joff = 0
 480    IF ( xstag  ) ioff = 1
 481    IF ( ystag  ) joff = 1
 482
 483    cd_feedback_mask = ( pig .ge. ips_save+spec_zone        .and.      &
 484                            pjg .ge. jps_save+spec_zone        .and.      &
 485                            pig .le. ipe_save-spec_zone  +ioff .and.      &
 486                            pjg .le. jpe_save-spec_zone  +joff           )
 487
 488
 489 END FUNCTION cd_feedback_mask
 490