Scrambler  1
tree_parsing.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_parsing.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 
00031 
00036 MODULE TreeParsing
00037    USE MPIPacking
00038    USE MessageDeclarations
00039    USE TreeNodeOps
00040 
00041    IMPLICIT NONE
00042    PUBLIC
00043 CONTAINS
00044 
00048 
00049 
00054    SUBROUTINE SendNeighboringChildren(message,node,neighbor)
00055       TYPE(NodeDef), POINTER :: node, neighbor, child
00056       TYPE(NodeDefList), POINTER :: childlist
00057       TYPE(PackedMessage), POINTER :: message
00058       INTEGER :: nChildren,level
00059 
00060       childlist=>node%children 
00061       nChildren=0 !Iterate through once to get a count
00062       level=message%level
00063       DO WHILE (associated(childlist))
00064          child=>childlist%self 
00065          IF (NephewCanBeOverlap(neighbor,child,level))  nChildren=nChildren+1
00066          childlist=>childlist%next         
00067       END DO
00068       IF (nChildren > 0) THEN
00069          CALL PackData(message, neighbor%box%mGlobal) !So the neighbor knows the parent node
00070          CALL PackData(message, node%box%mGlobal) !So the neighbor knows the parent node
00071          CALL PackData(message,nChildren)
00072          childlist=>node%children 
00073          DO WHILE (associated(childlist))
00074             child=>childlist%self 
00075             IF (NephewCanBeOverlap(neighbor,child,level)) CALL PackData(message,child%box)
00076             childlist=>childlist%next         
00077          END DO
00078       END IF
00079    END SUBROUTINE SendNeighboringChildren
00080 
00081 
00084    SUBROUTINE RecvNeighboringChildren(message)
00085       TYPE(NodeDef), POINTER :: node, neighbor, child
00086       TYPE(PackedMessage), POINTER :: message
00087       INTEGER :: nChildren,i
00088       INTEGER :: level
00089       TYPE(NodeBox) :: neighborbox, childbox, localnodebox
00090 
00091 
00092       level=message%level
00093       neighborbox%MPI_ID = message%remote_proc
00094       localnodebox%MPI_ID=MPI_ID
00095       DO WHILE(StrictGetNextBox(message, localnodebox%mGlobal, "RecvNeighboringChildren"))
00096 
00097          NULLIFY(node, neighbor)
00098 
00099          CALL StrictFindNode(level,localnodebox, node, "RecvNeighboringChildren(node)")
00100          CALL UnpackData(message,neighborbox%mGlobal)
00101 
00102          CALL StrictFindNode(level,neighborbox,neighbor, "RecvNeighboringChildren(neighbor)")
00103          CALL UnpackData(message,nChildren)
00104 
00105          DO i=1,nChildren
00106             NULLIFY(child)
00107 
00108             CALL UnPackData(message,childbox)
00109 
00110             CALL AddFindNode(level+1,childbox,child)
00111             CALL AddFindChild(neighbor,child)
00112          END DO
00113          CALL InheritNeighborChildren(node,neighbor,level)
00114       END DO
00115 
00116    END SUBROUTINE RecvNeighboringChildren
00117 
00118 
00120 
00123 
00133    SUBROUTINE SendOverlappingChildren(message,node,overlap)
00134       TYPE(NodeDef), POINTER :: node, overlap, child
00135       TYPE(NodeDefList), POINTER :: childlist
00136       TYPE(PackedMessage), POINTER :: message
00137       INTEGER :: nChildren,level
00138 
00139       childlist=>node%children 
00140       nChildren=0 !Iterate through once to get a count
00141       level=message%level
00142       DO WHILE (associated(childlist))
00143          child=>childlist%self 
00144          IF (NephewCanBeOverlap(overlap,child,level))  nChildren=nChildren+1
00145          childlist=>childlist%next         
00146       END DO
00147       IF (nChildren > 0) THEN
00148          CALL PackData(message, overlap%box%mGlobal) !So the neighbor knows the parent node
00149          CALL PackData(message, node%box%mGlobal) !So the neighbor knows the parent node
00150          CALL PackData(message,nChildren)
00151          childlist=>node%children 
00152          DO WHILE (associated(childlist))
00153             child=>childlist%self 
00154             IF (NephewCanBeOverlap(overlap,child,level)) CALL PackData(message,child%box)
00155             childlist=>childlist%next         
00156          END DO
00157       END IF
00158    END SUBROUTINE SendOverlappingChildren
00159 
00162    SUBROUTINE RecvOverlappingChildrenFromOldNodes(message)
00163       TYPE(NodeDef), POINTER :: node, overlap, child
00164       TYPE(NodeDefList), POINTER :: overlapchildlist
00165       TYPE(PackedMessage), POINTER :: message
00166       INTEGER :: nChildren,i
00167       INTEGER :: level
00168       TYPE(NodeBox) :: localnodebox, overlapbox, childbox
00169 
00170 
00171       level=message%level
00172       localnodebox%MPI_ID = MPI_ID
00173       NULLIFY(overlap)
00174 
00175 
00176       overlapbox%MPI_ID=message%remote_proc
00177 
00178       DO WHILE(StrictGetNextBox(message, localnodebox%mGlobal, "RecvOverlappingChildrenFromOldNodes"))
00179 
00180          NULLIFY(node)
00181 
00182          CALL StrictFindNode(level,localnodebox,node, "RecvOverlappingChildrenFromNodes(node)")
00183          CALL UnPackData(message, overlapbox%mGlobal)
00184          CALL StrictFindOldNode(level,overlapbox,overlap, "RecvOverlappingChildrenFromNodes(overlap)")
00185          CALL UnpackData(message, nChildren)
00186 
00187          IF (nChildren > 0) THEN
00188    
00189              DO i=1,nChildren
00190                  ! Retrieve the new child box from the packed message.
00191                  CALL UnpackData(message,childbox)
00192                  ! Find a child node on the next level up, or add one if none exists.
00193                  NULLIFY(child)
00194                  CALL AddFindOldNode(level+1, childbox, child)
00195                  ! Search for this child node within overlap's list, and add it if it isn't found.
00196                  CALL AddFindChild(overlap, child)
00197              END DO
00198 
00199              CALL InheritOverlapChildren(node,overlap,level)
00200          END IF
00201       END DO
00202 
00203    END SUBROUTINE RecvOverlappingChildrenFromOldNodes
00204 
00207    SUBROUTINE RecvOverlappingChildrenFromNewNodes(message)
00208       TYPE(NodeDef), POINTER :: node, overlap, child
00209       TYPE(NodeDefList), POINTER :: overlapchildlist
00210       TYPE(PackedMessage), POINTER :: message
00211       INTEGER :: nChildren,i
00212       INTEGER :: level
00213       TYPE(NodeBox) :: localnodebox, overlapbox, childbox
00214 
00215 
00216       level=message%level
00217       localnodebox%MPI_ID = MPI_ID
00218 
00219       NULLIFY(overlap)
00220 
00221       overlapbox%MPI_ID=message%remote_proc
00222 
00223       DO WHILE(StrictGetNextBox(message, localnodebox%mGlobal, "RecvOverlappingChildrenFromNewNodes(local)"))
00224 
00225          NULLIFY(node)
00226          NULLIFY(overlap)
00227 
00228          CALL StrictFindOldNode(level,localnodebox,node, "RecvOverlappingChildrenFromNewNodes(node)")
00229          CALL UnPackData(message, overlapbox%mGlobal)
00230          CALL StrictFindNode(level,overlapbox,overlap, "RecvOverlappingChildrenFromNewNodes(overlap)")
00231          CALL UnpackData(message, nChildren)
00232 
00233          IF (nChildren > 0) THEN
00234 
00235              DO i=1,nChildren
00236                  CALL UnpackData(message,childbox)
00237                  CALL AddFindNode(level+1, childbox, child)
00238                  ! Search for this child node within overlap's list, and add it
00239                  ! if it isn't found.
00240                  CALL AddFindChild(overlap, child)
00241              END DO
00242 
00243          END IF
00244 
00245          CALL InheritOverlapChildren(node,overlap,level)
00246       END DO
00247 
00248    END SUBROUTINE RecvOverlappingChildrenFromNewNodes
00249 
00251 
00254 
00258    SUBROUTINE SendGridToChild(message, child)
00259       TYPE(PackedMessage), POINTER :: message
00260       TYPE(NodeDef), POINTER :: child
00261 
00262       CALL PackData(Message, child%box%mGlobal)
00263 !      CALL PackList(Message, child%proclist)
00264 !      CALL PackList(Message, child%proctime)
00265       CALL PackData(Message, child%parent%box%mGlobal)      
00266 
00267    END SUBROUTINE SendGridToChild
00268 
00271    SUBROUTINE RecvGridsFromParent(message)
00272       TYPE(PackedMessage), POINTER :: message
00273       Type(NodeDef), POINTER:: node, parent
00274       TYPE(NodeBox) :: box, parentbox
00275       INTEGER :: level
00276 
00277 
00278       box%MPI_ID=MPI_ID
00279       parentbox%MPI_ID=message%remote_proc
00280 
00281       DO WHILE (StrictGetNextBox(message,box%mGlobal, "RecvGridsFromParent"))
00282          
00283          NULLIFY(node, parent)
00284          CALL AddFindNode(message%level+1,box,node)
00285          CALL UnPackData(message,parentbox%mGlobal)
00286 
00287          CALL AddFindNode(message%level,parentbox,parent)
00288          CALL AddParent(node,parent)
00289       END DO
00290 
00291    END SUBROUTINE RecvGridsFromParent
00292 
00294 
00297   
00301    SUBROUTINE SendOverlapsNeighborsToChild(Message, child)
00302       TYPE(NodeDef), POINTER :: child
00303       TYPE(PackedMessage), POINTER :: message
00304       INTEGER :: nOverlaps, nNeighbors
00305       TYPE(NodeDefList), POINTER :: nodelist
00306 
00307 
00308       CALL PackData(message, child%box%mGlobal) !Pack the child box before its overlaps and neighbors
00309       nOverlaps=NodeCount(child%overlaps)
00310 
00311       CALL PackData(message, nOverlaps)
00312 
00313       IF (nOverlaps > 0) THEN
00314          nodelist=>child%overlaps
00315          DO WHILE(ASSOCIATED(nodelist))
00316 
00317             CALL PackData(Message,nodelist%self%box)
00318             nodelist=>nodelist%next
00319          END DO
00320       END IF
00321 
00322       nNeighbors=NodeCount(child%Neighbors)
00323 
00324       CALL PackData(message, nNeighbors)
00325 
00326       IF (nNeighbors > 0) THEN
00327          nodelist=>child%neighbors
00328          DO WHILE(ASSOCIATED(nodelist))
00329             CALL PackData(Message,nodelist%self%box)
00330             nodelist=>nodelist%next
00331          END DO
00332       END IF
00333 
00334    END SUBROUTINE SendOverlapsNeighborsToChild
00335 
00338    SUBROUTINE RecvOverlapsNeighbors(message)
00339       TYPE(PackedMessage), POINTER :: message
00340       TYPE(NodeBox) :: node_box, overlapbox, neighborbox
00341       TYPE(NodeDef), POINTER :: node, overlap, neighbor
00342       INTEGER :: level, nOverlaps, nNeighbors, i
00343 
00344       level=message%level+1
00345       node_box%MPI_ID = MPI_ID
00346 
00347       DO WHILE(StrictGetNextBox(message, node_box%mGlobal, "RecvOverlapsNeighbors"))
00348 
00349          NULLIFY(node)
00350          CALL StrictFindNode(level,node_box,node, "RecvOverlapsNeighbors(node)")
00351          CALL UnpackData(message, nOverlaps)
00352 
00353          DO i=1,nOverlaps
00354             NULLIFY(overlap)
00355             CALL UnPackData(message, overlapbox)
00356             CALL AddFindOldNode(level,overlapbox,overlap)
00357             CALL AddOverlap(node, overlap)
00358          END DO
00359 
00360          CALL UnpackData(message, nNeighbors)
00361 
00362          DO i=1,nNeighbors
00363             NULLIFY(neighbor)
00364             CALL UnPackData(message, neighborbox)
00365             CALL AddFindNode(level,neighborbox,neighbor)
00366             CALL AddNeighbor(node, neighbor)
00367          END DO
00368 
00369       END DO
00370 
00371    END SUBROUTINE RecvOverlapsNeighbors
00372 
00374 
00377 
00386    SUBROUTINE SendOverlapsToChild(message, child)
00387       TYPE(PackedMessage), POINTER :: message
00388       TYPE(NodeDef), POINTER :: child
00389 
00390       INTEGER :: nOverlaps
00391       TYPE(NodeDefList), POINTER :: nodelist
00392 
00393 
00394       CALL PackData(message, child%box%mGlobal) !Pack the child box before its overlaps and neighbors
00395       nOverlaps=NodeCount(child%overlaps)
00396       CALL PackData(message, nOverlaps)
00397 
00398       nodelist=>child%overlaps
00399       DO WHILE(ASSOCIATED(nodelist))
00400          CALL PackData(Message,nodelist%self%box)
00401          nodelist=>nodelist%next
00402       END DO
00403    END SUBROUTINE SendOverlapsToChild
00404 
00405 
00408    SUBROUTINE RecvOldNodeOverlaps(message)
00409       TYPE(PackedMessage), POINTER :: message
00410       TYPE(NodeBox) :: node_box, overlapbox
00411       TYPE(NodeDef), POINTER :: node, overlap
00412       INTEGER :: level,i,nOverlaps
00413       level=message%level+1
00414       node_box%MPI_ID = MPI_ID
00415 
00416 
00417       DO WHILE(StrictGetNextBox(message, node_box%mGlobal, "RecvOldNodeOverlaps"))
00418          NULLIFY(node)
00419          CALL StrictFindOldNode(level,node_box,node, "RecvOldNodeOverlaps")
00420          CALL UnpackData(message, nOverlaps)
00421 
00422          DO i=1,nOverlaps
00423 
00424             NULLIFY(overlap)
00425 
00426             CALL UnPackData(message, overlapbox)
00427             CALL AddFindNode(level,overlapbox,overlap)
00428             CALL AddOverlap(node, overlap)
00429          END DO
00430       END DO
00431    END SUBROUTINE RecvOldNodeOverlaps
00432 
00434 
00437 
00438 
00444    SUBROUTINE FinalizeSendGridsToChildren(MessageGroup, ChildChildArray, GrandChildArray)
00445       TYPE(StageMessageGroup), POINTER :: MessageGroup
00446       TYPE(PackedMessage), POINTER :: message
00447       INTEGER, DIMENSION(:), POINTER :: NewParentList
00448       INTEGER, DIMENSION(:), POINTER :: GrandChildProcList
00449       INTEGER :: i
00450       LOGICAL, DIMENSION(:,:), POINTER :: ChildChildArray
00451       LOGICAL, DIMENSION(:), POINTER :: GrandChildArray
00452       
00453 
00454       NULLIFY(NewParentList, GrandChildProcList)
00455 
00456       CALL FindList1D(GrandChildArray, GrandChildProcList)
00457 
00458       DO i=1,size(GrandChildProcList)
00459 
00460          IF (GrandChildProcList(i) /= MPI_id) THEN
00461             CALL ExtractMessageFromGroup(MessageGroup, GrandChildProcList(i), message)
00462             CALL PackData(message, TERMINATIONBOX)
00463             IF (message%level < MaxLevel-1) THEN 
00464                CALL FindList2D(ChildChildArray,GrandChildProcList(i),NewParentList)
00465                CALL PackList(message, NewParentList)
00466                IF (ASSOCIATED(NewParentList)) THEN
00467                   DEALLOCATE(NewParentList)
00468                   NULLIFY(NewParentList)
00469                END IF
00470             END IF
00471          END IF
00472 
00473       END DO
00474 
00475       IF (ASSOCIATED(GrandChildProcList)) THEN
00476          DEALLOCATE(GrandChildProcList)
00477          NULLIFY(GrandChildProcList)
00478       END IF
00479 
00480    END SUBROUTINE FinalizeSendGridsToChildren
00481 
00486    SUBROUTINE FinalizeRecvGridsFromParents(MessageGroup, NewParentsArray)
00487       TYPE(StageMessageGroup), POINTER :: MessageGroup
00488       TYPE(PackedMessage), POINTER :: message
00489       INTEGER, DIMENSION(:), POINTER :: ParentProcList, NewParentList
00490       INTEGER :: i, n
00491       INTEGER, DIMENSION(1) :: lb, ub
00492       LOGICAL, DIMENSION(:), POINTER :: NewParentsArray
00493 
00494 
00495       NULLIFY(NewParentList, ParentProcList)
00496 
00497       CALL GetProcListAsArray(MessageGroup, ParentProcList)
00498 
00499       IF (ASSOCIATED(ParentProcList)) THEN
00500          DO i=1,size(ParentProcList)
00501 
00502             CALL ExtractMessageFromGroup(MessageGroup, ParentProcList(i), message)
00503             CALL UnpackList(message, NewParentList)
00504 
00505             lb = LBOUND(NewParentList)
00506             ub = UBOUND(NewParentList)
00507 
00508             DO n = lb(1), ub(1)
00509                NewParentsArray(NewParentList(n))=.TRUE.
00510             END DO
00511 
00512             IF (ASSOCIATED(NewParentList)) THEN
00513                DEALLOCATE(NewParentList)
00514                NULLIFY(NewParentList)
00515             END IF
00516          END DO
00517 
00518          IF (ASSOCIATED(ParentProcList)) THEN
00519             DEALLOCATE(ParentProcList)
00520             NULLIFY(ParentProcList)
00521          END IF
00522 
00523       END IF
00524 
00525    END SUBROUTINE FinalizeRecvGridsFromParents
00526 
00528 
00529    
00534    SUBROUTINE FindList2D(A,j,b)
00535       LOGICAL, DIMENSION(:,:), POINTER :: A
00536       INTEGER :: i,j
00537       INTEGER, DIMENSION(:), POINTER :: b
00538       INTEGER :: n
00539       n=COUNT(A(:,j))
00540       ALLOCATE(b(n))
00541       n=0
00542       DO i=0,size(A,1)-1
00543          IF (A(i,j)) THEN
00544             n=n+1
00545             b(n)=i
00546          END IF
00547       END DO
00548    END SUBROUTINE FindList2D
00549 
00553    SUBROUTINE FindList1D(A,b)
00554       LOGICAL, DIMENSION(:), POINTER :: A
00555       INTEGER :: i
00556       INTEGER, DIMENSION(:), POINTER :: b
00557       INTEGER :: n
00558 
00559       NULLIFY(b)
00560 
00561       IF (ASSOCIATED(A)) THEN
00562          n=COUNT(A(:))
00563          ALLOCATE(b(n))
00564          n=0
00565          DO i=0,size(A,1)-1
00566             IF (A(i)) THEN
00567                n=n+1
00568                b(n)=i
00569             END IF
00570          END DO
00571 
00572       END IF
00573 
00574    END SUBROUTINE FindList1D
00575 
00576 END MODULE TreeParsing
00577 
 All Classes Files Functions Variables