Scrambler  1
layout_comms.f90
Go to the documentation of this file.
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
 All Classes Files Functions Variables