Scrambler
1
|
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