Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! tree_level_comms.f90 is part of AstroBEAR. 00008 ! 00009 ! AstroBEAR is free software: you can redistribute it and/or modify 00010 ! it under the terms of the GNU General Public License as published by 00011 ! the Free Software Foundation, either version 3 of the License, or 00012 ! (at your option) any later version. 00013 ! 00014 ! AstroBEAR is distributed in the hope that it will be useful, 00015 ! but WITHOUT ANY WARRANTY; without even the implied warranty of 00016 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00017 ! GNU General Public License for more details. 00018 ! 00019 ! You should have received a copy of the GNU General Public License 00020 ! along with AstroBEAR. If not, see <http://www.gnu.org/licenses/>. 00021 ! 00022 !######################################################################### 00025 00028 00032 00035 MODULE TreeLevelComms 00036 USE TreeDeclarations 00037 USE TreeParsing 00038 USE CommunicationDeclarations 00039 USE GlobalDeclarations 00040 USE DistributionDeclarations 00041 USE Timing 00042 IMPLICIT NONE 00043 00044 00045 !Interlevel Sends To Children 00046 PUBLIC PostSendGridsToChildren, PostSendOverlapsNeighbors, PostSendOverlapsToOldNodesChildren, PostSendOverlapsToNodesOldChildren 00047 00048 !Interlevel Receives From Parents 00049 PUBLIC PostRecvGridsFromParents, PostRecvOverlapsNeighbors, PostRecvOldNodeOverlaps 00050 00051 !Intralevel Sends/Recvs from neighbors/overlaps 00052 PUBLIC PostSendNeighboringChildren, PostSendOverlappingChildrenToOldNodes, PostSendOverlappingChildrenToNewNodes, & 00053 PostRecvNeighboringChildren, PostRecvOverlappingChildrenFromOldNodes, PostRecvOverlappingChildrenFromNewNodes 00054 00055 !Interlevel Send Completions to Children 00056 PUBLIC CompSendGridsToChildren, CompSendOverlapsNeighbors, CompSendOverlapsToOldNodesChildren, CompSendOverlapsToNodesOldChildren 00057 00058 !Interlevel Receive Completions from Parents 00059 PUBLIC CompRecvGridsFromParents, CompRecvOverlapsNeighbors, CompRecvOldNodeOverlaps 00060 00061 !Intralevel Sends/Recvs Completions from neighbors/overlaps 00062 PUBLIC CompSendNeighboringChildren, CompSendOverlappingChildrenToOldNodes, CompSendOverlappingChildrenToNewNodes, & 00063 CompRecvNeighboringChildren, CompRecvOverlappingChildrenFromOldNodes, CompRecvOverlappingChildrenFromNewNodes 00064 00065 PUBLIC PackTest 00066 PRIVATE 00067 CONTAINS 00068 00069 00072 00073 SUBROUTINE PostSendNeighboringChildren(n) 00074 INTEGER :: n 00075 TYPE(StageMessageGroup), Pointer ::MessageGroup 00076 TYPE(PackedMessage), POINTER :: message 00077 TYPE(NodeDefList), POINTER :: nodelist, neighborlist 00078 TYPE(NodeDef), POINTER :: node, neighbor 00079 CALL StartTimer(iiSendNeighboringChildren, n) 00080 00081 CALL CreateMessageGroup(StageMessageGroups(iSendNeighboringChildren,n)%p, TRANSMIT_NEIGHBORING_CHILDREN,STAGE_SEND,n) 00082 MessageGroup=>StageMessageGroups(iSendNeighboringChildren,n)%p 00083 00084 nodelist=>Nodes(n)%p 00085 DO WHILE (associated(nodelist)) 00086 node=>nodelist%self 00087 neighborlist=>node%neighbors 00088 DO WHILE (associated(neighborlist)) 00089 neighbor=>neighborlist%self 00090 IF (neighbor%box%MPI_ID /= MPI_ID) THEN 00091 CALL ExtractMessageFromGroup(MessageGroup,neighbor%box%MPI_ID, message) !This ensures that every neighbor gets a message - even if there is nothing to send 00092 CALL SendNeighboringChildren(message,node,neighbor) 00093 END IF 00094 neighborlist=>neighborlist%next 00095 END DO 00096 nodelist=>nodelist%next 00097 END DO 00098 CALL SendTerminationBox(MessageGroup) 00099 CALL CloseMessageGroup(MessageGroup) 00100 CALL StopTimer(iiSendNeighboringChildren, n) 00101 END SUBROUTINE PostSendNeighboringChildren 00102 00103 SUBROUTINE CompSendNeighboringChildren(n) 00104 INTEGER :: n 00105 CALL StartTimer(iiSendNeighboringChildren, n) 00106 CALL DestroyMessageGroup(StageMessageGroups(iSendNeighboringChildren,n)%p) 00107 CALL StopTimer(iiSendNeighboringChildren, n) 00108 END SUBROUTINE CompSendNeighboringChildren 00109 00110 SUBROUTINE PostRecvNeighboringChildren(n) 00111 INTEGER :: n 00112 TYPE(StageMessageGroup), Pointer ::MessageGroup 00113 TYPE(PackedMessage), POINTER :: message 00114 TYPE(NodeDefList), POINTER :: nodelist, neighborlist 00115 TYPE(NodeDef), POINTER :: node, neighbor 00116 CALL StartTimer(iiRecvNeighboringChildren, n) 00117 CALL CreateMessageGroup(StageMessageGroups(iRecvNeighboringChildren,n)%p, TRANSMIT_NEIGHBORING_CHILDREN,STAGE_RECV,n) 00118 MessageGroup=>StageMessageGroups(iRecvNeighboringChildren,n)%p 00119 00120 nodelist=>Nodes(n)%p 00121 DO WHILE (associated(nodelist)) 00122 node=>nodelist%self 00123 neighborlist=>node%neighbors 00124 DO WHILE (associated(neighborlist)) 00125 neighbor=>neighborlist%self 00126 IF (neighbor%box%MPI_ID /= MPI_ID) CALL ExtractMessageFromGroup(MessageGroup,neighbor%box%MPI_ID, message) !This ensures that every neighbor gets a message - even if there is nothing to send 00127 neighborlist=>neighborlist%next 00128 END DO 00129 nodelist=>nodelist%next 00130 END DO 00131 CALL StopTimer(iiRecvNeighboringChildren, n) 00132 END SUBROUTINE PostRecvNeighboringChildren 00133 00134 SUBROUTINE CompRecvNeighboringChildren(n) 00135 INTEGER :: n 00136 TYPE(StageMessageGroup), Pointer :: sm_group 00137 TYPE(PackedMessage), POINTER :: message 00138 CALL StartTimer(iiRecvNeighboringChildren, n) 00139 00140 sm_group => StageMessageGroups(iRecvNeighboringChildren,n)%p 00141 CALL MGBlockOnFirstMessages(sm_group, message) 00142 00143 DO WHILE (ASSOCIATED(message)) 00144 CALL RecvNeighboringChildren(message) 00145 CALL MGBlockOnFirstMessages(sm_group, message) 00146 END DO 00147 00148 CALL DestroyMessageGroup(StageMessageGroups(iRecvNeighboringChildren,n)%p) 00149 CALL StopTimer(iiRecvNeighboringChildren, n) 00150 END SUBROUTINE CompRecvNeighboringChildren 00151 00153 00156 00157 SUBROUTINE PostSendOverlappingChildrenToNewNodes(n) 00158 INTEGER :: n 00159 TYPE(NodeDef), POINTER :: node, overlap 00160 TYPE(NodeDefList), POINTER :: nodelist, overlaplist 00161 TYPE(StageMessageGroup), Pointer ::MessageGroup 00162 TYPE(PackedMessage), POINTER :: message 00163 CALL StartTimer(iiSendOverlappingChildrenToNewNodes, n) 00164 00165 CALL CreateMessageGroup(StageMessageGroups(iSendOverlappingChildrenToNewNodes,n)%p, TRANSMIT_OLC_TO_NEW_NODES,STAGE_SEND,n) 00166 MessageGroup=>StageMessageGroups(iSendOverlappingChildrenToNewNodes,n)%p 00167 00168 !IF ((n == 1) .AND. (MPI_id == 7)) PRINT "('Proc ', i1, ' posted OLC_TNN send for level ', i2, '.')", MPI_id, n 00169 00170 00171 nodelist=>OldNodes(n)%p 00172 00173 DO WHILE (associated(nodelist)) 00174 node=>nodelist%self 00175 overlaplist=>node%overlaps 00176 00177 DO WHILE (associated(overlaplist)) 00178 overlap=>overlaplist%self 00179 !IF ((n == 1) .AND. (MPI_id == 7)) PRINT "('PostSendOverlappingChildren::overlap = [', i1, '][', 6i4, '].')", overlap%box%MPI_id, overlap%box%mGlobal 00180 IF (overlap%box%MPI_ID /= MPI_ID) THEN 00181 CALL ExtractMessageFromGroup(MessageGroup, overlap%box%MPI_ID, message) 00182 !IF ((n == 1) .AND. (MPI_id == 7)) PRINT "('Proc ', i1, ', level ', i2, ' added OLC_TNN send for remote proc ', i1, '.')", MPI_id, n, overlap%box%MPI_id 00183 CALL SendOverlappingChildren(message,node,overlap) 00184 END IF 00185 overlaplist=>overlaplist%next 00186 END DO 00187 nodelist=>nodelist%next 00188 END DO 00189 CALL SendTerminationBox(MessageGroup) 00190 CALL CloseMessageGroup(MessageGroup) 00191 00192 CALL StopTimer(iiSendOverlappingChildrenToNewNodes, n) 00193 END SUBROUTINE PostSendOverlappingChildrenToNewNodes 00194 00195 00196 SUBROUTINE CompSendOverlappingChildrenToNewNodes(n) 00197 INTEGER :: n 00198 CALL StartTimer(iiSendOverlappingChildrenToNewNodes, n) 00199 CALL DestroyMessageGroup(StageMessageGroups(iSendOverlappingChildrenToNewNodes,n)%p) 00200 CALL StopTimer(iiSendOverlappingChildrenToNewNodes, n) 00201 END SUBROUTINE CompSendOverlappingChildrenToNewNodes 00202 00203 SUBROUTINE PostRecvOverlappingChildrenFromOldNodes(n) 00204 INTEGER :: n 00205 TYPE(NodeDef), POINTER :: node, overlap 00206 TYPE(NodeDefList), POINTER :: nodelist, overlaplist 00207 TYPE(StageMessageGroup), Pointer ::MessageGroup 00208 TYPE(PackedMessage), POINTER :: message 00209 CALL StartTimer(iiRecvOverlappingChildrenFromOldNodes, n) 00210 00211 CALL CreateMessageGroup(StageMessageGroups(iRecvOverlappingChildrenFromOldNodes,n)%p, TRANSMIT_OLC_TO_NEW_NODES,STAGE_RECV,n) 00212 MessageGroup=>StageMessageGroups(iRecvOverlappingChildrenFromOldNodes,n)%p 00213 00214 nodelist=>Nodes(n)%p 00215 DO WHILE (associated(nodelist)) 00216 node=>nodelist%self 00217 overlaplist=>node%overlaps 00218 DO WHILE (associated(overlaplist)) 00219 overlap=>overlaplist%self 00220 IF (overlap%box%MPI_ID /= MPI_ID) THEN 00221 CALL ExtractMessageFromGroup(MessageGroup, overlap%box%MPI_ID, message) 00222 END IF 00223 overlaplist=>overlaplist%next 00224 END DO 00225 nodelist=>nodelist%next 00226 END DO 00227 CALL StopTimer(iiRecvOverlappingChildrenFromOldNodes, n) 00228 END SUBROUTINE PostRecvOverlappingChildrenFromOldNodes 00229 00230 SUBROUTINE CompRecvOverlappingChildrenFromOldNodes(n) 00231 INTEGER :: n 00232 TYPE(StageMessageGroup), Pointer :: sm_group 00233 TYPE(PackedMessage), POINTER :: message 00234 00235 CALL StartTimer(iiRecvOverlappingChildrenFromOldNodes, n) 00236 sm_group=>StageMessageGroups(iRecvOverlappingChildrenFromOldNodes,n)%p 00237 CALL MGBlockOnFirstMessages(sm_group, message) 00238 00239 DO WHILE (ASSOCIATED(message)) 00240 CALL RecvOverlappingChildrenFromOldNodes(message) 00241 CALL MGBlockOnFirstMessages(sm_group, message) 00242 END DO 00243 00244 CALL DestroyMessageGroup(StageMessageGroups(iRecvOverlappingChildrenFromOldNodes,n)%p) 00245 CALL StopTimer(iiRecvOverlappingChildrenFromOldNodes, n) 00246 00247 END SUBROUTINE CompRecvOverlappingChildrenFromOldNodes 00248 00249 00251 00254 00255 00258 SUBROUTINE PostSendOverlappingChildrenToOldNodes(n) 00259 INTEGER :: n 00260 TYPE(NodeDef), POINTER :: node, overlap 00261 TYPE(NodeDefList), POINTER :: nodelist, overlaplist 00262 TYPE(StageMessageGroup), Pointer ::MessageGroup 00263 TYPE(PackedMessage), POINTER :: message 00264 CALL StartTimer(iiSendOverlappingChildrenToOldNodes, n) 00265 00266 CALL CreateMessageGroup(StageMessageGroups(iSendOverlappingChildrenToOldNodes,n)%p, TRANSMIT_OLC_TO_OLD_NODES,STAGE_SEND,n) 00267 MessageGroup=>StageMessageGroups(iSendOverlappingChildrenToOldNodes,n)%p 00268 00269 nodelist=>Nodes(n)%p 00270 DO WHILE (associated(nodelist)) 00271 node=>nodelist%self 00272 overlaplist=>node%overlaps 00273 DO WHILE (associated(overlaplist)) 00274 overlap=>overlaplist%self 00275 IF (overlap%box%MPI_ID /= MPI_ID) THEN 00276 CALL ExtractMessageFromGroup(MessageGroup, overlap%box%MPI_ID, message) 00277 CALL SendOverlappingChildren(message,node,overlap) 00278 END IF 00279 overlaplist=>overlaplist%next 00280 END DO 00281 nodelist=>nodelist%next 00282 END DO 00283 CALL SendTerminationBox(MessageGroup) 00284 CALL CloseMessageGroup(MessageGroup) 00285 CALL StopTimer(iiSendOverlappingChildrenToOldNodes, n) 00286 00287 END SUBROUTINE PostSendOverlappingChildrenToOldNodes 00288 00289 SUBROUTINE CompSendOverlappingChildrenToOldNodes(n) 00290 INTEGER :: n 00291 CALL StartTimer(iiSendOverlappingChildrenToOldNodes, n) 00292 CALL DestroyMessageGroup(StageMessageGroups(iSendOverlappingChildrenToOldNodes,n)%p) 00293 CALL StopTimer(iiSendOverlappingChildrenToOldNodes, n) 00294 END SUBROUTINE CompSendOverlappingChildrenToOldNodes 00295 00296 00297 SUBROUTINE PostRecvOverlappingChildrenFromNewNodes(n) 00298 INTEGER :: n 00299 TYPE(NodeDef), POINTER :: node, overlap 00300 TYPE(NodeDefList), POINTER :: nodelist, overlaplist 00301 TYPE(StageMessageGroup), Pointer ::MessageGroup 00302 TYPE(PackedMessage), POINTER :: message 00303 CALL StartTimer(iiRecvOverlappingChildrenFromNewNodes, n) 00304 CALL CreateMessageGroup(StageMessageGroups(iRecvOverlappingChildrenFromNewNodes,n)%p, TRANSMIT_OLC_TO_OLD_NODES,STAGE_RECV,n) 00305 MessageGroup=>StageMessageGroups(iRecvOverlappingChildrenFromNewNodes,n)%p 00306 00307 nodelist=>OldNodes(n)%p 00308 DO WHILE (associated(nodelist)) 00309 node=>nodelist%self 00310 overlaplist=>node%overlaps 00311 DO WHILE (associated(overlaplist)) 00312 overlap=>overlaplist%self 00313 00314 !IF ((n == 1) .AND. (MPI_id == 0)) PRINT "('PostRecvOverlappingChildren::overlap = [', i1, '][', 6i4, '].')", overlap%box%MPI_id, overlap%box%mGlobal 00315 IF (overlap%box%MPI_ID /= MPI_ID) CALL ExtractMessageFromGroup(MessageGroup, overlap%box%MPI_ID, message) 00316 overlaplist=>overlaplist%next 00317 END DO 00318 nodelist=>nodelist%next 00319 END DO 00320 CALL StopTimer(iiRecvOverlappingChildrenFromNewNodes, n) 00321 END SUBROUTINE PostRecvOverlappingChildrenFromNewNodes 00322 00323 SUBROUTINE CompRecvOverlappingChildrenFromNewNodes(n) 00324 INTEGER :: n 00325 TYPE(StageMessageGroup), Pointer :: sm_group 00326 TYPE(PackedMessage), POINTER :: message 00327 CALL StartTimer(iiRecvOverlappingChildrenFromNewNodes, n) 00328 sm_group=>StageMessageGroups(iRecvOverlappingChildrenFromNewNodes,n)%p 00329 CALL MGBlockOnFirstMessages(sm_group, message) 00330 00331 DO WHILE (ASSOCIATED(message)) 00332 CALL RecvOverlappingChildrenFromNewNodes(message) 00333 CALL MGBlockOnFirstMessages(sm_group, message) 00334 END DO 00335 00336 CALL DestroyMessageGroup(StageMessageGroups(iRecvOverlappingChildrenFromNewNodes,n)%p) 00337 00338 CALL StopTimer(iiRecvOverlappingChildrenFromNewNodes, n) 00339 END SUBROUTINE CompRecvOverlappingChildrenFromNewNodes 00340 00342 00345 00346 00349 SUBROUTINE PostSendGridsToChildren(n) 00350 INTEGER :: n, i 00351 TYPE(StageMessageGroup), Pointer ::MessageGroup 00352 TYPE(PackedMessage), POINTER :: message 00353 LOGICAL, DIMENSION(:,:), POINTER :: ChildChildArray 00354 LOGICAL, DIMENSION(:), POINTER :: GrandChildArray 00355 TYPE(NodeDefList), POINTER :: nodelist,childlist 00356 TYPE(NodeDef), POINTER :: node,child 00357 CALL StartTimer(iiSendGridsToChildren, n) 00358 00359 levels(n+1)%MPI_COMM=levels(n)%MPI_COMM 00360 CALL CreateMessageGroup(StageMessageGroups(iSendGridsToChildren,n)%p, TRANSMIT_CHILD_GRIDS, STAGE_SEND,n) 00361 MessageGroup=>StageMessageGroups(iSendGridsToChildren,n)%p 00362 00363 IF (ASSOCIATED(ChildProcs(n)%p)) THEN 00364 DO i=1,size(ChildProcs(n)%p) 00365 IF (ChildPRocs(n)%p(i) /= MPI_ID) CALL ExtractMessageFromGroup(MessageGroup, ChildProcs(n)%p(i), Message) 00366 END DO 00367 END IF 00368 nodelist=>Nodes(n)%p 00369 00370 DO WHILE (associated(nodelist)) 00371 node=>nodelist%self 00372 childlist=>node%children 00373 00374 DO WHILE (associated(childlist)) 00375 child=>childlist%self 00376 IF (child%box%MPI_ID /= MPI_ID) THEN 00377 CALL ExtractMessageFromGroup(MessageGroup, child%box%MPI_ID, Message) 00378 CALL SendGridToChild(message,child) 00379 END IF 00380 childlist=>childlist%next 00381 END DO 00382 00383 nodelist=>nodelist%next 00384 END DO 00385 00386 CALL SendTerminationBox(MessageGroup) 00387 CALL CloseMessageGroup(MessageGroup) 00388 00389 00390 CALL StopTimer(iiSendGridsToChildren, n) 00391 00392 END SUBROUTINE PostSendGridsToChildren 00393 00394 SUBROUTINE CompSendGridsToChildren(n) 00395 00396 INTEGER :: n 00397 CALL StartTimer(iiSendGridsToChildren, n) 00398 CALL DestroyMessageGroup(StageMessageGroups(iSendGridsToChildren,n)%p) 00399 CALL StopTimer(iiSendGridsToChildren, n) 00400 END SUBROUTINE CompSendGridsToChildren 00401 00402 00403 SUBROUTINE PostRecvGridsFromParents(n) 00404 INTEGER :: n, i 00405 TYPE(StageMessageGroup), POINTER ::MessageGroup 00406 TYPE(PackedMessage), POINTER :: message 00407 CALL StartTimer(iiRecvGridsFromParents, n) 00408 ! Creates a message group to manage this processor's open receives. 00409 CALL CreateMessageGroup(StageMessageGroups(iRecvGridsFromParents,n)%p, TRANSMIT_CHILD_GRIDS, STAGE_RECV,n-1) 00410 MessageGroup=>StageMessageGroups(iRecvGridsFromParents,n)%p 00411 00412 IF (ASSOCIATED(ParentProcs(n)%p)) THEN 00413 DO i=1,size(ParentProcs(n)%p) 00414 IF (ParentProcs(n)%p(i) /= MPI_ID) CALL ExtractMessageFromGroup(MessageGroup,ParentProcs(n)%p(i),message) 00415 END DO 00416 END IF 00417 00418 CALL StopTimer(iiRecvGridsFromParents, n) 00419 00420 END SUBROUTINE PostRecvGridsFromParents 00421 00422 SUBROUTINE CompRecvGridsFromParents(n) 00423 INTEGER :: n 00424 TYPE(StageMessageGroup), Pointer :: sm_group 00425 TYPE(PackedMessage), POINTER :: message 00426 LOGICAL, DIMENSION(:), POINTER :: NewParentsArray 00427 CALL StartTimer(iiRecvGridsFromParents, n) 00428 00429 sm_group => StageMessageGroups(iRecvGridsFromParents,n)%p 00430 00431 ! Retrieve first message from group. 00432 CALL MGBlockOnFirstMessages(sm_group, message) 00433 00434 ! Continue processing messages until there are no more open messages. 00435 DO WHILE (ASSOCIATED(message)) 00436 CALL RecvGridsFromParent(message) 00437 CALL MGBlockOnFirstMessages(sm_group, message) 00438 END DO 00439 00440 00441 ! Close all open handles and destroy the message group. 00442 CALL DestroyMessageGroup(StageMessageGroups(iRecvGridsFromParents,n)%p) 00443 CALL StopTimer(iiRecvGridsFromParents, n) 00444 00445 00446 END SUBROUTINE CompRecvGridsFromParents 00447 00449 00452 00455 SUBROUTINE PostSendOverlapsNeighbors(n) 00456 INTEGER :: n 00457 TYPE(NodeDef), POINTER :: node, child 00458 TYPE(NodeDefList), POINTER :: childlist, nodelist 00459 TYPE(StageMessageGroup), POINTER ::MessageGroup 00460 TYPE(PackedMessage), POINTER :: message 00461 CALL StartTimer(iiSendOverlapsNeighbors, n) 00462 00463 CALL CreateMessageGroup(StageMessageGroups(iSendOverlapsNeighbors,n)%p, TRANSMIT_OVERLAPS_NEIGHBORS,STAGE_SEND,n) 00464 MessageGroup=>StageMessageGroups(iSendOverlapsNeighbors,n)%p 00465 nodelist=>Nodes(n)%p 00466 00467 DO WHILE (associated(nodelist)) 00468 node=>nodelist%self 00469 childlist=>node%children 00470 00471 DO WHILE (associated(childlist)) 00472 child=>childlist%self 00473 IF (child%box%MPI_ID /= MPI_ID) THEN 00474 CALL ExtractMessageFromGroup(MessageGroup, child%box%MPI_ID, Message) 00475 CALL SendOverlapsNeighborsToChild(message,child) 00476 END IF 00477 childlist=>childlist%next 00478 END DO 00479 00480 nodelist=>nodelist%next 00481 END DO 00482 00483 CALL SendTerminationBox(MessageGroup) 00484 CALL CloseMessageGroup(MessageGroup) 00485 00486 CALL StopTimer(iiSendOverlapsNeighbors, n) 00487 00488 END SUBROUTINE PostSendOverlapsNeighbors 00489 00490 SUBROUTINE CompSendOverlapsNeighbors(n) 00491 INTEGER :: n 00492 CALL StartTimer(iiSendOverlapsNeighbors, n) 00493 CALL DestroyMessageGroup(StageMessageGroups(iSendOverlapsNeighbors,n)%p) 00494 CALL StopTimer(iiSendOverlapsNeighbors, n) 00495 END SUBROUTINE CompSendOverlapsNeighbors 00496 00497 SUBROUTINE PostRecvOverlapsNeighbors(n) 00498 INTEGER :: n 00499 TYPE(StageMessageGroup), Pointer ::MessageGroup 00500 TYPE(PackedMessage), POINTER :: Message 00501 TYPE(NodeDefList), POINTER :: nodelist 00502 TYPE(NodeDef), POINTER :: node 00503 CALL StartTimer(iiRecvOverlapsNeighbors, n) 00504 00505 CALL CreateMessageGroup(StageMessageGroups(iRecvOverlapsNeighbors,n)%p, TRANSMIT_OVERLAPS_NEIGHBORS,STAGE_RECV,n-1) 00506 MessageGroup=>StageMessageGroups(iRecvOverlapsNeighbors,n)%p 00507 00508 nodelist=>Nodes(n)%p 00509 DO WHILE (ASSOCIATED(nodelist)) 00510 node=>nodelist%self 00511 IF (node%parent%box%MPI_ID /= MPI_ID) CALL ExtractMessageFromGroup(MessageGroup,node%parent%box%MPI_ID, message) 00512 nodelist=>nodelist%next 00513 END DO 00514 00515 CALL StopTimer(iiRecvOverlapsNeighbors, n) 00516 END SUBROUTINE PostRecvOverlapsNeighbors 00517 00518 SUBROUTINE CompRecvOverlapsNeighbors(n) 00519 INTEGER :: n 00520 TYPE(StageMessageGroup), Pointer :: sm_group 00521 TYPE(PackedMessage), POINTER :: message 00522 TYPE(NodeDefList), POINTER :: testlist, testneighborlist 00523 TYPE(NodeDef), POINTER :: testnode 00524 CALL StartTimer(iiRecvOverlapsNeighbors,n) 00525 sm_group=>StageMessageGroups(iRecvOverlapsNeighbors,n)%p 00526 00527 CALL MGBlockOnFirstMessages(sm_group, message) 00528 00529 DO WHILE (ASSOCIATED(message)) 00530 CALL RecvOverlapsNeighbors(message) 00531 CALL MGBlockOnFirstMessages(sm_group, message) 00532 END DO 00533 00534 CALL DestroyMessageGroup(StageMessageGroups(iRecvOverlapsNeighbors,n)%p) 00535 CALL StopTimer(iiRecvOverlapsNeighbors,n) 00536 END SUBROUTINE CompRecvOverlapsNeighbors 00538 00539 00545 00546 SUBROUTINE PostSendOverlapsToOldNodesChildren(n) 00547 00548 INTEGER :: n 00549 TYPE(NodeDef), POINTER :: node, child 00550 TYPE(NodeDefList), POINTER :: childlist, nodelist 00551 TYPE(StageMessageGroup), POINTER :: MessageGroup 00552 TYPE(PackedMessage), POINTER :: message 00553 CALL StartTimer(iiSendOverlapsToOldNodesChildren, n) 00554 00555 CALL CreateMessageGroup(StageMessageGroups(iSendOverlapsToOldNodesChildren,n)%p, TRANSMIT_OLD_NODE_OVERLAPS,STAGE_SEND,n) 00556 MessageGroup=>StageMessageGroups(iSendOverlapsToOldNodesChildren,n)%p 00557 00558 nodelist=>OldNodes(n)%p 00559 DO WHILE (associated(nodelist)) 00560 node=>nodelist%self 00561 childlist=>node%children 00562 00563 DO WHILE (associated(childlist)) 00564 child=>childlist%self 00565 IF (child%box%MPI_ID /= MPI_ID) THEN 00566 CALL ExtractMessageFromGroup(MessageGroup, child%box%MPI_ID, Message) 00567 CALL SendOverlapsToChild(message, child) 00568 END IF 00569 childlist=>childlist%next 00570 END DO 00571 nodelist=>nodelist%next 00572 END DO 00573 00574 CALL SendTerminationBox(MessageGroup) 00575 CALL CloseMessageGroup(MessageGroup) 00576 00577 CALL StopTimer(iiSendOverlapsToOldNodesChildren, n) 00578 00579 END SUBROUTINE PostSendOverlapsToOldNodesChildren 00580 00581 00582 SUBROUTINE PostSendOverlapsToNodesOldChildren(n) 00583 INTEGER :: n 00584 TYPE(NodeDef), POINTER :: node, child 00585 TYPE(NodeDefList), POINTER :: childlist, nodelist 00586 TYPE(StageMessageGroup), Pointer ::MessageGroup 00587 TYPE(PackedMessage), POINTER :: message 00588 CALL StartTimer(iiSendOverlapsToNodesOldChildren, n) 00589 00590 CALL CreateMessageGroup(StageMessageGroups(iSendOverlapsToNodesOldChildren,n)%p, TRANSMIT_OLD_NODE_OVERLAPS,STAGE_SEND,n) 00591 MessageGroup=>StageMessageGroups(iSendOverlapsToNodesOldChildren,n)%p 00592 00593 nodelist=>Nodes(n)%p 00594 00595 DO WHILE (associated(nodelist)) 00596 node=>nodelist%self 00597 childlist=>node%oldchildren 00598 00599 DO WHILE (associated(childlist)) 00600 child=>childlist%self 00601 IF (child%box%MPI_ID /= MPI_ID) THEN 00602 CALL ExtractMessageFromGroup(MessageGroup, child%box%MPI_ID, Message) 00603 CALL SendOverlapsToChild(message, child) 00604 END IF 00605 childlist=>childlist%next 00606 END DO 00607 nodelist=>nodelist%next 00608 END DO 00609 00610 CALL SendTerminationBox(MessageGroup) 00611 CALL CloseMessageGroup(MessageGroup) 00612 00613 CALL StopTimer(iiSendOverlapsToNodesOldChildren, n) 00614 END SUBROUTINE PostSendOverlapsToNodesOldChildren 00615 00616 SUBROUTINE CompSendOverlapsToOldNodesChildren(n) 00617 INTEGER :: n 00618 CALL StartTimer(iiSendOverlapsToOldNodesChildren, n) 00619 CALL DestroyMessageGroup(StageMessageGroups(iSendOverlapsToOldNodesChildren,n)%p) 00620 CALL StopTimer(iiSendOverlapsToOldNodesChildren, n) 00621 END SUBROUTINE CompSendOverlapsToOldNodesChildren 00622 00623 00624 SUBROUTINE CompSendOverlapsToNodesOldChildren(n) 00625 INTEGER :: n 00626 CALL StartTimer(iiSendOverlapsToNodesOldChildren, n) 00627 CALL DestroyMessageGroup(StageMessageGroups(iSendOverlapsToNodesOldChildren,n)%p) 00628 CALL StopTimer(iiSendOverlapsToNodesOldChildren, n) 00629 00630 END SUBROUTINE CompSendOverlapsToNodesOldChildren 00631 00632 SUBROUTINE PostRecvOldNodeOverlaps(n) 00633 INTEGER :: n 00634 TYPE(StageMessageGroup), Pointer ::MessageGroup 00635 TYPE(PackedMessage), POINTER :: message 00636 TYPE(NodeDefList), POINTER :: nodelist 00637 TYPE(NodeDef), POINTER :: node 00638 00639 CALL StartTimer(iiRecvOldNodeOverlaps,n) 00640 00641 CALL CreateMessageGroup(StageMessageGroups(iRecvOldNodeOverlaps,n)%p, TRANSMIT_OLD_NODE_OVERLAPS,STAGE_RECV,n-1) 00642 MessageGroup=>StageMessageGroups(iRecvOldNodeOverlaps,n)%p 00643 nodelist=>OldNodes(n)%p 00644 00645 DO WHILE (ASSOCIATED(nodelist)) 00646 node=>nodelist%self 00647 IF (node%parent%box%MPI_ID /= MPI_ID) CALL ExtractMessageFromGroup(MessageGroup,node%parent%box%MPI_ID, message) 00648 nodelist=>nodelist%next 00649 END DO 00650 CALL StopTimer(iiRecvOldNodeOverlaps,n) 00651 END SUBROUTINE PostRecvOldNodeOverlaps 00652 00653 SUBROUTINE CompRecvOldNodeOverlaps(n) 00654 INTEGER :: n 00655 TYPE(StageMessageGroup), Pointer :: sm_group 00656 TYPE(PackedMessage), POINTER :: message 00657 CALL StartTimer(iiRecvOldNodeOverlaps,n) 00658 00659 sm_group=>StageMessageGroups(iRecvOldNodeOverlaps,n)%p 00660 CALL MGBlockOnFirstMessages(sm_group, message) 00661 00662 DO WHILE (ASSOCIATED(message)) 00663 CALL RecvOldNodeOverlaps(message) 00664 CALL MGBlockOnFirstMessages(sm_group, message) 00665 END DO 00666 00667 CALL DestroyMessageGroup(StageMessageGroups(iRecvOldNodeOverlaps,n)%p) 00668 00669 CALL StopTimer(iiRecvOldNodeOverlaps,n) 00670 END SUBROUTINE CompRecvOldNodeOverlaps 00672 00673 00674 SUBROUTINE PackTest 00675 00676 TYPE(StageMessageGroup), POINTER :: sm_group 00677 TYPE(PackedMessage), POINTER :: message 00678 ! REAL(KIND=qPrec), DIMENSION(:,:,:,:), POINTER :: payload 00679 ! REAL, POINTER, DIMENSION(:,:,:,:) :: payload 00680 INTEGER, POINTER, DIMENSION(:,:,:,:) :: payload 00681 INTEGER :: proc 00682 INTEGER :: i,j,k,m,counter 00683 00684 00685 ALLOCATE(payload(8,8,8,8)) 00686 ! payload = -1.d0 00687 ! payload = -1.0 00688 payload = -1 00689 00690 IF (MODULO(MPI_id, 2) == 0) THEN 00691 00692 NULLIFY(message) 00693 00694 CALL CreateMessageGroup(sm_group, 5000, STAGE_SEND,0) 00695 00696 00697 NULLIFY(message) 00698 00699 DO proc = 1, MPI_np - 1, 2 00700 CALL ExtractMessageFromGroup(sm_group, proc, message) 00701 END DO 00702 00703 DO proc = 1, MPI_np - 1, 2 00704 CALL ExtractMessageFromGroup(sm_group, proc, message) 00705 ! payload = REAL(MPI_id) 00706 ! payload = REAL(MPI_id) 00707 ! payload = MPI_id 00708 counter = 0 00709 DO m = 1, 8 00710 DO k = 1, 8 00711 DO j = 1, 8 00712 DO i = 1, 8 00713 counter = counter + 1 00714 ! payload(i,j,k,m) = REAL(counter, KIND=qPrec) 00715 payload(i,j,k,m) = counter 00716 END DO 00717 END DO 00718 END DO 00719 END DO 00720 ! CALL PrintPayload(payload) 00721 CALL PackData(message, payload) 00722 END DO 00723 00724 CALL CloseMessageGroup(sm_group) 00725 CALL DestroyMessageGroup(sm_group) 00726 00727 ELSE 00728 00729 CALL CreateMessageGroup(sm_group, 5000, STAGE_RECV,0) 00730 00731 NULLIFY(message) 00732 00733 DO proc = 0, MPI_np - 2, 2 00734 CALL ExtractMessageFromGroup(sm_group, proc, message) 00735 !PRINT *, "PackTest::message%closed = ", message%closed 00736 END DO 00737 00738 NULLIFY(message) 00739 00740 CALL MGBlockOnFirstMessages(sm_group, message) 00741 00742 !PRINT *, "PackTest::done message%closed = ", message%closed 00743 DO WHILE (ASSOCIATED(message)) 00744 00745 !PRINT *, "remote_proc ", message%remote_proc, " nMessages = ", message%nMessages 00746 !PRINT *, "remote_proc ", message%remote_proc, " last_block_size = ", message%last_block%buffer_size 00747 00748 ! payload = -1.d0 00749 ! payload = -1.0 00750 payload = -1 00751 CALL UnpackData(message, payload) 00752 PRINT *, "message from ", message%remote_proc 00753 CALL PrintPayload(payload) 00754 CALL MGBlockOnFirstMessages(sm_group, message) 00755 END DO 00756 00757 CALL DestroyMessageGroup(sm_group) 00758 00759 END IF 00760 00761 DEALLOCATE(payload) 00762 NULLIFY(payload) 00763 00764 END SUBROUTINE PackTest 00765 00766 SUBROUTINE PrintPayload(payload) 00767 ! REAL(KIND=qPrec), DIMENSION(:,:,:,:) :: payload 00768 ! REAL, DIMENSION(:,:,:,:) :: payload 00769 INTEGER, DIMENSION(:,:,:,:) :: payload 00770 INTEGER :: i,j,k,m 00771 00772 ! PRINT *, "proc ", MPI_id 00773 ! PRINT *, "Average payload = ", SUM(payload) * 1.0 / SIZE(payload) 00774 ! PRINT *, "Minimum payload = ", MINVAL(payload) 00775 ! PRINT *, "Maximum payload = ", MAXVAL(payload) 00776 ! PRINT *, "COUNT(0) = ", COUNT(payload == 0) 00777 ! PRINT *, "COUNT(2) = ", COUNT(payload == 2) 00778 ! PRINT *, "COUNT = ", SIZE(payload) 00779 ! PRINT * 00780 ! PRINT *, "proc ", MPI_id 00781 ! PRINT * 00782 ! DO l=1,4 00783 ! DO k=1,4 00784 ! PRINT *, "k=", k, "l=", l 00785 ! DO j=1,4 00786 ! PRINT "(' [', 4f8.5, ']')", payload(:,j,k,l) 00787 ! END DO 00788 ! PRINT * 00789 ! END DO 00790 ! END DO 00791 DO m=LBOUND(payload,4),UBOUND(payload,4) 00792 DO k=LBOUND(payload,3),UBOUND(payload,4) 00793 DO j=LBOUND(payload,2),UBOUND(payload,2) 00794 ! DO i=LBOUND(payload,1),UBOUND(payload,1) 00795 ! PRINT "('Proc ', i1, ' payload[', i2, ', ', i2, ', 1, ', i1, '] = ', f, '.')", MPI_id, i,j,m,payload(i,j,1,m) 00796 PRINT "('Proc ', i1, ' payload = [', 8I10, '].')", MPI_id, payload(:,j,k,m) 00797 END DO 00798 END DO 00799 END DO 00800 END SUBROUTINE PrintPayload 00801 00802 END MODULE TreeLevelComms 00803