Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! tree_node_ops.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 00029 00032 00033 MODULE TreeNodeOps 00034 USE GlobalDeclarations, ONLY : levels, nDim, lStressTest, nDomains, Domains, MPI_NP, MPI_ID, MaxLevel, BaseLevel 00035 USE DataDeclarations, ONLY : AllocChildFixups, DeAllocChildFixups, levelup 00036 USE DataInfoOps, ONLY : NewSubGrids 00037 USE TreeDeclarations 00038 USE DistributionControl 00039 IMPLICIT NONE 00040 !Pair-wise tree operations 00041 PUBLIC :: InheritNeighborChildren, InheritOverlapChildren, InheritOverlapOldChildren, InheritOverlapNewChildren 00042 00043 !Self-wise tree operations 00044 PUBLIC :: InheritSelfNeighborChildren, InheritSelfOverlapOldChildren,InheritSelfOverlapNewChildren 00045 00046 !Single node tree operations 00047 PUBLIC :: CreateChildren, AgeNodeChildren, BackupParent, BackupChildren, RestoreParent, RestoreChildren 00048 00049 CONTAINS 00050 00051 00054 00059 SUBROUTINE InheritNeighborChildren(node,neighbor,n) 00060 TYPE(NodeDef), POINTER :: node, child, neighbor, neighborchild 00061 TYPE(NodeDefList), POINTER :: childlist, neighborchildlist 00062 INTEGER :: n 00063 00064 childlist=>node%children 00065 00066 DO WHILE (associated(childlist)) 00067 00068 child=>childlist%self 00069 00070 IF (NephewCanBeNeighbor(neighbor,child,n)) THEN 00071 neighborchildlist=>neighbor%children 00072 00073 DO WHILE (associated(neighborchildlist)) 00074 neighborchild=>neighborchildlist%self 00075 IF (Neighbors(child,neighborchild,n+1)) CALL AddNeighbor(child,neighborchild) 00076 neighborchildlist=>neighborchildlist%next 00077 END DO 00078 00079 END IF 00080 00081 childlist=>childlist%next 00082 00083 END DO 00084 00085 END SUBROUTINE InheritNeighborChildren 00086 00091 SUBROUTINE InheritOverlapChildren(node,overlap,n) 00092 TYPE(NodeDef), POINTER :: node, child, overlap, overlapchild 00093 TYPE(NodeDefList), POINTER :: childlist, overlapchildlist 00094 INTEGER :: n 00095 00096 childlist=>node%children 00097 00098 DO WHILE (associated(childlist)) 00099 00100 child=>childlist%self 00101 00102 IF (NephewCanBeOverlap(overlap,child,n)) THEN 00103 overlapchildlist=>overlap%children 00104 DO WHILE (associated(overlapchildlist)) 00105 overlapchild=>overlapchildlist%self 00106 IF (Overlaps(child,overlapchild,n+1)) CALL AddOverlap(child,overlapchild) 00107 00108 overlapchildlist=>overlapchildlist%next 00109 END DO 00110 END IF 00111 00112 childlist=>childlist%next 00113 END DO 00114 00115 END SUBROUTINE InheritOverlapChildren 00116 00117 00122 SUBROUTINE InheritOverlapOldChildren(node,overlap,n) 00123 TYPE(NodeDef), POINTER :: node, child, overlap, overlapchild 00124 TYPE(NodeDefList), POINTER :: childlist, overlapchildlist 00125 INTEGER :: n 00126 00127 childlist=>node%children 00128 DO WHILE (associated(childlist)) 00129 child=>childlist%self 00130 IF (NephewCanBeOverlap(overlap,child,n)) THEN 00131 overlapchildlist=>overlap%oldchildren 00132 DO WHILE (associated(overlapchildlist)) 00133 overlapchild=>overlapchildlist%self 00134 IF (Overlaps(child,overlapchild,n+1)) CALL AddOverlap(child,overlapchild) 00135 overlapchildlist=>overlapchildlist%next 00136 END DO 00137 END IF 00138 childlist=>childlist%next 00139 END DO 00140 00141 END SUBROUTINE InheritOverlapOldChildren 00142 00147 SUBROUTINE InheritOverlapNewChildren(node,overlap,n) 00148 TYPE(NodeDef), POINTER :: node, child, overlap, overlapchild 00149 TYPE(NodeDefList), POINTER :: childlist, overlapchildlist 00150 INTEGER :: n 00151 childlist=>node%oldchildren 00152 DO WHILE (associated(childlist)) 00153 child=>childlist%self 00154 IF (NephewCanBeOverlap(overlap,child,n)) THEN 00155 overlapchildlist=>overlap%children 00156 DO WHILE (associated(overlapchildlist)) 00157 overlapchild=>overlapchildlist%self 00158 IF (Overlaps(child,overlapchild,n+1)) CALL AddOverlap(child,overlapchild) 00159 overlapchildlist=>overlapchildlist%next 00160 END DO 00161 END IF 00162 childlist=>childlist%next 00163 END DO 00164 00165 END SUBROUTINE InheritOverlapNewChildren 00166 00170 SUBROUTINE InheritSelfNeighborChildren(node,n) 00171 TYPE(NodeDef), POINTER :: node, child, sibling 00172 TYPE(NodeDefList), POINTER :: childlist, siblinglist 00173 INTEGER :: n 00174 childlist=>node%children 00175 DO WHILE (associated(childlist)) 00176 child=>childlist%self 00177 siblinglist=>childlist%next 00178 DO WHILE (associated(siblinglist)) 00179 sibling=>siblinglist%self 00180 IF (Neighbors(child,sibling,n+1)) CALL AddNeighbor(child,sibling) 00181 IF (Neighbors(child,sibling,n+1)) CALL AddNeighbor(sibling,child) 00182 siblinglist=>siblinglist%next 00183 END DO 00184 childlist=>childlist%next 00185 END DO 00186 END SUBROUTINE InheritSelfNeighborChildren 00187 00188 00192 SUBROUTINE InheritSelfOverlapOldChildren(node,n) 00193 TYPE(NodeDef), POINTER :: node, child, overlapchild 00194 TYPE(NodeDefList), POINTER :: childlist, overlapchildlist 00195 INTEGER :: n 00196 00197 childlist=>node%children 00198 DO WHILE (associated(childlist)) 00199 child=>childlist%self 00200 overlapchildlist=>node%oldchildren 00201 DO WHILE (associated(overlapchildlist)) 00202 overlapchild=>overlapchildlist%self 00203 IF (Overlaps(child,overlapchild,n+1)) THEN 00204 CALL AddOverlap(child,overlapchild) 00205 END IF 00206 overlapchildlist=>overlapchildlist%next 00207 END DO 00208 childlist=>childlist%next 00209 END DO 00210 END SUBROUTINE InheritSelfOverlapOldChildren 00211 00215 SUBROUTINE InheritSelfOverlapNewChildren(node,n) 00216 TYPE(NodeDef), POINTER :: node, child, overlapchild 00217 TYPE(NodeDefList), POINTER :: childlist, overlapchildlist 00218 INTEGER :: n 00219 00220 childlist=>node%children 00221 DO WHILE (associated(childlist)) 00222 child=>childlist%self 00223 overlapchildlist=>node%oldchildren 00224 DO WHILE (associated(overlapchildlist)) 00225 overlapchild=>overlapchildlist%self 00226 IF (Overlaps(child,overlapchild,n+1)) THEN 00227 CALL AddOverlap(overlapchild,child) 00228 END IF 00229 overlapchildlist=>overlapchildlist%next 00230 END DO 00231 childlist=>childlist%next 00232 END DO 00233 END SUBROUTINE InheritSelfOverlapNewChildren 00235 00236 00239 00243 SUBROUTINE CreateChildren(node,n) 00244 INTEGER :: n, step 00245 TYPE(NodeDef), POINTER :: node, child 00246 INTEGER, POINTER, DIMENSION(:,:,:) :: childgrids 00247 TYPE(NodeBox), POINTER :: child_box 00248 INTEGER :: iErr,j,i,k 00249 INTEGER :: nprocs = 0 00250 INTEGER :: nchildren 00251 step=levels(n)%step 00252 00253 NULLIFY(child) 00254 NULLIFY(childgrids) 00255 NULLIFY(child_box) 00256 00257 IF (n >= -2) THEN 00258 IF (lRegrid .AND. n == 0) THEN 00259 nchildren=1 00260 ALLOCATE(childgrids(3,2,nChildren)) 00261 childgrids(:,:,1)=node%box%mGlobal-spread(node%box%mGlobal(:,1), 2, 2)+1 00262 ELSEIF (lStressTest) THEN 00263 IF (n == -2) THEN 00264 nchildren=nDomains 00265 ALLOCATE(childgrids(3,2,nchildren)) 00266 DO j=1,nChildren 00267 childgrids(:,:,j)=Domains(j)%mGlobal 00268 END DO 00269 ELSE IF (n == -1) THEN 00270 ! nchildren=1 00271 ! ALLOCATE(childgrids(3,2,1)) 00272 ! childgrids(:,:,1)=node%box%mGlobal 00273 IF (nDim == 2) THEN 00274 IF (MPI_NP<=2) THEN 00275 nchildren=1 00276 ALLOCATE(childgrids(3,2,nchildren)) 00277 childgrids=1 00278 childgrids(1:2,:,1)=RESHAPE((/1,1,8,8/),(/2,2/)) 00279 ! childgrids(1:2,:,2)=RESHAPE((/17,1,32,16/),(/2,2/)) 00280 ! childgrids(1:2,:,1)=RESHAPE((/1,1,32,16/),(/2,2/)) 00281 ELSE IF (MPI_NP==4) THEN 00282 nchildren=4 00283 ALLOCATE(childgrids(3,2,4)) 00284 childgrids=1 00285 childgrids(1:2,:,1)=RESHAPE((/1,1,16,8/),(/2,2/)) 00286 childgrids(1:2,:,2)=RESHAPE((/17,1,32,8/),(/2,2/)) 00287 childgrids(1:2,:,3)=RESHAPE((/1,9,16,16/),(/2,2/)) 00288 childgrids(1:2,:,4)=RESHAPE((/17,9,32,16/),(/2,2/)) 00289 END IF 00290 ELSEIF (nDim == 3) THEN 00291 IF (MPI_NP<=2) THEN 00292 nchildren=2!1 00293 ALLOCATE(childgrids(3,2,nchildren)) 00294 childgrids(1:3,:,1)=RESHAPE((/1,1,1,16,16,16/),(/3,2/)) 00295 childgrids(1:3,:,2)=RESHAPE((/17,1,1,32,16,16/),(/3,2/)) 00296 ! childgrids(1:3,:,1)=RESHAPE((/1,1,1,32,16,16/),(/3,2/)) 00297 ELSEIF (MPI_NP == 4) THEN 00298 nchildren=4 00299 ALLOCATE(childgrids(3,2,4)) 00300 childgrids(1:3,:,1)=RESHAPE((/1,1,1,16,8,16/),(/3,2/)) 00301 childgrids(1:3,:,2)=RESHAPE((/17,1,1,32,8,16/),(/3,2/)) 00302 childgrids(1:3,:,3)=RESHAPE((/1,9,1,16,16,16/),(/3,2/)) 00303 childgrids(1:3,:,4)=RESHAPE((/17,9,1,32,16,16/),(/3,2/)) 00304 END IF 00305 END IF 00306 ELSEIF (n == 0) THEN 00307 nchildren=1 00308 ALLOCATE(childgrids(3,2,1)) 00309 childgrids=1 00310 IF (nDim == 2) THEN 00311 IF (MPI_NP==4) THEN 00312 IF (ALL(node%box%mGlobal(1:2,1)==(/1,1/))) THEN 00313 childgrids(1:2,:,1)=RESHAPE((/9,5,16,8/),(/2,2/)) 00314 ELSEIF (ALL(node%box%mGlobal(1:2,1)==(/1,9/))) THEN 00315 childgrids(1:2,:,1)=RESHAPE((/9,1,16,4/),(/2,2/)) 00316 ELSEIF (ALL(node%box%mGlobal(1:2,1)==(/17,1/))) THEN 00317 childgrids(1:2,:,1)=RESHAPE((/1,5,8,8/),(/2,2/)) 00318 ELSEIF (ALL(node%box%mGlobal(1:2,1)==(/17,9/))) THEN 00319 childgrids(1:2,:,1)=RESHAPE((/1,1,8,4/),(/2,2/)) 00320 END IF 00321 ELSEIF (MPI_NP<=2) THEN 00322 ! write(*,*) MPI_ID, node%box%mGlobal 00323 IF (LevelBalance(1)== 0) THEN 00324 IF (ALL(node%box%mGlobal(1:2,1)==(/1,1/))) THEN 00325 childgrids(1:2,:,1)=RESHAPE((/3,3,4,6/),(/2,2/)) 00326 ELSE 00327 childgrids(1:2,:,1)=RESHAPE((/1,3,2,6/),(/2,2/)) 00328 END IF 00329 ELSE 00330 IF (ALL(node%box%mGlobal(1:2,1)==(/1,1/))) THEN 00331 childgrids(1:2,:,1)=RESHAPE((/3,3,6,6/),(/2,2/)) 00332 ELSEIF (ALL(node%box%mGlobal(1:2,1)==(/17,1/))) THEN 00333 childgrids(1:2,:,1)=RESHAPE((/5,7,9,10/),(/2,2/)) 00334 END IF 00335 END IF 00336 END IF 00337 ELSEIF (nDim == 3) THEN 00338 IF (MPI_NP==4) THEN 00339 IF (ALL(node%box%mGlobal(1:3,1)==(/1,1,1/))) THEN 00340 childgrids(1:3,:,1)=RESHAPE((/9,5,1,16,8,1/),(/3,2/)) 00341 ELSEIF (ALL(node%box%mGlobal(1:3,1)==(/1,9,1/))) THEN 00342 childgrids(1:3,:,1)=RESHAPE((/9,1,1,16,4,1/),(/3,2/)) 00343 ELSEIF (ALL(node%box%mGlobal(1:3,1)==(/17,1,1/))) THEN 00344 childgrids(1:3,:,1)=RESHAPE((/1,5,1,8,8,1/),(/3,2/)) 00345 ELSEIF (ALL(node%box%mGlobal(1:3,1)==(/17,9,1/))) THEN 00346 childgrids(1:3,:,1)=RESHAPE((/1,1,1,8,4,1/),(/3,2/)) 00347 END IF 00348 ELSEIF (MPI_NP<=2) THEN 00349 IF (ALL(node%box%mGlobal(1:3,1)==(/1,1,1/))) THEN 00350 childgrids(1:3,:,1)=RESHAPE((/13,7,7,16,10,10/),(/3,2/)) 00351 ELSEIF (ALL(node%box%mGlobal(1:3,1)==(/17,1,1/))) THEN 00352 childgrids(1:3,:,1)=RESHAPE((/5,7,7,9,10,10/),(/3,2/)) 00353 END IF 00354 END IF 00355 END IF 00356 ELSEIF (n == 1) THEN 00357 IF (MPI_NP<=2) THEN 00358 IF (ALL(node%box%mGlobal(1:2,1)==(/25,13/))) THEN 00359 nchildren=1 00360 ALLOCATE(childgrids(3,2,1)) 00361 childgrids=1 00362 childgrids(1:2,:,1)=RESHAPE((/1,1,4,4/),(/2,2/)) 00363 ELSE 00364 nchildren=0 00365 END IF 00366 END IF 00367 ELSE 00368 CALL NewSubGrids(node%info, nchildren, childgrids) 00369 END IF 00370 ELSE 00371 IF (n == -2) THEN 00372 nchildren=nDomains 00373 ALLOCATE(childgrids(3,2,nchildren)) 00374 DO j=1,nChildren 00375 childgrids(:,:,j)=Domains(j)%mGlobal 00376 END DO 00377 ELSE IF (n == -1) THEN 00378 ! IF (ASSOCIATED(node%proclist)) THEN 00379 ! nprocs = SIZE(node%proclist) 00380 ! END IF 00381 ! nchildren=2 00382 ! ALLOCATE(childgrids(3,2,nchildren)) 00383 ! childgrids(:,:,1)=reshape((/1,1,1,16,16,8/),(/3,2/)) 00384 ! childgrids(:,:,2)=reshape((/1,1,9,16,16,16/),(/3,2/)) 00385 00386 nchildren=1 00387 ALLOCATE(childgrids(3,2,nchildren)) 00388 childgrids(:,:,1)=node%box%mGlobal 00389 ELSE 00390 CALL NewSubGrids(node%info, nchildren, childgrids) 00391 END IF 00392 END IF 00393 00394 IF (nChildren > 0) THEN 00395 CALL CreateNodeBox(node%box%mGlobal, child_box, MPI_ID) 00396 DO j=1, nChildren 00397 childgrids(:,:,j)=levelUp(childgrids(:,:,j)+spread(node%box%mGlobal(:,1)-1,2,2), n) 00398 END DO 00399 CALL HilbertSort(childgrids, n+1) 00400 DO j=1, nChildren 00401 child_box%mGlobal=childgrids(:,:,j) 00402 NULLIFY(child) 00403 IF (MPI_NP == 1) THEN 00404 CALL AddNode(n+1, child_box, child) 00405 CALL AddParent(child, node) 00406 ELSE 00407 ALLOCATE(child) 00408 CALL NullifyNodeFields(child) 00409 child%box=child_box 00410 END IF 00411 CALL AddChild(node, child) 00412 END DO 00413 END IF 00414 IF (MPI_NP == 1 .AND. n >= 0) CALL AllocChildFixups(node%info, childgrids) 00415 IF (nChildren > 0) THEN 00416 CALL DestroyNodeBox(child_box) 00417 DEALLOCATE(childgrids, STAT=iErr) 00418 IF (iErr /= 0) THEN 00419 PRINT *, "CreateChildren() error: Unable to deallocate childgrids." 00420 STOP 00421 END IF 00422 NULLIFY(childgrids) 00423 END IF 00424 END IF 00425 00426 END SUBROUTINE CreateChildren 00427 00428 00431 SUBROUTINE AgeNodeChildren(node) 00432 00433 TYPE(NodeDef) :: node 00434 00435 ! Move node's children to its old children list and then clear 00436 ! the children list. 00437 CALL ClearNodeList(node%oldchildren) 00438 node%oldchildren=>node%children 00439 NULLIFY(node%children) 00440 NULLIFY(node%lastchild) 00441 00442 END SUBROUTINE AgeNodeChildren 00443 00444 00445 00449 00450 SUBROUTINE RestoreChildren(n, node, lstrict_opt) 00451 TYPE(NodeDef), POINTER :: node, parent, currentnode, child 00452 TYPE(NodeDefList), POINTER :: children 00453 INTEGER :: n 00454 LOGICAL, OPTIONAL :: lstrict_opt 00455 LOGICAL :: lstrict 00456 IF (PRESENT(lstrict_opt)) THEN 00457 lstrict=lstrict_opt 00458 ELSE 00459 lstrict=.true. 00460 END IF 00461 NULLIFY(currentnode) 00462 IF (lstrict) THEN 00463 CALL StrictFindBackupNode(n,node%box, currentnode, "RestoreChildren") 00464 ELSE 00465 CALL FindBackupNode(n, node%box, currentnode) 00466 END IF 00467 IF (ASSOCIATED(currentnode)) THEN 00468 children=>currentnode%children 00469 DO WHILE (ASSOCIATED(children)) 00470 CALL StrictFindNode(n+1,children%self%box, child, "RestoreChildren") 00471 CALL AddChild(node, child) 00472 children=>children%next 00473 END DO 00474 END IF 00475 END SUBROUTINE RestoreChildren 00476 00477 00481 00482 SUBROUTINE RestoreParent(n, node) 00483 TYPE(NodeDef), POINTER :: node, parent, currentnode 00484 INTEGER :: n 00485 00486 CALL StrictFindBackupNode(n,node%box, currentnode, "RestoreParent") 00487 CALL StrictFindNode(n-1,currentnode%parent%box, parent, "RestoreParent") 00488 CALL AddParent(node, parent) 00489 END SUBROUTINE RestoreParent 00490 00494 00495 SUBROUTINE BackupChildren(n, node) 00496 TYPE(NodeDef), POINTER :: node, parent, currentnode, child 00497 TYPE(NodeDefList), POINTER :: children 00498 INTEGER :: n 00499 CALL StrictFindNode(n,node%box, currentnode, "BackupChildren") 00500 children=>currentnode%children 00501 DO WHILE (ASSOCIATED(children)) 00502 CALL StrictFindBackupNode(n+1,children%self%box, child, "BackupChildren") 00503 CALL AddChild(node, child) 00504 children=>children%next 00505 END DO 00506 END SUBROUTINE BackupChildren 00507 00508 00512 00513 SUBROUTINE BackupParent(n, node) 00514 TYPE(NodeDef), POINTER :: node, parent, currentnode 00515 INTEGER :: n 00516 CALL StrictFindNode(n,node%box, currentnode, "BackupParent") 00517 CALL StrictFindBackupNode(n-1,currentnode%parent%box, parent, "BackupParent") 00518 CALL AddParent(node, parent) 00519 END SUBROUTINE BackupParent 00520 00521 00522 00524 00525 END MODULE TreeNodeOps