Scrambler
1
|
00001 MODULE LayoutComms 00002 USE LayoutDeclarations 00003 USE GlobalDeclarations 00004 USE TreeDeclarations 00005 USE DataDeclarations 00006 USE CommunicationDeclarations 00007 USE Fields 00008 00009 IMPLICIT NONE 00010 00011 INTERFACE LoadFieldIntoLayout 00012 MODULE PROCEDURE LoadFieldIntoLayoutC, LoadFieldIntoLayoutR 00013 END INTERFACE LoadFieldIntoLayout 00014 00015 INTERFACE UnLoadFieldFromLayout 00016 MODULE PROCEDURE UnLoadFieldFromLayoutC, UnLoadFieldFromLayoutR 00017 END INTERFACE UnLoadFieldFromLayout 00018 00019 INTERFACE TransferLayouts 00020 MODULE PROCEDURE TransferLayoutsC, TransferLayoutsR 00021 END INTERFACE TransferLayouts 00022 00023 00024 CONTAINS 00026 SUBROUTINE LoadFieldIntoLayoutC(layout, data, FieldID, level_opt) 00027 TYPE(LayoutDef) :: layout 00028 INTEGER :: FieldID(:) 00029 INTEGER :: level 00030 COMPLEX(8), DIMENSION(:,:,:,:), POINTER :: data 00031 INTEGER :: mO(3,2), mB(3,2), mC(3,2) 00032 REAL(8), DIMENSION(:,:,:,:), ALLOCATABLE :: buffer 00033 CHARACTER, DIMENSION(:), ALLOCATABLE :: mpi_buffer 00034 INTEGER :: iErr 00035 INTEGER :: status(MPI_STATUS_SIZE) 00036 TYPE(NodeDefList), POINTER :: nodelist 00037 TYPE(NodeDef), POINTER :: node 00038 INTEGER :: buffsize 00039 INTEGER :: i,j,k,l,m,remote_proc, nfields 00040 INTEGER, OPTIONAL :: level_opt 00041 INTEGER :: level_min, level_max 00042 00043 IF (PRESENT(level_opt)) THEN 00044 level_min=level_opt 00045 level_max=level_opt 00046 ELSE 00047 level_min=0 00048 level_max=layout%level 00049 END IF 00050 mC=1 00051 mB=layout%mB(MPI_ID,:,:) 00052 nfields=size(data,4) 00053 DO level=level_min, level_max 00054 buffsize=0 00055 nodelist=>Nodes(level)%p 00056 DO WHILE (ASSOCIATED(NodeList)) 00057 buffsize=buffsize+6*PACK_INTEGER_SIZE 00058 buffsize=buffsize+PRODUCT(nodelist%self%info%mx(1:nDim))*PACK_DOUBLE_SIZE*nfields 00059 buffsize=buffsize+MPI_BSEND_OVERHEAD 00060 nodelist=>nodelist%next 00061 END DO 00062 buffsize=buffsize+6*PACK_INTEGER_SIZE+MPI_BSEND_OVERHEAD 00063 ALLOCATE(mpi_buffer(buffsize)) 00064 DO l=1, MPI_NP 00065 CALL MPI_Buffer_attach(mpi_buffer, buffsize, iErr) 00066 remote_proc=modulo(MPI_ID+l, MPI_NP) 00067 nodelist=>Nodes(level)%p 00068 DO WHILE (ASSOCIATED(nodelist)) 00069 node=>nodelist%self 00070 mO(:,:)=LevelDown(layout%mB(remote_proc,:,:),layout%level, level) 00071 mO(:,1)=max(mO(:,1), node%box%mGlobal(:,1)) 00072 mO(:,2)=min(mO(:,2), node%box%mGlobal(:,2)) 00073 IF (ALL(mO(:,2) >= mO(:,1))) THEN 00074 ALLOCATE(buffer(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2),nfields)) 00075 CALL MPI_BSEND(mO, 6, MPI_INTEGER, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00076 DO i=mO(1,1),mO(1,2) 00077 DO j=mO(2,1), mO(2,2) 00078 DO k=mO(3,1), mO(3,2) 00079 DO m=1,nfields 00080 buffer(i,j,k,m)=GetField(node%Info,i-node%box%mGlobal(1,1)+1, j-node%box%mGlobal(2,1)+1, k-node%box%mGlobal(3,1)+1, FieldID(m)) 00081 END DO 00082 END DO 00083 END DO 00084 END DO 00085 CALL MPI_BSEND(buffer, size(buffer), MPI_DOUBLE_PRECISION, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00086 DEALLOCATE(buffer) 00087 END IF 00088 nodelist=>nodelist%next 00089 END DO 00090 CALL MPI_BSEND(TERMINATIONBOX, 6, MPI_INTEGER, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00091 remote_proc=modulo(MPI_ID-l, MPI_NP) 00092 DO 00093 CALL MPI_RECV(mO, 6, MPI_INTEGER, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, status, iErr) 00094 IF (ALL(mO == TERMINATIONBOX)) THEN 00095 EXIT 00096 ELSE 00097 ALLOCATE(buffer(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2), nfields)) 00098 CALL MPI_RECV(buffer, size(buffer), MPI_DOUBLE_PRECISION, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, status, iErr) 00099 IF (layout%level == level) THEN 00100 data(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2),1:nfields)=buffer 00101 ELSE 00102 DO i=mO(1,1), mO(1,2) 00103 mC(1,:)=MapToLevel(i, level, layout%level) 00104 mC(1,1)=max(mC(1,1), mB(1,1)) 00105 mC(1,2)=min(mC(1,2), mB(1,2)) 00106 DO j=mO(2,1), mO(2,2) 00107 IF (nDim >= 2) THEN 00108 mC(2,:)=MapToLevel(j, level, layout%level) 00109 mC(2,1)=max(mC(2,1), mB(2,1)) 00110 mC(2,2)=min(mC(2,2), mB(2,2)) 00111 END IF 00112 DO k=mO(3,1), mO(3,2) 00113 IF (nDim >= 3) THEN 00114 mC(3,:)=MapToLevel(k, level, layout%level) 00115 mC(3,1)=max(mC(3,1), mB(3,1)) 00116 mC(3,2)=min(mC(3,2), mB(3,2)) 00117 END IF 00118 DO m=1,nFields 00119 data(mC(1,1):mC(1,2), mC(2,1):mC(2,2), mC(3,1):mC(3,2), m)=buffer(i,j,k,m) 00120 END DO 00121 END DO 00122 END DO 00123 END DO 00124 END IF 00125 DEALLOCATE(buffer) 00126 END IF 00127 END DO 00128 CALL MPI_Buffer_detach(mpi_buffer, buffsize, iErr) 00129 END DO 00130 DEALLOCATE(mpi_buffer) 00131 END DO 00132 END SUBROUTINE LoadFieldIntoLayoutC 00133 00134 00135 00137 SUBROUTINE UnLoadFieldFromLayoutC(layout, data, FieldID, lPeriodic, rmbc) 00138 TYPE(LayoutDef) :: layout 00139 INTEGER :: FieldID(:,:) 00140 INTEGER :: level 00141 INTEGER :: rmbc 00142 LOGICAL, DIMENSION(:) :: lPeriodic 00143 COMPLEX(8), DIMENSION(:,:,:,:) :: data 00144 INTEGER :: mS(3,2), mB(3,2), mT(3,2) 00145 INTEGER, POINTER, DIMENSION(:,:,:) :: mTs, mSs 00146 INTEGER :: nOverlaps 00147 COMPLEX(8), DIMENSION(:,:,:,:), ALLOCATABLE :: buffer 00148 CHARACTER, DIMENSION(:), ALLOCATABLE :: mpi_buffer 00149 INTEGER :: iErr 00150 INTEGER :: status(MPI_STATUS_SIZE) 00151 TYPE(NodeDefList), POINTER :: nodelist 00152 TYPE(NodeDef), POINTER :: node 00153 INTEGER :: buffsize 00154 INTEGER :: i,j,k,l, recv_proc, send_proc 00155 INTEGER :: request, nfields 00156 nfields=size(FieldID,1) 00157 DO l=1, MPI_NP 00158 recv_proc=modulo(MPI_ID+l, MPI_NP) 00159 send_proc=modulo(MPI_ID-l, MPI_NP) 00160 mB=layout%mB(recv_proc,:,:) 00161 ALLOCATE(buffer(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2),nfields)) 00162 CALL MPI_IRECV(buffer, size(buffer), MPI_DOUBLE_COMPLEX, recv_proc, LAYOUT_TAG, MPI_COMM_WORLD, request, iErr) 00163 00164 CALL MPI_SEND(data, size(data), MPI_DOUBLE_COMPLEX, send_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00165 CALL MPI_WAIT(request, status, iErr) 00166 00167 nodelist=>Nodes(layout%level)%p 00168 DO WHILE (ASSOCIATED(nodelist)) 00169 node=>nodelist%self 00170 CALL CalcOverlaps(node%box%mGlobal(:,:), layout%mB(recv_proc,:,:), mTs, mSs, nOverlaps, layout%level, lPeriodic, rmbc) 00171 IF (nOverlaps > 0) THEN 00172 DO j=1,nOverlaps 00173 mS=mSs(j,:,:)+spread(layout%mB(recv_proc,:,1),2,2)-1 00174 mT=mTs(j,:,:) 00175 ! mO(1:nDim,1)=max(layout%mB(recv_proc,1:nDim,1), node%box%mGlobal(1:nDim,1)-rmbc) 00176 ! mO(1:nDim,2)=min(layout%mB(recv_proc,1:nDim,2), node%box%mGlobal(1:nDim,2)+rmbc) 00177 ! IF (ALL(mO(:,2) >= mO(:,1))) THEN 00178 ! ip=mO-spread(node%box%mGlobal(:,1),2,2)+1 00179 DO i=1,nfields 00180 IF (FieldID(i,1) /= 0) THEN 00181 node%info%q(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2), FieldiD(i,1))= & 00182 REAL(buffer(mS(1,1):mS(1,2), mS(2,1):mS(2,2), mS(3,1):mS(3,2),i)) 00183 END IF 00184 IF (FieldID(i,2) /= 0) THEN 00185 node%info%q(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2), FieldiD(i,2))= & 00186 AIMAG(buffer(mS(1,1):mS(1,2), mS(2,1):mS(2,2), mS(3,1):mS(3,2),i)) 00187 END IF 00188 END DO 00189 END DO 00190 DEALLOCATE(mTs, mSs) 00191 END IF 00192 nodelist=>nodelist%next 00193 END DO 00194 DEALLOCATE(buffer) 00195 END DO 00196 END SUBROUTINE UnLoadFieldFromLayoutC 00197 00198 00200 SUBROUTINE TransferLayoutsC(layout_src, layout_trg, data, newdata_opt) 00201 TYPE(LayoutDef) :: layout_src, layout_trg 00202 COMPLEX(8), DIMENSION(:,:,:,:), POINTER :: data, newdata 00203 COMPLEX(8), DIMENSION(:,:,:,:), POINTER, OPTIONAL :: newdata_opt 00204 INTEGER :: mO(3,2), mB(3,2) 00205 COMPLEX(8), DIMENSION(:,:,:,:), ALLOCATABLE :: recvbuffer, sendbuffer 00206 INTEGER :: iErr 00207 INTEGER :: status(MPI_STATUS_SIZE) 00208 INTEGER :: l,send_proc, recv_proc, isrc, itrg 00209 INTEGER :: request, nfields 00210 mB=layout_trg%mB(MPI_ID,:,:) 00211 nfields=size(data,4) 00212 IF (PRESENT(newdata_opt)) THEN 00213 newdata=>newdata_opt 00214 ELSE 00215 ALLOCATE(newdata(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2),nfields)) 00216 END IF 00217 DO l=1, MPI_NP 00218 send_proc=modulo(MPI_ID+l, MPI_NP) 00219 recv_proc=modulo(MPI_ID-l, MPI_NP) 00220 mO(:,1)=max(layout_trg%mB(MPI_ID,:,1), layout_src%mB(recv_proc,:,1)) 00221 mO(:,2)=min(layout_trg%mB(MPI_ID,:,2), layout_src%mB(recv_proc,:,2)) 00222 IF (ALL(mO(:,2) >= mO(:,1))) THEN 00223 ALLOCATE(recvbuffer(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2), nfields)) 00224 CALL MPI_IRECV(recvbuffer, size(recvbuffer), MPI_DOUBLE_COMPLEX, recv_proc, LAYOUT_TAG, MPI_COMM_WORLD, request, iErr) 00225 END IF 00226 mB(:,1)=max(layout_src%mB(MPI_ID,:,1), layout_trg%mB(send_proc,:,1)) 00227 mB(:,2)=min(layout_src%mB(MPI_ID,:,2), layout_trg%mB(send_proc,:,2)) 00228 IF (ALL(mB(:,2) >= mB(:,1))) THEN 00229 ALLOCATE(sendbuffer(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), nfields)) 00230 sendbuffer=data(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2),:) 00231 CALL MPI_SEND(sendbuffer, size(sendbuffer), MPI_DOUBLE_COMPLEX, send_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00232 DEALLOCATE(sendbuffer) 00233 END IF 00234 IF (ALL(mO(:,2) >= mO(:,1))) THEN 00235 CALL MPI_WAIT(request, status, iErr) 00236 newdata(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2),:)=recvbuffer 00237 DEALLOCATE(recvbuffer) 00238 END IF 00239 END DO 00240 IF (.NOT. PRESENT(newdata_opt)) THEN 00241 DEALLOCATE(data) 00242 data=>newdata 00243 END IF 00244 END SUBROUTINE TransferLayoutsC 00245 00246 00247 00249 SUBROUTINE LoadFieldIntoLayoutR(layout, data, FieldID, level_opt) 00250 TYPE(LayoutDef) :: layout 00251 INTEGER :: FieldID(:) 00252 INTEGER :: level 00253 REAL(8), DIMENSION(:,:,:,:), POINTER :: data 00254 INTEGER :: mO(3,2), mB(3,2), mC(3,2) 00255 REAL(8), DIMENSION(:,:,:,:), ALLOCATABLE :: buffer 00256 CHARACTER, DIMENSION(:), ALLOCATABLE :: mpi_buffer 00257 INTEGER :: iErr 00258 INTEGER :: status(MPI_STATUS_SIZE) 00259 TYPE(NodeDefList), POINTER :: nodelist 00260 TYPE(NodeDef), POINTER :: node 00261 INTEGER :: buffsize 00262 INTEGER :: i,j,k,l,m,remote_proc, nfields 00263 INTEGER, OPTIONAL :: level_opt 00264 INTEGER :: level_min, level_max 00265 00266 IF (PRESENT(level_opt)) THEN 00267 level_min=level_opt 00268 level_max=level_opt 00269 ELSE 00270 level_min=0 00271 level_max=layout%level 00272 END IF 00273 mB=layout%mB(MPI_ID,:,:) 00274 mC=1 00275 nfields=size(data,4) 00276 DO level=level_min, level_max 00277 nodelist=>Nodes(level)%p 00278 buffsize=0 00279 DO WHILE (ASSOCIATED(NodeList)) 00280 buffsize=buffsize+6*PACK_INTEGER_SIZE 00281 buffsize=buffsize+PRODUCT(nodelist%self%info%mx(1:nDim)+2)*PACK_DOUBLE_SIZE*nfields 00282 buffsize=buffsize+MPI_BSEND_OVERHEAD 00283 nodelist=>nodelist%next 00284 END DO 00285 buffsize=buffsize+6*PACK_INTEGER_SIZE+MPI_BSEND_OVERHEAD 00286 ALLOCATE(mpi_buffer(buffsize)) 00287 DO l=1, MPI_NP 00288 CALL MPI_Buffer_attach(mpi_buffer, buffsize, iErr) 00289 remote_proc=modulo(MPI_ID+l, MPI_NP) 00290 nodelist=>Nodes(level)%p 00291 DO WHILE (ASSOCIATED(nodelist)) 00292 node=>nodelist%self 00293 mO(:,:)=LevelDown(layout%mB(remote_proc,:,:),layout%level, level) 00294 mO(:,1)=max(mO(:,1), node%box%mGlobal(:,1)) 00295 mO(:,2)=min(mO(:,2), node%box%mGlobal(:,2)) 00296 IF (ALL(mO(:,2) >= mO(:,1))) THEN 00297 ALLOCATE(buffer(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2),nfields)) 00298 CALL MPI_BSEND(mO, 6, MPI_INTEGER, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00299 DO i=mO(1,1),mO(1,2) 00300 DO j=mO(2,1), mO(2,2) 00301 DO k=mO(3,1), mO(3,2) 00302 DO m=1,nfields 00303 buffer(i,j,k,m)=GetField(node%Info,i-node%box%mGlobal(1,1)+1, j-node%box%mGlobal(2,1)+1, k-node%box%mGlobal(3,1)+1, FieldID(m)) 00304 END DO 00305 END DO 00306 END DO 00307 END DO 00308 CALL MPI_BSEND(buffer, size(buffer), MPI_DOUBLE_PRECISION, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00309 DEALLOCATE(buffer) 00310 END IF 00311 nodelist=>nodelist%next 00312 END DO 00313 CALL MPI_BSEND(TERMINATIONBOX, 6, MPI_INTEGER, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00314 remote_proc=modulo(MPI_ID-l, MPI_NP) 00315 DO 00316 CALL MPI_RECV(mO, 6, MPI_INTEGER, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, status, iErr) 00317 IF (ALL(mO == TERMINATIONBOX)) THEN 00318 EXIT 00319 ELSE 00320 ALLOCATE(buffer(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2), nfields)) 00321 CALL MPI_RECV(buffer, size(buffer), MPI_DOUBLE_PRECISION, remote_proc, LAYOUT_TAG, MPI_COMM_WORLD, status, iErr) 00322 IF (layout%level == level) THEN 00323 data(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2),:)=buffer 00324 ELSE 00325 DO i=mO(1,1), mO(1,2) 00326 mC(1,:)=MapToLevel(i, level, layout%level) 00327 mC(1,1)=max(mC(1,1), mB(1,1)) 00328 mC(1,2)=min(mC(1,2), mB(1,2)) 00329 DO j=mO(2,1), mO(2,2) 00330 IF (nDim >= 2) THEN 00331 mC(2,:)=MapToLevel(j, level, layout%level) 00332 mC(2,1)=max(mC(2,1), mB(2,1)) 00333 mC(2,2)=min(mC(2,2), mB(2,2)) 00334 END IF 00335 DO k=mO(3,1), mO(3,2) 00336 IF (nDim >= 3) THEN 00337 mC(3,:)=MapToLevel(k, level, layout%level) 00338 mC(3,1)=max(mC(3,1), mB(3,1)) 00339 mC(3,2)=min(mC(3,2), mB(3,2)) 00340 END IF 00341 DO m=1,nFields 00342 data(mC(1,1):mC(1,2), mC(2,1):mC(2,2), mC(3,1):mC(3,2), m)=buffer(i,j,k,m) 00343 END DO 00344 END DO 00345 END DO 00346 END DO 00347 END IF 00348 DEALLOCATE(buffer) 00349 END IF 00350 END DO 00351 CALL MPI_Buffer_detach(mpi_buffer, buffsize, iErr) 00352 END DO 00353 DEALLOCATE(mpi_buffer) 00354 END DO 00355 END SUBROUTINE LoadFieldIntoLayoutR 00356 00357 00358 00360 SUBROUTINE UnLoadFieldFromLayoutR(layout, data, FieldID, lPeriodic, rmbc) 00361 TYPE(LayoutDef) :: layout 00362 INTEGER :: FieldID(:) 00363 INTEGER :: level 00364 INTEGER :: rmbc 00365 LOGICAL :: lPeriodic(:) 00366 REAL(8), DIMENSION(:,:,:,:) :: data 00367 INTEGER :: mS(3,2), mB(3,2), mT(3,2) 00368 INTEGER, DIMENSION(:,:,:), POINTER :: mTs, mSs 00369 REAL(8), DIMENSION(:,:,:,:), ALLOCATABLE :: buffer 00370 CHARACTER, DIMENSION(:), ALLOCATABLE :: mpi_buffer 00371 INTEGER :: iErr, nOverlaps 00372 INTEGER :: status(MPI_STATUS_SIZE) 00373 TYPE(NodeDefList), POINTER :: nodelist 00374 TYPE(NodeDef), POINTER :: node 00375 INTEGER :: buffsize 00376 INTEGER :: i,j,k,l, recv_proc, send_proc 00377 INTEGER :: request, nfields 00378 nfields=size(FieldID,1) 00379 DO l=1, MPI_NP 00380 recv_proc=modulo(MPI_ID+l, MPI_NP) 00381 send_proc=modulo(MPI_ID-l, MPI_NP) 00382 mB=layout%mB(recv_proc,:,:) 00383 ALLOCATE(buffer(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2),nfields)) 00384 CALL MPI_IRECV(buffer, size(buffer), MPI_DOUBLE_PRECISION, recv_proc, LAYOUT_TAG, MPI_COMM_WORLD, request, iErr) 00385 00386 CALL MPI_SEND(data, size(data), MPI_DOUBLE_PRECISION, send_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00387 CALL MPI_WAIT(request, status, iErr) 00388 00389 nodelist=>Nodes(layout%level)%p 00390 DO WHILE (ASSOCIATED(nodelist)) 00391 node=>nodelist%self 00392 CALL CalcOverlaps(node%box%mGlobal(:,:), layout%mB(recv_proc,:,:), mTs, mSs, nOverlaps, layout%level, lPeriodic, rmbc) 00393 IF (nOverlaps > 0) THEN 00394 DO j=1,nOverlaps 00395 mS=mSs(j,:,:)+spread(layout%mB(recv_proc,:,1),2,2)-1 00396 mT=mTs(j,:,:) 00397 ! mO(1:nDim,1)=max(layout%mB(recv_proc,1:nDim,1), node%box%mGlobal(1:nDim,1)-rmbc) 00398 ! mO(1:nDim,2)=min(layout%mB(recv_proc,1:nDim,2), node%box%mGlobal(1:nDim,2)+rmbc) 00399 ! IF (ALL(mO(:,2) >= mO(:,1))) THEN 00400 ! ip=mO-spread(node%box%mGlobal(:,1),2,2)+1 00401 DO i=1,nfields 00402 node%info%q(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2), FieldiD(i))= & 00403 buffer(mS(1,1):mS(1,2), mS(2,1):mS(2,2), mS(3,1):mS(3,2),i) 00404 END DO 00405 END DO 00406 DEALLOCATE(mTs, mSs) 00407 END IF 00408 nodelist=>nodelist%next 00409 END DO 00410 DEALLOCATE(buffer) 00411 END DO 00412 END SUBROUTINE UnLoadFieldFromLayoutR 00413 00414 00416 SUBROUTINE TransferLayoutsR(layout_src, layout_trg, data, newdata_opt) 00417 TYPE(LayoutDef) :: layout_src, layout_trg 00418 REAL(8), DIMENSION(:,:,:,:), POINTER :: data, newdata 00419 REAL(8), DIMENSION(:,:,:,:), POINTER, OPTIONAL :: newdata_opt 00420 INTEGER :: mO(3,2), mB(3,2) 00421 REAL(8), DIMENSION(:,:,:,:), ALLOCATABLE :: recvbuffer, sendbuffer 00422 INTEGER :: iErr 00423 INTEGER :: status(MPI_STATUS_SIZE) 00424 INTEGER :: l,send_proc, recv_proc, isrc, itrg 00425 INTEGER :: request, nfields 00426 mB=layout_trg%mB(MPI_ID,:,:) 00427 nfields=size(data,4) 00428 IF (PRESENT(newdata_opt)) THEN 00429 newdata=>newdata_opt 00430 ELSE 00431 ALLOCATE(newdata(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2),nfields)) 00432 END IF 00433 DO l=1, MPI_NP 00434 send_proc=modulo(MPI_ID+l, MPI_NP) 00435 recv_proc=modulo(MPI_ID-l, MPI_NP) 00436 mO(:,1)=max(layout_trg%mB(MPI_ID,:,1), layout_src%mB(recv_proc,:,1)) 00437 mO(:,2)=min(layout_trg%mB(MPI_ID,:,2), layout_src%mB(recv_proc,:,2)) 00438 IF (ALL(mO(:,2) >= mO(:,1))) THEN 00439 ALLOCATE(recvbuffer(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2), nfields)) 00440 CALL MPI_IRECV(recvbuffer, size(recvbuffer), MPI_DOUBLE_PRECISION, recv_proc, LAYOUT_TAG, MPI_COMM_WORLD, request, iErr) 00441 END IF 00442 mB(:,1)=max(layout_src%mB(MPI_ID,:,1), layout_trg%mB(send_proc,:,1)) 00443 mB(:,2)=min(layout_src%mB(MPI_ID,:,2), layout_trg%mB(send_proc,:,2)) 00444 IF (ALL(mB(:,2) >= mB(:,1))) THEN 00445 ALLOCATE(sendbuffer(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), nfields)) 00446 sendbuffer=data(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2),:) 00447 CALL MPI_SEND(sendbuffer, size(sendbuffer), MPI_DOUBLE_PRECISION, send_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00448 DEALLOCATE(sendbuffer) 00449 END IF 00450 IF (ALL(mO(:,2) >= mO(:,1))) THEN 00451 CALL MPI_WAIT(request, status, iErr) 00452 newdata(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2),:)=recvbuffer 00453 DEALLOCATE(recvbuffer) 00454 END IF 00455 END DO 00456 IF (.NOT. PRESENT(newdata_opt)) THEN 00457 DEALLOCATE(data) 00458 data=>newdata 00459 END IF 00460 END SUBROUTINE TransferLayoutsR 00461 00462 00463 !Similar to TransferLayouts except that we are transferring a subregion and the layouts may have different bounds 00464 SUBROUTINE LayoutTransferC(mC, mD, layout_src, layout_trg, data_src, data_trg) 00465 INTEGER, DIMENSION(3,2) :: mC, mD, mS, mR, mSO, mRO 00466 INTEGER :: l, offset(3), trg_proc, src_proc, nfields 00467 TYPE(LayoutDef) :: layout_src, layout_trg 00468 COMPLEX(8), DIMENSION(:,:,:,:), POINTER :: data_src, data_trg 00469 COMPLEX(8), DIMENSION(:,:,:,:), ALLOCATABLE :: send_buffer, recv_buffer 00470 INTEGER :: status(MPI_STATUS_SIZE), request, iErr 00471 LOGICAL :: lRecv, lSend, lRecvNow, lSendNow 00472 00473 00474 IF (product(mC(:,2)-mC(:,1)+1) /= product(mD(:,2)-mD(:,1)+1)) THEN 00475 PRINT*, 'ERROR: Data in layout transfer not the same size' 00476 write(*,'(6I5)') mC 00477 write(*,'(6I5)') mD 00478 STOP 00479 END IF 00480 00481 nfields=size(data_src, 4) 00482 offset=mD(:,1)-mC(:,1) !offset between layouts 00483 00484 !So mS and mT are distributed across processors 00485 !Processors can send data right and receive left 00486 !Doesn't really matter? 00487 00488 mR(:,1)=max(layout_trg%mB(MPI_ID,:,1), mD(:,1)) 00489 mR(:,2)=min(layout_trg%mB(MPI_ID,:,2), mD(:,2)) 00490 lRecv=ALL(mR(:,2) >= mR(:,1)) 00491 00492 mS(:,1)=max(layout_src%mB(MPI_ID,:,1), mC(:,1)) 00493 mS(:,2)=min(layout_src%mB(MPI_ID,:,2), mC(:,2)) 00494 lSend=ALL(mS(:,2) >= mS(:,1)) 00495 00496 IF (.NOT. lSend .AND. .NOT. lRecv) RETURN !We are done - nothing to transfer 00497 00498 DO l=1, MPI_NP 00499 IF (lSend) THEN 00500 trg_proc=modulo(MPI_ID+l, MPI_NP) 00501 mSO(:,1)=max(mS(:,1), layout_trg%mB(trg_proc,:,1)-offset) 00502 mSO(:,2)=min(mS(:,2), layout_trg%mB(trg_proc,:,2)-offset) 00503 lSendNow=ALL(mSO(:,2) >= mSO(:,1)) 00504 ELSE 00505 lSendNow=.false. 00506 END IF 00507 IF (lRecv) THEN 00508 src_proc=modulo(MPI_ID-l, MPI_NP) 00509 mRO(:,1)=max(mR(:,1), layout_src%mB(src_proc,:,1)+offset) 00510 mRO(:,2)=min(mR(:,2), layout_src%mB(src_proc,:,2)+offset) 00511 lRecvNow=ALL(mRO(:,2) >= mRO(:,1)) 00512 ELSE 00513 lRecvNow=.false. 00514 END IF 00515 00516 IF (lRecvNow) THEN 00517 ALLOCATE(recv_buffer(mRO(1,1):mRO(1,2), mRO(2,1):mRO(2,2), mRO(3,1):mRO(3,2), 1:nfields)) 00518 CALL MPI_IRECV(recv_buffer, size(recv_buffer), MPI_DOUBLE_COMPLEX, src_proc, LAYOUT_TAG, MPI_COMM_WORLD, request, iErr) 00519 END IF 00520 00521 IF (lSendNow) THEN 00522 ALLOCATE(send_buffer(mSO(1,1):mSO(1,2), mSO(2,1):mSO(2,2), mSO(3,1):mSO(3,2), 1:nfields)) 00523 send_buffer=data_src(mSO(1,1):mSO(1,2), mSO(2,1):mSO(2,2), mSO(3,1):mSO(3,2), 1:nFields) 00524 CALL MPI_SEND(send_buffer, size(send_buffer), MPI_DOUBLE_COMPLEX, trg_proc, LAYOUT_TAG, MPI_COMM_WORLD, iErr) 00525 DEALLOCATE(send_buffer) 00526 END IF 00527 IF (lRecvNow) THEN 00528 CALL MPI_WAIT(request, status, iErr) 00529 data_trg(mRO(1,1):mRO(1,2), mRO(2,1):mRO(2,2), mRO(3,1):mRO(3,2), 1:nfields)=recv_buffer 00530 DEALLOCATE(recv_buffer) 00531 END IF 00532 END DO 00533 00534 END SUBROUTINE LayoutTransferC 00535 00536 00537 END MODULE LayoutComms