00001 subroutine MPP_UPDATE_DOMAINS_2D_( field, domain, flags )
00002 !updates data domain of 2D field whose computational domains have been computed
00003 MPP_TYPE_, intent(inout) :: field(:,:)
00004 type(domain2D), intent(in) :: domain
00005 integer, intent(in), optional :: flags
00006 MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
00007 #ifdef use_CRI_pointers
00008 pointer( ptr, field3D )
00009 ptr = LOC(field)
00010 call mpp_update_domains( field3D, domain, flags )
00011 #else
00012 field3D = RESHAPE( field, SHAPE(field3D) )
00013 call mpp_update_domains( field3D, domain, flags )
00014 field = RESHAPE( field3D, SHAPE(field) )
00015 #endif
00016 return
00017 end subroutine MPP_UPDATE_DOMAINS_2D_
00018
00019 subroutine MPP_UPDATE_DOMAINS_4D_( field, domain, flags )
00020 !updates data domain of 4D field whose computational domains have been computed
00021 MPP_TYPE_, intent(inout) :: field(:,:,:,:)
00022 type(domain2D), intent(in) :: domain
00023 integer, intent(in), optional :: flags
00024 MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
00025 #ifdef use_CRI_pointers
00026 pointer( ptr, field3D )
00027 ptr = LOC(field)
00028 call mpp_update_domains( field3D, domain, flags )
00029 #else
00030 field3D = RESHAPE( field, SHAPE(field3D) )
00031 call mpp_update_domains( field3D, domain, flags )
00032 field = RESHAPE( field3D, SHAPE(field) )
00033 #endif
00034 return
00035 end subroutine MPP_UPDATE_DOMAINS_4D_
00036
00037 subroutine MPP_UPDATE_DOMAINS_5D_( field, domain, flags )
00038 !updates data domain of 5D field whose computational domains have been computed
00039 MPP_TYPE_, intent(inout) :: field(:,:,:,:,:)
00040 type(domain2D), intent(in) :: domain
00041 integer, intent(in), optional :: flags
00042 MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
00043 #ifdef use_CRI_pointers
00044 pointer( ptr, field3D )
00045 ptr = LOC(field)
00046 call mpp_update_domains( field3D, domain, flags )
00047 #else
00048 field3D = RESHAPE( field, SHAPE(field3D) )
00049 call mpp_update_domains( field3D, domain, flags )
00050 field = RESHAPE( field3D, SHAPE(field) )
00051 #endif
00052 return
00053 end subroutine MPP_UPDATE_DOMAINS_5D_
00054
00055 subroutine MPP_UPDATE_DOMAINS_3D_( field, domain, flags )
00056 !updates data domain of 3D field whose computational domains have been computed
00057 type(domain2D), intent(in) :: domain
00058 MPP_TYPE_, intent(inout) :: field(domain%x%data%begin:,domain%y%data%begin:,:)
00059 integer, intent(in), optional :: flags
00060 integer :: update_flags
00061 !equate to mpp_domains_stack
00062 integer :: wordlen !#words of MPP_TYPE_ fit in 1 word of mpp_domains_stack
00063 MPP_TYPE_ :: buffer(size(mpp_domains_stack))
00064 #ifdef use_CRI_pointers
00065 pointer( ptr, buffer )
00066 #endif
00067 integer :: buffer_pos
00068 integer :: i, j, k, m, n
00069 integer :: is, ie, js, je, ke
00070 !receive domains saved here for unpacking
00071 !for non-blocking version, could be recomputed
00072 integer, dimension(8) :: isr, ier, jsr, jer
00073 integer :: to_pe, from_pe, list, pos, msgsize
00074 logical :: recv_e, recv_se, recv_s, recv_sw, recv_w, recv_nw, recv_n, recv_ne
00075 logical :: send_e, send_se, send_s, send_sw, send_w, send_nw, send_n, send_ne
00076 logical :: folded
00077 character(len=8) :: text
00078
00079 update_flags = XUPDATE+YUPDATE !default
00080 if( PRESENT(flags) )update_flags = flags
00081 recv_w = BTEST(update_flags,WEST)
00082 recv_e = BTEST(update_flags,EAST)
00083 recv_s = BTEST(update_flags,SOUTH)
00084 recv_n = BTEST(update_flags,NORTH)
00085 recv_ne = recv_e .AND. recv_n
00086 recv_se = recv_e .AND. recv_s
00087 recv_sw = recv_w .AND. recv_s
00088 recv_nw = recv_w .AND. recv_n
00089 send_w = recv_e
00090 send_e = recv_w
00091 send_s = recv_n
00092 send_n = recv_s
00093 send_ne = send_e .AND. send_n
00094 send_se = send_e .AND. send_s
00095 send_sw = send_w .AND. send_s
00096 send_nw = send_w .AND. send_n
00097 if( recv_w .AND. BTEST(domain%fold,WEST) .AND. BTEST(grid_offset_type,EAST) ) &
00098 call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
00099 if( recv_s .AND. BTEST(domain%fold,SOUTH) .AND. BTEST(grid_offset_type,NORTH) ) &
00100 call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
00101 if( recv_e .AND. BTEST(domain%fold,EAST) .AND. BTEST(grid_offset_type,WEST) ) &
00102 call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
00103 if( recv_n .AND. BTEST(domain%fold,NORTH) .AND. BTEST(grid_offset_type,SOUTH) ) &
00104 call mpp_error( FATAL, 'Incompatible grid offset and fold.' )
00105
00106
00107 n = size(domain%list)
00108 ke = size(field,3)
00109 buffer_pos = 0 !this initialization goes away if update_domains becomes non-blocking
00110 #ifdef use_CRI_pointers
00111 ptr = LOC(mpp_domains_stack)
00112 wordlen = size(transfer(buffer(1),mpp_domains_stack))
00113 #endif
00114 !send
00115 do list = 0,n-1
00116 m = mod( domain%pos+list, n )
00117 if( .NOT.domain%list(m)%overlap )cycle
00118 call mpp_clock_begin(pack_clock)
00119 to_pe = domain%list(m)%pe
00120 pos = buffer_pos
00121 if( send_w .AND. domain%list(m)%send_w%overlap )then
00122 is = domain%list(m)%send_w%is; ie = domain%list(m)%send_w%ie
00123 js = domain%list(m)%send_w%js; je = domain%list(m)%send_w%je
00124 if( grid_offset_type.NE.AGRID )then
00125 is = domain%list(m)%send_w_off%is; ie = domain%list(m)%send_w_off%ie
00126 js = domain%list(m)%send_w_off%js; je = domain%list(m)%send_w_off%je
00127 end if
00128 call mpp_clock_begin(pack_loop_clock)
00129 do k = 1,ke
00130 do j = js,je
00131 do i = is,ie
00132 pos = pos + 1
00133 buffer(pos) = field(i,j,k)
00134 end do
00135 end do
00136 end do
00137 call mpp_clock_end(pack_loop_clock)
00138 end if
00139 if( send_nw .AND. domain%list(m)%send_nw%overlap )then
00140 is = domain%list(m)%send_nw%is; ie = domain%list(m)%send_nw%ie
00141 js = domain%list(m)%send_nw%js; je = domain%list(m)%send_nw%je
00142 if( grid_offset_type.NE.AGRID )then
00143 is = domain%list(m)%send_nw_off%is; ie = domain%list(m)%send_nw_off%ie
00144 js = domain%list(m)%send_nw_off%js; je = domain%list(m)%send_nw_off%je
00145 end if
00146 call mpp_clock_begin(pack_loop_clock)
00147 do k = 1,ke
00148 do j = js,je
00149 do i = is,ie
00150 pos = pos + 1
00151 buffer(pos) = field(i,j,k)
00152 end do
00153 end do
00154 end do
00155 call mpp_clock_end(pack_loop_clock)
00156 end if
00157 if( send_n .AND. domain%list(m)%send_n%overlap )then
00158 is = domain%list(m)%send_n%is; ie = domain%list(m)%send_n%ie
00159 js = domain%list(m)%send_n%js; je = domain%list(m)%send_n%je
00160 if( grid_offset_type.NE.AGRID )then
00161 is = domain%list(m)%send_n_off%is; ie = domain%list(m)%send_n_off%ie
00162 js = domain%list(m)%send_n_off%js; je = domain%list(m)%send_n_off%je
00163 end if
00164 call mpp_clock_begin(pack_loop_clock)
00165 do k = 1,ke
00166 do j = js,je
00167 do i = is,ie
00168 pos = pos + 1
00169 buffer(pos) = field(i,j,k)
00170 end do
00171 end do
00172 end do
00173 call mpp_clock_end(pack_loop_clock)
00174 end if
00175 if( send_ne .AND. domain%list(m)%send_ne%overlap )then
00176 is = domain%list(m)%send_ne%is; ie = domain%list(m)%send_ne%ie
00177 js = domain%list(m)%send_ne%js; je = domain%list(m)%send_ne%je
00178 if( grid_offset_type.NE.AGRID )then
00179 is = domain%list(m)%send_ne_off%is; ie = domain%list(m)%send_ne_off%ie
00180 js = domain%list(m)%send_ne_off%js; je = domain%list(m)%send_ne_off%je
00181 end if
00182 call mpp_clock_begin(pack_loop_clock)
00183 do k = 1,ke
00184 do j = js,je
00185 do i = is,ie
00186 pos = pos + 1
00187 buffer(pos) = field(i,j,k)
00188 end do
00189 end do
00190 end do
00191 call mpp_clock_end(pack_loop_clock)
00192 end if
00193 if( send_e .AND. domain%list(m)%send_e%overlap )then
00194 is = domain%list(m)%send_e%is; ie = domain%list(m)%send_e%ie
00195 js = domain%list(m)%send_e%js; je = domain%list(m)%send_e%je
00196 if( grid_offset_type.NE.AGRID )then
00197 is = domain%list(m)%send_e_off%is; ie = domain%list(m)%send_e_off%ie
00198 js = domain%list(m)%send_e_off%js; je = domain%list(m)%send_e_off%je
00199 end if
00200 call mpp_clock_begin(pack_loop_clock)
00201 do k = 1,ke
00202 do j = js,je
00203 do i = is,ie
00204 pos = pos + 1
00205 buffer(pos) = field(i,j,k)
00206 end do
00207 end do
00208 end do
00209 call mpp_clock_end(pack_loop_clock)
00210 end if
00211 if( send_se .AND. domain%list(m)%send_se%overlap )then
00212 is = domain%list(m)%send_se%is; ie = domain%list(m)%send_se%ie
00213 js = domain%list(m)%send_se%js; je = domain%list(m)%send_se%je
00214 if( grid_offset_type.NE.AGRID )then
00215 is = domain%list(m)%send_se_off%is; ie = domain%list(m)%send_se_off%ie
00216 js = domain%list(m)%send_se_off%js; je = domain%list(m)%send_se_off%je
00217 end if
00218 call mpp_clock_begin(pack_loop_clock)
00219 do k = 1,ke
00220 do j = js,je
00221 do i = is,ie
00222 pos = pos + 1
00223 buffer(pos) = field(i,j,k)
00224 end do
00225 end do
00226 end do
00227 call mpp_clock_end(pack_loop_clock)
00228 end if
00229 if( send_s .AND. domain%list(m)%send_s%overlap )then
00230 is = domain%list(m)%send_s%is; ie = domain%list(m)%send_s%ie
00231 js = domain%list(m)%send_s%js; je = domain%list(m)%send_s%je
00232 if( grid_offset_type.NE.AGRID )then
00233 is = domain%list(m)%send_s_off%is; ie = domain%list(m)%send_s_off%ie
00234 js = domain%list(m)%send_s_off%js; je = domain%list(m)%send_s_off%je
00235 end if
00236 call mpp_clock_begin(pack_loop_clock)
00237 do k = 1,ke
00238 do j = js,je
00239 do i = is,ie
00240 pos = pos + 1
00241 buffer(pos) = field(i,j,k)
00242 end do
00243 end do
00244 end do
00245 call mpp_clock_end(pack_loop_clock)
00246 end if
00247 if( send_sw .AND. domain%list(m)%send_sw%overlap )then
00248 is = domain%list(m)%send_sw%is; ie = domain%list(m)%send_sw%ie
00249 js = domain%list(m)%send_sw%js; je = domain%list(m)%send_sw%je
00250 if( grid_offset_type.NE.AGRID )then
00251 is = domain%list(m)%send_sw_off%is; ie = domain%list(m)%send_sw_off%ie
00252 js = domain%list(m)%send_sw_off%js; je = domain%list(m)%send_sw_off%je
00253 end if
00254 call mpp_clock_begin(pack_loop_clock)
00255 do k = 1,ke
00256 do j = js,je
00257 do i = is,ie
00258 pos = pos + 1
00259 buffer(pos) = field(i,j,k)
00260 end do
00261 end do
00262 end do
00263 call mpp_clock_end(pack_loop_clock)
00264 end if
00265 call mpp_clock_end(pack_clock)
00266 call mpp_clock_begin(send_clock)
00267 msgsize = pos - buffer_pos
00268 print *,'msgsize ',msgsize
00269 if( msgsize.GT.0 )then
00270 print *,'mpp_domains_stack_hwm ',mpp_domains_stack_hwm
00271 print *,'pos*wordlen ',pos*wordlen
00272 print *,'max ',max( mpp_domains_stack_hwm, pos*wordlen )
00273 print *,'mpp_domains_stack_size ',mpp_domains_stack_size
00274 mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos*wordlen )
00275 if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
00276 write( text,'(i8)' )mpp_domains_stack_hwm
00277 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: mpp_domains1_stack overflow, call mpp_domains_set_stack_size(' &
00278
00279 end if
00280 call mpp_send( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, to_pe )
00281 buffer_pos = pos
00282 end if
00283 call mpp_clock_end(send_clock)
00284 end do
00285
00286 !recv
00287 do list = 0,n-1
00288 m = mod( domain%pos+n-list, n )
00289 if( .NOT.domain%list(m)%overlap )cycle
00290 call mpp_clock_begin(recv_clock)
00291 from_pe = domain%list(m)%pe
00292 msgsize = 0
00293 if( recv_e .AND. domain%list(m)%recv_e%overlap )then
00294 is = domain%list(m)%recv_e%is; ie = domain%list(m)%recv_e%ie
00295 js = domain%list(m)%recv_e%js; je = domain%list(m)%recv_e%je
00296 if( grid_offset_type.NE.AGRID )then
00297 is = domain%list(m)%recv_e_off%is; ie = domain%list(m)%recv_e_off%ie
00298 js = domain%list(m)%recv_e_off%js; je = domain%list(m)%recv_e_off%je
00299 end if
00300 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00301 end if
00302 if( recv_se .AND. domain%list(m)%recv_se%overlap )then
00303 is = domain%list(m)%recv_se%is; ie = domain%list(m)%recv_se%ie
00304 js = domain%list(m)%recv_se%js; je = domain%list(m)%recv_se%je
00305 if( grid_offset_type.NE.AGRID )then
00306 is = domain%list(m)%recv_se_off%is; ie = domain%list(m)%recv_se_off%ie
00307 js = domain%list(m)%recv_se_off%js; je = domain%list(m)%recv_se_off%je
00308 end if
00309 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00310 end if
00311 if( recv_s .AND. domain%list(m)%recv_s%overlap )then
00312 is = domain%list(m)%recv_s%is; ie = domain%list(m)%recv_s%ie
00313 js = domain%list(m)%recv_s%js; je = domain%list(m)%recv_s%je
00314 if( grid_offset_type.NE.AGRID )then
00315 is = domain%list(m)%recv_s_off%is; ie = domain%list(m)%recv_s_off%ie
00316 js = domain%list(m)%recv_s_off%js; je = domain%list(m)%recv_s_off%je
00317 end if
00318 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00319 end if
00320 if( recv_sw .AND. domain%list(m)%recv_sw%overlap )then
00321 is = domain%list(m)%recv_sw%is; ie = domain%list(m)%recv_sw%ie
00322 js = domain%list(m)%recv_sw%js; je = domain%list(m)%recv_sw%je
00323 if( grid_offset_type.NE.AGRID )then
00324 is = domain%list(m)%recv_sw_off%is; ie = domain%list(m)%recv_sw_off%ie
00325 js = domain%list(m)%recv_sw_off%js; je = domain%list(m)%recv_sw_off%je
00326 end if
00327 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00328 end if
00329 if( recv_w .AND. domain%list(m)%recv_w%overlap )then
00330 is = domain%list(m)%recv_w%is; ie = domain%list(m)%recv_w%ie
00331 js = domain%list(m)%recv_w%js; je = domain%list(m)%recv_w%je
00332 if( grid_offset_type.NE.AGRID )then
00333 is = domain%list(m)%recv_w_off%is; ie = domain%list(m)%recv_w_off%ie
00334 js = domain%list(m)%recv_w_off%js; je = domain%list(m)%recv_w_off%je
00335 end if
00336 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00337 end if
00338 if( recv_nw .AND. domain%list(m)%recv_nw%overlap )then
00339 is = domain%list(m)%recv_nw%is; ie = domain%list(m)%recv_nw%ie
00340 js = domain%list(m)%recv_nw%js; je = domain%list(m)%recv_nw%je
00341 if( grid_offset_type.NE.AGRID )then
00342 is = domain%list(m)%recv_nw_off%is; ie = domain%list(m)%recv_nw_off%ie
00343 js = domain%list(m)%recv_nw_off%js; je = domain%list(m)%recv_nw_off%je
00344 end if
00345 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00346 end if
00347 if( recv_n .AND. domain%list(m)%recv_n%overlap )then
00348 is = domain%list(m)%recv_n%is; ie = domain%list(m)%recv_n%ie
00349 js = domain%list(m)%recv_n%js; je = domain%list(m)%recv_n%je
00350 if( grid_offset_type.NE.AGRID )then
00351 is = domain%list(m)%recv_n_off%is; ie = domain%list(m)%recv_n_off%ie
00352 js = domain%list(m)%recv_n_off%js; je = domain%list(m)%recv_n_off%je
00353 end if
00354 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00355 end if
00356 if( recv_ne .AND. domain%list(m)%recv_ne%overlap )then
00357 is = domain%list(m)%recv_ne%is; ie = domain%list(m)%recv_ne%ie
00358 js = domain%list(m)%recv_ne%js; je = domain%list(m)%recv_ne%je
00359 if( grid_offset_type.NE.AGRID )then
00360 is = domain%list(m)%recv_ne_off%is; ie = domain%list(m)%recv_ne_off%ie
00361 js = domain%list(m)%recv_ne_off%js; je = domain%list(m)%recv_ne_off%je
00362 end if
00363 msgsize = msgsize + (ie-is+1)*(je-js+1)*ke
00364 end if
00365 if( msgsize.GT.0 )then
00366 print *,'mpp_domains_stack_hwm ',mpp_domains_stack_hwm
00367 print *,'buffer_pos+msgsize)*wordlen ',(buffer_pos+msgsize)*wordlen
00368 print *,'max ',max( mpp_domains_stack_hwm, pos*wordlen )
00369 print *,'mpp_domains_stack_size ',mpp_domains_stack_size
00370 mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
00371 if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
00372 write( text,'(i8)' )mpp_domains_stack_hwm
00373 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: mpp_domains2_stack overflow, call mpp_domains_set_stack_size(' &
00374
00375 end if
00376 call mpp_recv( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, from_pe )
00377 buffer_pos = buffer_pos + msgsize
00378 end if
00379 call mpp_clock_end(recv_clock)
00380 end do
00381
00382 !unpack recv
00383 !unpack halos in reverse order
00384 do list = n-1,0,-1
00385 m = mod( domain%pos+n-list, n )
00386 if( .NOT.domain%list(m)%overlap )cycle
00387 call mpp_clock_begin(unpk_clock)
00388 from_pe = domain%list(m)%pe
00389 pos = buffer_pos
00390 if( recv_ne .AND. domain%list(m)%recv_ne%overlap )then
00391 is = domain%list(m)%recv_ne%is; ie = domain%list(m)%recv_ne%ie
00392 js = domain%list(m)%recv_ne%js; je = domain%list(m)%recv_ne%je
00393 if( grid_offset_type.NE.AGRID )then
00394 is = domain%list(m)%recv_ne_off%is; ie = domain%list(m)%recv_ne_off%ie
00395 js = domain%list(m)%recv_ne_off%js; je = domain%list(m)%recv_ne_off%je
00396 end if
00397 msgsize = (ie-is+1)*(je-js+1)*ke
00398 pos = buffer_pos - msgsize
00399 buffer_pos = pos
00400 if( domain%list(m)%recv_ne%folded )then
00401 do k = 1,ke
00402 do j = je,js,-1
00403 do i = ie,is,-1
00404 pos = pos + 1
00405 field(i,j,k) = buffer(pos)
00406 end do
00407 end do
00408 end do
00409 else
00410 do k = 1,ke
00411 do j = js,je
00412 do i = is,ie
00413 pos = pos + 1
00414 field(i,j,k) = buffer(pos)
00415 end do
00416 end do
00417 end do
00418 end if
00419 end if
00420 if( recv_n .AND. domain%list(m)%recv_n%overlap )then
00421 is = domain%list(m)%recv_n%is; ie = domain%list(m)%recv_n%ie
00422 js = domain%list(m)%recv_n%js; je = domain%list(m)%recv_n%je
00423 if( grid_offset_type.NE.AGRID )then
00424 is = domain%list(m)%recv_n_off%is; ie = domain%list(m)%recv_n_off%ie
00425 js = domain%list(m)%recv_n_off%js; je = domain%list(m)%recv_n_off%je
00426 end if
00427 msgsize = (ie-is+1)*(je-js+1)*ke
00428 pos = buffer_pos - msgsize
00429 buffer_pos = pos
00430 if( domain%list(m)%recv_n%folded )then
00431 do k = 1,ke
00432 do j = je,js,-1
00433 do i = ie,is,-1
00434 pos = pos + 1
00435 field(i,j,k) = buffer(pos)
00436 end do
00437 end do
00438 end do
00439 else
00440 do k = 1,ke
00441 do j = js,je
00442 do i = is,ie
00443 pos = pos + 1
00444 field(i,j,k) = buffer(pos)
00445 end do
00446 end do
00447 end do
00448 end if
00449 end if
00450 if( recv_nw .AND. domain%list(m)%recv_nw%overlap )then
00451 is = domain%list(m)%recv_nw%is; ie = domain%list(m)%recv_nw%ie
00452 js = domain%list(m)%recv_nw%js; je = domain%list(m)%recv_nw%je
00453 if( grid_offset_type.NE.AGRID )then
00454 is = domain%list(m)%recv_nw_off%is; ie = domain%list(m)%recv_nw_off%ie
00455 js = domain%list(m)%recv_nw_off%js; je = domain%list(m)%recv_nw_off%je
00456 end if
00457 msgsize = (ie-is+1)*(je-js+1)*ke
00458 pos = buffer_pos - msgsize
00459 buffer_pos = pos
00460 if( domain%list(m)%recv_nw%folded )then
00461 do k = 1,ke
00462 do j = je,js,-1
00463 do i = ie,is,-1
00464 pos = pos + 1
00465 field(i,j,k) = buffer(pos)
00466 end do
00467 end do
00468 end do
00469 else
00470 do k = 1,ke
00471 do j = js,je
00472 do i = is,ie
00473 pos = pos + 1
00474 field(i,j,k) = buffer(pos)
00475 end do
00476 end do
00477 end do
00478 end if
00479 end if
00480 if( recv_w .AND. domain%list(m)%recv_w%overlap )then
00481 is = domain%list(m)%recv_w%is; ie = domain%list(m)%recv_w%ie
00482 js = domain%list(m)%recv_w%js; je = domain%list(m)%recv_w%je
00483 if( grid_offset_type.NE.AGRID )then
00484 is = domain%list(m)%recv_w_off%is; ie = domain%list(m)%recv_w_off%ie
00485 js = domain%list(m)%recv_w_off%js; je = domain%list(m)%recv_w_off%je
00486 end if
00487 msgsize = (ie-is+1)*(je-js+1)*ke
00488 pos = buffer_pos - msgsize
00489 buffer_pos = pos
00490 if( domain%list(m)%recv_w%folded )then
00491 do k = 1,ke
00492 do j = je,js,-1
00493 do i = ie,is,-1
00494 pos = pos + 1
00495 field(i,j,k) = buffer(pos)
00496 end do
00497 end do
00498 end do
00499 else
00500 do k = 1,ke
00501 do j = js,je
00502 do i = is,ie
00503 pos = pos + 1
00504 field(i,j,k) = buffer(pos)
00505 end do
00506 end do
00507 end do
00508 end if
00509 end if
00510 if( recv_sw .AND. domain%list(m)%recv_sw%overlap )then
00511 is = domain%list(m)%recv_sw%is; ie = domain%list(m)%recv_sw%ie
00512 js = domain%list(m)%recv_sw%js; je = domain%list(m)%recv_sw%je
00513 if( grid_offset_type.NE.AGRID )then
00514 is = domain%list(m)%recv_sw_off%is; ie = domain%list(m)%recv_sw_off%ie
00515 js = domain%list(m)%recv_sw_off%js; je = domain%list(m)%recv_sw_off%je
00516 end if
00517 msgsize = (ie-is+1)*(je-js+1)*ke
00518 pos = buffer_pos - msgsize
00519 buffer_pos = pos
00520 if( domain%list(m)%recv_sw%folded )then
00521 do k = 1,ke
00522 do j = je,js,-1
00523 do i = ie,is,-1
00524 pos = pos + 1
00525 field(i,j,k) = buffer(pos)
00526 end do
00527 end do
00528 end do
00529 else
00530 do k = 1,ke
00531 do j = js,je
00532 do i = is,ie
00533 pos = pos + 1
00534 field(i,j,k) = buffer(pos)
00535 end do
00536 end do
00537 end do
00538 end if
00539 end if
00540 if( recv_s .AND. domain%list(m)%recv_s%overlap )then
00541 is = domain%list(m)%recv_s%is; ie = domain%list(m)%recv_s%ie
00542 js = domain%list(m)%recv_s%js; je = domain%list(m)%recv_s%je
00543 if( grid_offset_type.NE.AGRID )then
00544 is = domain%list(m)%recv_s_off%is; ie = domain%list(m)%recv_s_off%ie
00545 js = domain%list(m)%recv_s_off%js; je = domain%list(m)%recv_s_off%je
00546 end if
00547 msgsize = (ie-is+1)*(je-js+1)*ke
00548 pos = buffer_pos - msgsize
00549 buffer_pos = pos
00550 if( domain%list(m)%recv_s%folded )then
00551 do k = 1,ke
00552 do j = je,js,-1
00553 do i = ie,is,-1
00554 pos = pos + 1
00555 field(i,j,k) = buffer(pos)
00556 end do
00557 end do
00558 end do
00559 else
00560 do k = 1,ke
00561 do j = js,je
00562 do i = is,ie
00563 pos = pos + 1
00564 field(i,j,k) = buffer(pos)
00565 end do
00566 end do
00567 end do
00568 end if
00569 end if
00570 if( recv_se .AND. domain%list(m)%recv_se%overlap )then
00571 is = domain%list(m)%recv_se%is; ie = domain%list(m)%recv_se%ie
00572 js = domain%list(m)%recv_se%js; je = domain%list(m)%recv_se%je
00573 if( grid_offset_type.NE.AGRID )then
00574 is = domain%list(m)%recv_se_off%is; ie = domain%list(m)%recv_se_off%ie
00575 js = domain%list(m)%recv_se_off%js; je = domain%list(m)%recv_se_off%je
00576 end if
00577 msgsize = (ie-is+1)*(je-js+1)*ke
00578 pos = buffer_pos - msgsize
00579 buffer_pos = pos
00580 if( domain%list(m)%recv_se%folded )then
00581 do k = 1,ke
00582 do j = je,js,-1
00583 do i = ie,is,-1
00584 pos = pos + 1
00585 field(i,j,k) = buffer(pos)
00586 end do
00587 end do
00588 end do
00589 else
00590 do k = 1,ke
00591 do j = js,je
00592 do i = is,ie
00593 pos = pos + 1
00594 field(i,j,k) = buffer(pos)
00595 end do
00596 end do
00597 end do
00598 end if
00599 end if
00600 if( recv_e .AND. domain%list(m)%recv_e%overlap )then
00601 is = domain%list(m)%recv_e%is; ie = domain%list(m)%recv_e%ie
00602 js = domain%list(m)%recv_e%js; je = domain%list(m)%recv_e%je
00603 if( grid_offset_type.NE.AGRID )then
00604 is = domain%list(m)%recv_e_off%is; ie = domain%list(m)%recv_e_off%ie
00605 js = domain%list(m)%recv_e_off%js; je = domain%list(m)%recv_e_off%je
00606 end if
00607 msgsize = (ie-is+1)*(je-js+1)*ke
00608 pos = buffer_pos - msgsize
00609 buffer_pos = pos
00610 if( domain%list(m)%recv_e%folded )then
00611 do k = 1,ke
00612 do j = je,js,-1
00613 do i = ie,is,-1
00614 pos = pos + 1
00615 field(i,j,k) = buffer(pos)
00616 end do
00617 end do
00618 end do
00619 else
00620 do k = 1,ke
00621 do j = js,je
00622 do i = is,ie
00623 pos = pos + 1
00624 field(i,j,k) = buffer(pos)
00625 end do
00626 end do
00627 end do
00628 end if
00629 end if
00630 call mpp_clock_end(unpk_clock)
00631 end do
00632
00633 call mpp_clock_begin(wait_clock)
00634 call mpp_sync_self( domain%list(:)%pe )
00635 call mpp_clock_end(wait_clock)
00636 return
00637 end subroutine MPP_UPDATE_DOMAINS_3D_
00638
00639 subroutine MPP_REDISTRIBUTE_2D_( domain_in, field_in, domain_out, field_out )
00640 type(domain2D), intent(in) :: domain_in, domain_out
00641 MPP_TYPE_, intent(in) :: field_in (:,:)
00642 MPP_TYPE_, intent(out) :: field_out(:,:)
00643 MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),1)
00644 MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),1)
00645 #ifdef use_CRI_pointers
00646 pointer( ptr_in, field3D_in )
00647 pointer( ptr_out, field3D_out )
00648 ptr_in = LOC(field_in )
00649 ptr_out = LOC(field_out)
00650 call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
00651 #else
00652 field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
00653 call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
00654 field_out = RESHAPE( field3D_out, SHAPE(field_out) )
00655 #endif
00656 return
00657 end subroutine MPP_REDISTRIBUTE_2D_
00658
00659 subroutine MPP_REDISTRIBUTE_3D_( domain_in, field_in, domain_out, field_out )
00660 type(domain2D), intent(in) :: domain_in, domain_out
00661 ! MPP_TYPE_, intent(in) :: field_in ( domain_in%x%data%begin:, domain_in%y%data%begin:,:)
00662 ! MPP_TYPE_, intent(out) :: field_out(domain_out%x%data%begin:,domain_out%y%data%begin:,:)
00663 MPP_TYPE_, intent(in) :: field_in (:,:,:)
00664 MPP_TYPE_, intent(out) :: field_out(:,:,:)
00665 integer :: is, ie, js, je, ke, isc, iec, jsc, jec
00666 integer :: i, j, k
00667 integer :: list, m, n, pos, msgsize
00668 integer :: to_pe, from_pe
00669 ! MPP_TYPE_, dimension(domain_in%x%compute%size*domain_in%y%compute%size*size(field_in,3)) :: send_buf, recv_buf
00670 MPP_TYPE_ :: buffer(size(mpp_domains_stack))
00671 #ifdef use_CRI_pointers
00672 pointer( ptr, buffer )
00673 #endif
00674 integer :: buffer_pos, wordlen
00675 character(len=8) :: text
00676
00677 ! ke = size(field_in,3)
00678 ! if( ke.NE.size(field_out,3) )call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mismatch between field_in and field_out.' )
00679 ! if( UBOUND(field_in,1).NE.domain_in%x%data%end .OR. &
00680 ! UBOUND(field_in,2).NE.domain_in%y%data%end ) &
00681 ! call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_in must be on data domain of domain_in.' )
00682 ! if( UBOUND(field_out,1).NE.domain_out%x%data%end .OR. &
00683 ! UBOUND(field_out,2).NE.domain_out%y%data%end ) &
00684 ! call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_out must be on data domain of domain_out.' )
00685
00686 !fix ke
00687 ke = 0
00688 if( domain_in%pe.NE.NULL_PE )ke = size(field_in,3)
00689 if( domain_out%pe.NE.NULL_PE )then
00690 if( ke.NE.0 .AND. ke.NE.size(field_out,3) ) &
00691 call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mismatch between field_in and field_out.' )
00692 ke = size(field_out,3)
00693 end if
00694 if( ke.EQ.0 )call mpp_error( FATAL, 'MPP_REDISTRIBUTE: either domain_in or domain_out must be native.' )
00695 !check sizes
00696 if( domain_in%pe.NE.NULL_PE )then
00697 if( size(field_in,1).NE.domain_in%x%data%size .OR. size(field_in,2).NE.domain_in%y%data%size ) &
00698 call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_in must be on data domain of domain_in.' )
00699 end if
00700 if( domain_out%pe.NE.NULL_PE )then
00701 if( size(field_out,1).NE.domain_out%x%data%size .OR. size(field_out,2).NE.domain_out%y%data%size ) &
00702 call mpp_error( FATAL, 'MPP_REDISTRIBUTE: field_out must be on data domain of domain_out.' )
00703 end if
00704
00705 buffer_pos = 0
00706 #ifdef use_CRI_pointers
00707 ptr = LOC(mpp_domains_stack)
00708 wordlen = size(TRANSFER(buffer(1),mpp_domains_stack))
00709 #endif
00710 !send
00711 call mpp_get_compute_domain( domain_in, isc, iec, jsc, jec )
00712 n = size(domain_out%list)
00713 do list = 0,n-1
00714 m = mod( domain_out%pos+list+n, n )
00715 to_pe = domain_out%list(m)%pe
00716 call mpp_get_compute_domain( domain_out%list(m), is, ie, js, je )
00717 is = max(is,isc); ie = min(ie,iec)
00718 js = max(js,jsc); je = min(je,jec)
00719 if( ie.GE.is .AND. je.GE.js )then
00720 msgsize = (ie-is+1)*(je-js+1)*ke
00721 mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
00722 if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
00723 write( text,'(i8)' )mpp_domains_stack_hwm
00724 call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
00725
00726 end if
00727 pos = buffer_pos
00728 do k = 1,ke
00729 do j = js-domain_in%y%data%begin+1,je-domain_in%y%data%begin+1
00730 do i = is-domain_in%x%data%begin+1,ie-domain_in%x%data%begin+1
00731 pos = pos+1
00732 buffer(pos) = field_in(i,j,k)
00733 end do
00734 end do
00735 end do
00736 if( debug )write( stderr(),* )'PE', pe, ' to PE ', to_pe, 'is,ie,js,je=', is, ie, js, je
00737 call mpp_send( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, to_pe )
00738 buffer_pos = pos
00739 end if
00740 end do
00741 !recv
00742 call mpp_get_compute_domain( domain_out, isc, iec, jsc, jec )
00743 n = size(domain_in%list)
00744 do list = 0,n-1
00745 m = mod( domain_in%pos+n-list, n )
00746 from_pe = domain_in%list(m)%pe
00747 call mpp_get_compute_domain( domain_in%list(m), is, ie, js, je )
00748 is = max(is,isc); ie = min(ie,iec)
00749 js = max(js,jsc); je = min(je,jec)
00750 if( ie.GE.is .AND. je.GE.js )then
00751 msgsize = (ie-is+1)*(je-js+1)*ke
00752 mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
00753 if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
00754 write( text,'(i8)' )mpp_domains_stack_hwm
00755 call mpp_error( FATAL, 'MPP_REDISTRIBUTE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
00756
00757 end if
00758 if( debug )write( stderr(),* )'PE', pe, ' from PE ', from_pe, 'is,ie,js,je=', is, ie, js, je
00759 call mpp_recv( buffer(buffer_pos+1:buffer_pos+msgsize), msgsize, from_pe )
00760 pos = buffer_pos
00761 do k = 1,ke
00762 do j = js-domain_out%y%data%begin+1,je-domain_out%y%data%begin+1
00763 do i = is-domain_out%x%data%begin+1,ie-domain_out%x%data%begin+1
00764 pos = pos+1
00765 field_out(i,j,k) = buffer(pos)
00766 end do
00767 end do
00768 end do
00769 buffer_pos = pos
00770 end if
00771 end do
00772
00773 ! call mpp_sync_self( domain_in%list(:)%pe )
00774 call mpp_sync_self()
00775 return
00776 end subroutine MPP_REDISTRIBUTE_3D_
00777
00778 subroutine MPP_REDISTRIBUTE_4D_( domain_in, field_in, domain_out, field_out )
00779 type(domain2D), intent(in) :: domain_in, domain_out
00780 MPP_TYPE_, intent(in) :: field_in (:,:,:,:)
00781 MPP_TYPE_, intent(out) :: field_out(:,:,:,:)
00782 MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),size(field_in ,3)*size(field_in ,4))
00783 MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),size(field_out,3)*size(field_out,4))
00784 #ifdef use_CRI_pointers
00785 pointer( ptr_in, field3D_in )
00786 pointer( ptr_out, field3D_out )
00787 ptr_in = LOC(field_in )
00788 ptr_out = LOC(field_out)
00789 call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
00790 #else
00791 field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
00792 call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
00793 field_out = RESHAPE( field3D_out, SHAPE(field_out) )
00794 #endif
00795 return
00796 end subroutine MPP_REDISTRIBUTE_4D_
00797
00798 subroutine MPP_REDISTRIBUTE_5D_( domain_in, field_in, domain_out, field_out )
00799 type(domain2D), intent(in) :: domain_in, domain_out
00800 MPP_TYPE_, intent(in) :: field_in (:,:,:,:,:)
00801 MPP_TYPE_, intent(out) :: field_out(:,:,:,:,:)
00802 MPP_TYPE_ :: field3D_in (size(field_in, 1),size(field_in, 2),&
00803 size(field_in ,3)*size(field_in ,4)*size(field_in ,5))
00804 MPP_TYPE_ :: field3D_out(size(field_out,1),size(field_out,2),&
00805 size(field_out,3)*size(field_out,4)*size(field_out,5))
00806 #ifdef use_CRI_pointers
00807 pointer( ptr_in, field3D_in )
00808 pointer( ptr_out, field3D_out )
00809 ptr_in = LOC(field_in )
00810 ptr_out = LOC(field_out)
00811 call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
00812 #else
00813 field3D_in = RESHAPE( field_in, SHAPE(field3D_in) )
00814 call mpp_redistribute( domain_in, field3D_in, domain_out, field3D_out )
00815 field_out = RESHAPE( field3D_out, SHAPE(field_out) )
00816 #endif
00817 return
00818 end subroutine MPP_REDISTRIBUTE_5D_
00819 #ifdef VECTOR_FIELD_
00820 !VECTOR_FIELD_ is set to false for MPP_TYPE_ integer or logical.
00821 !vector fields
00822 subroutine MPP_UPDATE_DOMAINS_2D_V_( fieldx, fieldy, domain, flags, gridtype )
00823 !updates data domain of 2D field whose computational domains have been computed
00824 MPP_TYPE_, intent(inout), dimension(:,:) :: fieldx, fieldy
00825 type(domain2D), intent(inout) :: domain
00826 integer, intent(in), optional :: flags, gridtype
00827 MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1)
00828 MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1)
00829 #ifdef use_CRI_pointers
00830 pointer( ptrx, field3Dx )
00831 pointer( ptry, field3Dy )
00832 ptrx = LOC(fieldx)
00833 ptry = LOC(fieldy)
00834 call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
00835 #else
00836 field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
00837 field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
00838 call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
00839 fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
00840 fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
00841 #endif
00842 return
00843 end subroutine MPP_UPDATE_DOMAINS_2D_V_
00844
00845 subroutine MPP_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype )
00846 !updates data domain of 3D field whose computational domains have been computed
00847 type(domain2D), intent(inout) :: domain
00848 MPP_TYPE_, intent(inout), dimension(domain%x%data%begin:,domain%y%data%begin:,:) :: fieldx, fieldy
00849 integer, intent(in), optional :: flags, gridtype
00850 integer :: update_flags
00851 integer :: i,j,k,n, is, ie, js, je, ke, pos
00852 integer :: ioff, joff
00853 MPP_TYPE_ :: buffer(size(mpp_domains_stack))
00854 #ifdef use_CRI_pointers
00855 pointer( ptr, buffer )
00856 MPP_TYPE_ :: field(size(fieldx,1),size(fieldx,2),2*size(fieldx,3))
00857 pointer( ptrf, field )
00858 #endif
00859 integer :: buffer_pos, msgsize, wordlen
00860 character(len=8) :: text
00861
00862 !gridtype
00863 grid_offset_type = AGRID
00864 if( PRESENT(gridtype) )then
00865 if( gridtype.NE.AGRID .AND. &
00866 gridtype.NE.BGRID_NE .AND. gridtype.NE.BGRID_SW .AND. &
00867 gridtype.NE.CGRID_NE .AND. gridtype.NE.CGRID_SW ) &
00868 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: gridtype must be one of AGRID|BGRID_NE|BGRID_SW|CGRID_NE|CGRID_SW.' )
00869 !grid_offset_type used by update domains to determine shifts.
00870 grid_offset_type = gridtype
00871 call compute_overlaps(domain)
00872 if( grid_offset_type.NE.domain%gridtype ) &
00873 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS: gridtype cannot be changed during run.' )
00874 end if
00875 !need to add code for EWS boundaries
00876 if( BTEST(domain%fold,WEST) .AND. BTEST(update_flags,WEST) ) &
00877 call mpp_error( FATAL, 'velocity stencil not yet active for WEST fold, contact author.' )
00878 if( BTEST(domain%fold,EAST) .AND. BTEST(update_flags,EAST) ) &
00879 call mpp_error( FATAL, 'velocity stencil not yet active for EAST fold, contact author.' )
00880 if( BTEST(domain%fold,SOUTH) .AND. BTEST(update_flags,SOUTH) ) &
00881 call mpp_error( FATAL, 'velocity stencil not yet active for SOUTH fold, contact author.' )
00882
00883 #ifdef use_CRI_pointers
00884 !optimization for BGRID when fieldx and fieldy are contiguous
00885 ptrf = LOC(fieldx)
00886 if( LOC(field(1,1,size(fieldx,3)+1)).EQ.LOC(fieldy) .AND. &
00887 ( domain%gridtype.EQ.BGRID_NE .OR. domain%gridtype.EQ.BGRID_SW ) )then
00888 call mpp_update_domains( field, domain, flags )
00889 else
00890 call mpp_update_domains( fieldx, domain, flags )
00891 call mpp_update_domains( fieldy, domain, flags )
00892 end if
00893 #else
00894 call mpp_update_domains( fieldx, domain, flags )
00895 call mpp_update_domains( fieldy, domain, flags )
00896 #endif
00897
00898 #ifdef use_CRI_pointers
00899 ptr = LOC(mpp_domains_stack)
00900 #endif
00901 wordlen = size(TRANSFER(buffer(1),mpp_domains_stack))
00902 buffer_pos = 0
00903 !for all gridtypes
00904 update_flags = XUPDATE+YUPDATE !default
00905 if( PRESENT(flags) )update_flags = flags
00906 ke = size(fieldx,3)
00907 call mpp_get_global_domain( domain, xsize=ioff, ysize=joff )
00908 !northern boundary fold
00909 if( BTEST(domain%fold,NORTH) .AND. BTEST(update_flags,NORTH) )then
00910 js = domain%y%global%end + 1
00911 je = domain%y%data%end
00912 if( je.GE.js )then
00913 !on offset grids, we need to move data leftward by one point
00914 pos = domain%x%pos - 1 !the one on your left
00915 if( pos.GE.0 )then
00916 is = domain%x%list(pos)%data%end+1; ie=is
00917 else if( domain%x%cyclic )then
00918 pos = pos + size(domain%x%list)
00919 is = domain%x%list(pos)%data%end+1 - ioff; ie=is
00920 else
00921 is=1; ie=0
00922 end if
00923 n = buffer_pos
00924 if( ie.EQ.is )then
00925 msgsize = (je-js+1)*ke*2 !only half this on CGRID actually
00926 mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize)*wordlen )
00927 if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
00928 write( text,'(i8)' )mpp_domains_stack_hwm
00929 call mpp_error( FATAL, 'MPP_UPDATE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
00930
00931 end if
00932 select case(grid_offset_type)
00933 case(BGRID_NE)
00934 do k = 1,ke
00935 do j = js,je
00936 n = n + 2
00937 buffer(n-1) = fieldx(is,j,k)
00938 buffer(n ) = fieldy(is,j,k)
00939 end do
00940 end do
00941 call mpp_send( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
00942 buffer_pos = buffer_pos + n
00943 case(CGRID_NE)
00944 do k = 1,ke
00945 do j = js,je
00946 n = n + 1
00947 buffer(n) = fieldx(is,j,k)
00948 end do
00949 end do
00950 call mpp_send( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
00951 buffer_pos = buffer_pos + n
00952 end select
00953 !receive data at x%data%end
00954 pos = domain%x%pos + 1 !the one on your right
00955 if( pos.LT.size(domain%x%list) )then
00956 n = (je-js+1)*ke
00957 else if( domain%x%cyclic )then
00958 pos = pos - size(domain%x%list)
00959 n = (je-js+1)*ke
00960 else
00961 n = 0
00962 end if
00963 if( n.GT.0 )then
00964 mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+n)*wordlen )
00965 if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
00966 write( text,'(i8)' )mpp_domains_stack_hwm
00967 call mpp_error( FATAL, 'MPP_UPDATE: mpp_domains_stack overflow, call mpp_domains_set_stack_size(' &
00968
00969 end if
00970 select case(grid_offset_type)
00971 case(BGRID_NE)
00972 do k = 1,ke
00973 do j = js,je
00974 do i = domain%x%data%begin,domain%x%data%end-1
00975 fieldx(i,j,k) = fieldx(i+1,j,k)
00976 fieldy(i,j,k) = fieldy(i+1,j,k)
00977 end do
00978 end do
00979 end do
00980 n = n*2
00981 call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
00982 i = domain%x%data%end
00983 n = buffer_pos
00984 do k = 1,ke
00985 do j = js,je
00986 n = n + 2
00987 fieldx(i,j,k) = buffer(n-1)
00988 fieldy(i,j,k) = buffer(n )
00989 end do
00990 end do
00991 case(CGRID_NE)
00992 do k = 1,ke
00993 do j = js,je
00994 do i = domain%x%data%begin,domain%x%data%end-1
00995 fieldx(i,j,k) = fieldx(i+1,j,k)
00996 fieldy(i,j,k) = fieldy(i+1,j,k)
00997 end do
00998 end do
00999 end do
01000 call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
01001 i = domain%x%data%end
01002 n = buffer_pos
01003 do k = 1,ke
01004 do j = js,je
01005 n = n + 1
01006 fieldx(i,j,k) = buffer(n)
01007 end do
01008 end do
01009 end select
01010 end if
01011 end if
01012 !flip the sign
01013 is = domain%x%data%begin
01014 ie = domain%x%data%end
01015 do k = 1,ke
01016 do j = js,je
01017 do i = is,ie
01018 fieldx(i,j,k) = -fieldx(i,j,k)
01019 fieldy(i,j,k) = -fieldy(i,j,k)
01020 end do
01021 end do
01022 end do
01023 end if
01024 !eliminate redundant vector data at fold
01025 j = domain%y%global%end
01026 if( domain%y%data%begin.LE.j .AND. j.LE.domain%y%data%end )then !fold is within domain
01027 !ship left-half data to right half: on BGRID_NE the x%data%end point is not in mirror domain and must be done separately.
01028 if( domain%x%pos.LT.(size(domain%x%list)+1)/2 )then
01029 is = domain%x%data%begin
01030 ie = min(domain%x%data%end,(domain%x%global%begin+domain%x%global%end)/2)
01031 n = buffer_pos
01032 select case(grid_offset_type)
01033 case(BGRID_NE)
01034 do k = 1,ke
01035 do i = is,ie-1
01036 n = n + 2
01037 buffer(n-1) = fieldx(i,j,k)
01038 buffer(n) = fieldy(i,j,k)
01039 end do
01040 end do
01041 call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
01042 buffer_pos = n
01043 case(CGRID_NE)
01044 do k = 1,ke
01045 do i = is,ie
01046 n = n + 1
01047 buffer(n) = fieldy(i,j,k)
01048 end do
01049 end do
01050 call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
01051 buffer_pos = n
01052 end select
01053 end if
01054 if( domain%x%pos.GE.size(domain%x%list)/2 )then
01055 is = max(domain%x%data%begin,(domain%x%global%begin+domain%x%global%end)/2+1)
01056 ie = domain%x%data%end
01057 select case(grid_offset_type)
01058 case(BGRID_NE)
01059 n = (ie-is+1)*ke*2
01060 call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
01061 n = buffer_pos
01062 !get all values except at x%data%end
01063 do k = 1,ke
01064 do i = ie-1,is,-1
01065 n = n + 2
01066 fieldx(i,j,k) = -buffer(n-1)
01067 fieldy(i,j,k) = -buffer(n)
01068 end do
01069 end do
01070 !now get the value at domain%x%data%end
01071 pos = domain%x%pos - 1
01072 if( pos.GE.size(domain%x%list)/2 )then
01073 i = domain%x%list(pos)%data%end
01074 buffer_pos = n
01075 do k = 1,ke
01076 n = n + 2
01077 buffer(n-1) = fieldx(i,j,k)
01078 buffer(n ) = fieldy(i,j,k)
01079 end do
01080 call mpp_send( buffer(buffer_pos+1:n), n-buffer_pos, domain%x%list(pos)%pe )
01081 buffer_pos = n
01082 end if
01083 pos = domain%x%pos + 1
01084 if( pos.LT.size(domain%x%list) )then
01085 n = ke*2
01086 call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(pos)%pe )
01087 n = buffer_pos
01088 i = domain%x%data%end
01089 do k = 1,ke
01090 n = n + 2
01091 fieldx(i,j,k) = buffer(n-1)
01092 fieldy(i,j,k) = buffer(n )
01093 end do
01094 end if
01095 case(CGRID_NE)
01096 n = (ie-is+1)*ke
01097 call mpp_recv( buffer(buffer_pos+1:buffer_pos+n), n, domain%x%list(size(domain%x%list)-domain%x%pos-1)%pe )
01098 n = buffer_pos
01099 do k = 1,ke
01100 do i = ie,is,-1
01101 n = n + 1
01102 fieldy(i,j,k) = -buffer(n)
01103 end do
01104 end do
01105 end select
01106 end if
01107 !poles set to 0: BGRID only
01108 if( grid_offset_type.EQ.BGRID_NE )then
01109 do i = domain%x%global%begin-1,domain%x%global%end,(domain%x%global%begin+domain%x%global%end)/2
01110 if( domain%x%data%begin.LE.i .AND. i.LE.domain%x%data%end )then
01111 do k = 1,ke
01112 fieldx(i,j,k) = 0.
01113 fieldy(i,j,k) = 0.
01114 end do
01115 end if
01116 end do
01117 end if
01118 !these last three code blocks correct an error where the data in your halo coming from other half may have the wrong sign
01119 !off west edge
01120 select case(grid_offset_type)
01121 case(BGRID_NE)
01122 is = domain%x%global%begin - 1
01123 if( is.GT.domain%x%data%begin )then
01124 if( 2*is-domain%x%data%begin.GT.domain%x%data%end ) &
01125 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE west edge ubound error.' )
01126 do k = 1,ke
01127 do i = domain%x%data%begin,is-1
01128 fieldx(i,j,k) = fieldx(2*is-i,j,k)
01129 fieldy(i,j,k) = fieldy(2*is-i,j,k)
01130 end do
01131 end do
01132 end if
01133 case(CGRID_NE)
01134 is = domain%x%global%begin
01135 if( is.GT.domain%x%data%begin )then
01136 if( 2*is-domain%x%data%begin-1.GT.domain%x%data%end ) &
01137 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE west edge ubound error.' )
01138 do k = 1,ke
01139 do i = domain%x%data%begin,is-1
01140 fieldy(i,j,k) = fieldy(2*is-i-1,j,k)
01141 end do
01142 end do
01143 end if
01144 end select
01145 !right of midpoint
01146 is = (domain%x%global%begin+domain%x%global%end)/2
01147 if( domain%x%compute%begin.LE.is .AND. is.LT.domain%x%data%end )then
01148 select case(grid_offset_type)
01149 case(BGRID_NE)
01150 ie = domain%x%data%end
01151 if( 2*is-ie.LT.domain%x%data%begin )ie = ie - 1
01152 if( 2*is-ie.LT.domain%x%data%begin ) &
01153 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE midpoint lbound error.' )
01154 do k = 1,ke
01155 do i = is+1,ie
01156 fieldx(i,j,k) = -fieldx(2*is-i,j,k)
01157 fieldy(i,j,k) = -fieldy(2*is-i,j,k)
01158 end do
01159 end do
01160 case(CGRID_NE)
01161 if( 2*is-domain%x%data%end+1.LT.domain%x%data%begin ) &
01162 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE midpoint lbound error.' )
01163 do k = 1,ke
01164 do i = is+1,domain%x%data%end
01165 fieldy(i,j,k) = -fieldy(2*is-i+1,j,k)
01166 end do
01167 end do
01168 end select
01169 end if
01170 !off east edge
01171 is = domain%x%global%end
01172 if( is.LT.domain%x%data%end )then
01173 select case(grid_offset_type)
01174 case(BGRID_NE)
01175 if( 2*is-domain%x%data%end.LT.domain%x%data%begin ) &
01176 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: BGRID_NE east edge lbound error.' )
01177 do k = 1,ke
01178 do i = is+1,domain%x%data%end
01179 fieldx(i,j,k) = fieldx(2*is-i,j,k)
01180 fieldy(i,j,k) = fieldy(2*is-i,j,k)
01181 end do
01182 end do
01183 case(CGRID_NE)
01184 if( 2*is-domain%x%data%end+1.LT.domain%x%data%begin ) &
01185 call mpp_error( FATAL, 'MPP_UPDATE_DOMAINS_V: CGRID_NE east edge lbound error.' )
01186 do k = 1,ke
01187 do i = is+1,domain%x%data%end
01188 fieldy(i,j,k) = fieldy(2*is-i+1,j,k)
01189 end do
01190 end do
01191 end select
01192 end if
01193 end if
01194 end if
01195
01196 grid_offset_type = AGRID !reset
01197 call mpp_sync_self()
01198 return
01199 end subroutine MPP_UPDATE_DOMAINS_3D_V_
01200
01201 subroutine MPP_UPDATE_DOMAINS_4D_V_( fieldx, fieldy, domain, flags, gridtype )
01202 !updates data domain of 4D field whose computational domains have been computed
01203 MPP_TYPE_, intent(inout), dimension(:,:,:,:) :: fieldx, fieldy
01204 type(domain2D), intent(inout) :: domain
01205 integer, intent(in), optional :: flags, gridtype
01206 MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4))
01207 MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4))
01208 #ifdef use_CRI_pointers
01209 pointer( ptrx, field3Dx )
01210 pointer( ptry, field3Dy )
01211 ptrx = LOC(fieldx)
01212 ptry = LOC(fieldy)
01213 call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
01214 #else
01215 field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
01216 field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
01217 call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
01218 fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
01219 fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
01220 #endif
01221 return
01222 end subroutine MPP_UPDATE_DOMAINS_4D_V_
01223
01224 subroutine MPP_UPDATE_DOMAINS_5D_V_( fieldx, fieldy, domain, flags, gridtype )
01225 !updates data domain of 5D field whose computational domains have been computed
01226 MPP_TYPE_, intent(inout), dimension(:,:,:,:,:) :: fieldx, fieldy
01227 type(domain2D), intent(inout) :: domain
01228 integer, intent(in), optional :: flags, gridtype
01229 MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5))
01230 MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5))
01231 #ifdef use_CRI_pointers
01232 pointer( ptrx, field3Dx )
01233 pointer( ptry, field3Dy )
01234 ptrx = LOC(fieldx)
01235 ptry = LOC(fieldy)
01236 call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
01237 #else
01238 field3Dx = RESHAPE( fieldx, SHAPE(field3Dx) )
01239 field3Dy = RESHAPE( fieldy, SHAPE(field3Dy) )
01240 call mpp_update_domains( field3Dx, field3Dy, domain, flags, gridtype )
01241 fieldx = RESHAPE( field3Dx, SHAPE(fieldx) )
01242 fieldy = RESHAPE( field3Dy, SHAPE(fieldy) )
01243 #endif
01244 return
01245 end subroutine MPP_UPDATE_DOMAINS_5D_V_
01246 #endif VECTOR_FIELD_
