Scrambler  1
tree_node_ops.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_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
 All Classes Files Functions Variables