|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
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 //trim(text)//') from all PEs.' ) 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 //trim(text)//') from all PEs.' ) 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 //trim(text)//') from all PEs.' ) 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 //trim(text)//') from all PEs.' ) 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 //trim(text)//') from all PEs.' ) 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 //trim(text)//') from all PEs.' ) 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_
1.7.4 
