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