RFLU_ModSplitTree.F90

Go to the documentation of this file.

! *********************************************************************
! * Rocstar Simulation Suite                                          *
! * Copyright@2015, Illinois Rocstar LLC. All rights reserved.        *
! *                                                                   *
! * Illinois Rocstar LLC                                              *
! * Champaign, IL                                                     *
! * www.illinoisrocstar.com                                           *
! * sales@illinoisrocstar.com                                         *
! *                                                                   *
! * License: See LICENSE file in top level of distribution package or *
! * http://opensource.org/licenses/NCSA                               *
! *********************************************************************
! *********************************************************************
! * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,   *
! * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES   *
! * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND          *
! * NONINFRINGEMENT.  IN NO EVENT SHALL THE CONTRIBUTORS OR           *
! * COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER       *
! * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,   *
! * Arising FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE    *
! * USE OR OTHER DEALINGS WITH THE SOFTWARE.                          *
! *********************************************************************
!*******************************************************************************
!
! Purpose: Suite of routines to carry out split tree operations.
!
! Description: None.
!
! Notes: To create and use a split tree, one has to take the following steps:
!   1. 
!   2. 
!   3. Deallocate the table by calling DestroyHashTable.
!
!*******************************************************************************
!
! $Id: RFLU_ModSplitTree.F90,v 1.6 2008/12/06 08:44:24 mtcampbe Exp $
!
! Copyright: (c) 2002 by the University of Illinois
!
!*******************************************************************************

MODULE rflu_modsplittree

  USE modglobal, ONLY: t_global
  USE moddatatypes
  USE modparameters
  USE moderror
  USE modsortsearch

  IMPLICIT NONE
  
  PRIVATE
  PUBLIC :: rflu_createsplittree, & 
            rflu_buildsplittree, & 
            rflu_destroysplittree

  SAVE
  
! ******************************************************************************
! Declarations and definitions
! ******************************************************************************  
  
  INTEGER, PARAMETER :: NLEVELS_MAX  = 50,    & ! Must be greater than 1
                        NBUCKETS_MAX = 10000, & ! Must be greater than 2
                        NPOINTS_MAX  = 5       
  
  INTEGER, PRIVATE :: nPoints
  
  INTEGER, DIMENSION(:), ALLOCATABLE :: pointList     
  INTEGER, DIMENSION(:,:), ALLOCATABLE :: tree     
       
  REAL(RFREAL), DIMENSION(:), ALLOCATABLE :: pointXyz     
       
! ******************************************************************************
! Routines
! ******************************************************************************

  CONTAINS
  
! ==============================================================================
!   Create split tree
! ==============================================================================  

    SUBROUTINE rflu_createsplittree(global,nDataPoints)
    
      IMPLICIT NONE   
        
      INTEGER, INTENT(IN) :: ndatapoints 
      TYPE(t_global), POINTER :: global  
        
      INTEGER :: errorflag,ip         
        
      CALL registerfunction(global,'RFLU_CreateSplitTree',&
  'RFLU_ModSplitTree.F90')

! ------------------------------------------------------------------------------
!     Copy argument into nPoints variable
! ------------------------------------------------------------------------------ 

      npoints = ndatapoints

! ------------------------------------------------------------------------------
!     Allocate memory
! ------------------------------------------------------------------------------ 

      ALLOCATE(tree(7,nbuckets_max),stat=errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_allocate,__line__)
      END IF ! global%error)

      ALLOCATE(pointlist(npoints),stat=errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_allocate,__line__)
      END IF ! global%error

      ALLOCATE(pointxyz(npoints),stat=errorflag)
      global%error = errorflag  
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_allocate,__line__)
      END IF ! global%error

! ------------------------------------------------------------------------------
!     Initialize
! ------------------------------------------------------------------------------ 

      tree(:,:) = 0

      DO ip = 1,npoints
        pointlist(ip) = ip
      END DO ! ip
    
      CALL deregisterfunction(global)    

    END SUBROUTINE rflu_createsplittree

! ==============================================================================
!   Build split tree
! ==============================================================================  

    SUBROUTINE rflu_buildsplittree(global,xyz)

      IMPLICIT NONE
      
      INTEGER :: errorflag,ibranch1,ibranch2,ibucket,ibucketlast,ipl,ipm,ipg, & 
                 isplitdir,nbuckets,nlevels
      
      REAL(RFREAL), INTENT(IN) :: xyz(3,npoints)
      TYPE(t_global), POINTER :: global
      
! ------------------------------------------------------------------------------
!     Start
! ------------------------------------------------------------------------------      
      
      CALL registerfunction(global,'RFLU_BuildSplitTree',&
  'RFLU_ModSplitTree.F90')      

      nlevels  = 1
      nbuckets = 1
      
      ibucket     = 1
      ibucketlast = 1
      isplitdir   = 1
      
      tree(1,ibucket) = 1
      tree(2,ibucket) = npoints
      tree(3,ibucket) = npoints
      tree(4,ibucket) = isplitdir
      
! ------------------------------------------------------------------------------
!     Loop over levels
! ------------------------------------------------------------------------------      
      
      outer: DO
        isplitdir = isplitdir + 1
        IF ( isplitdir > 3 ) THEN 
          isplitdir = 1
        END IF ! iSplitDir
      
! ----- Loop over buckets      
      
        inner: DO 
     
! ------- Determine whether bucket should be split     
           
          IF ( tree(3,ibucket) > npoints_max ) THEN ! Split bucket

! --------- Check whether more buckets can be generated

            IF ( nbuckets > nbuckets_max-2 ) THEN 
              EXIT outer
            END IF ! nBuckets
          
! --------- Determine where bucket should be split - use median 
          
            ipl = 0
            DO ipg = tree(1,ibucket),tree(2,ibucket)
              ipl = ipl + 1
              pointxyz(ipl) = xyz(isplitdir,pointlist(ipg))
            END DO ! ipg
            
            CALL quicksortrfrealinteger(pointxyz(1:tree(3,ibucket)), &
                          pointlist(tree(1,ibucket):tree(2,ibucket)), & 
                          tree(3,ibucket))
          
            ipm = tree(3,ibucket)/2 + 1 ! NOTE integer division
          
! --------- Update information for current bucket          
          
            tree(5,ibucket) = pointlist(ipm)          
          
            ibranch1 = ibucket + 1
            ibranch2 = ibucket + 2
            
            tree(6,ibucket) = ibranch1
            tree(7,ibucket) = ibranch2          
          
! --------- Create new buckets

            nbuckets = nbuckets + 2
            
            tree(1,ibranch1) = tree(1,ibucket)
            tree(2,ibranch1) = ipm - 1
            tree(3,ibranch1) = tree(2,ibranch1) - tree(1,ibranch1) + 1        
            tree(4,ibranch1) = isplitdir
          
            tree(1,ibranch2) = ipm
            tree(2,ibranch2) = tree(3,ibucket)
            tree(3,ibranch2) = tree(2,ibranch2) - tree(1,ibranch2) + 1
            tree(4,ibranch2) = tree(4,ibranch1)           
          END IF ! tree(3,iBucket)  
          
! ------- Check whether more buckets to be split          
        
          IF ( ibucket < nbuckets ) THEN 
            IF ( ibucket /= ibucketlast ) THEN
              ibucket = ibucket + 1             
            ELSE 
              ibucketlast = nbuckets
              EXIT inner
            END IF ! iBucket
          ELSE
            EXIT outer  
          END IF ! iBucket
        END DO inner 
      
! ----- Check whether more levels can be inserted      
      
        IF ( nlevels < nlevels_max ) THEN 
          nlevels   = nlevels   + 1
          ibucket   = ibucket   + 1
        ELSE  
          EXIT outer
        END IF ! nLevels
      END DO outer

      WRITE(*,*) nlevels,nbuckets

      DO ipl = 1,nbuckets
        WRITE(*,*) ipl,tree(1:7,ipl)
      END DO ! ipl

      CALL deregisterfunction(global)  

    END SUBROUTINE rflu_buildsplittree

! ==============================================================================
!   Destroy split tree
! ==============================================================================  
   
    SUBROUTINE rflu_destroysplittree(global)
    
      IMPLICIT NONE

      TYPE(t_global), POINTER :: global

      INTEGER :: errorflag

      CALL registerfunction(global,'RFLU_DestroySplitTree',&
  'RFLU_ModSplitTree.F90')

      DEALLOCATE(tree,stat=errorflag)
      global%error = errorflag  
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_deallocate,__line__)
      END IF ! global%error)

      DEALLOCATE(pointlist,stat=errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_deallocate,__line__)
      END IF ! global%error

      DEALLOCATE(pointxyz,stat=errorflag)
      global%error = errorflag
      IF ( global%error /= err_none ) THEN 
        CALL errorstop(global,err_deallocate,__line__)
      END IF ! global%error

      CALL deregisterfunction(global)

    END SUBROUTINE rflu_destroysplittree


  

! ******************************************************************************
! End
! ******************************************************************************
  
END MODULE rflu_modsplittree


! ******************************************************************************
!
! RCS Revision history:
!
!   $Log: RFLU_ModSplitTree.F90,v $
!   Revision 1.6  2008/12/06 08:44:24  mtcampbe
!   Updated license.
!
!   Revision 1.5  2008/11/19 22:17:35  mtcampbe
!   Added Illinois Open Source License/Copyright
!
!   Revision 1.4  2004/01/22 16:03:59  haselbac
!   Made contents of modules PRIVATE, only procs PUBLIC, to avoid errors on ALC and titan
!
!   Revision 1.3  2002/10/08 15:49:21  haselbac
!   {IO}STAT=global%error replaced by {IO}STAT=errorFlag - SGI problem
!
!   Revision 1.2  2002/09/09 15:12:12  haselbac
!   global now under regions
!
!   Revision 1.1  2002/04/11 18:48:48  haselbac
!   Initial revision
!
!
! ******************************************************************************