prismtrs_sort_add.F90

Go to the documentation of this file.

!------------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISMTrs_sort_add
!
! !INTERFACE
      subroutine prismtrs_sort_add(add1, add2, weights, num_links, num_wts)

      USE PRISMDrv, dummy_INTERFACE => PRISMTrs_sort_add
      implicit none

!-----------------------------------------------------------------------
!
!     Input and Output arrays
!
!-----------------------------------------------------------------------

      integer, intent(in) :: num_links, num_wts
      integer, intent(inout), dimension(num_links) :: 
              add1,      ! destination address array (num_links)
              add2        ! source      address array

      DOUBLE PRECISION, intent(inout), 
          dimension(num_wts, num_links) :: 
              weights     ! remapping weights (num_wts, num_links)
!
! !DESCRIPTION
!
! SUBROUTINE prismtrs_sort_add sorts address and weight arrays based 
! on the destination address with the source address as a secondary
! sorting criterion.  the method is a standard heap sort.This subroutine
! comes from the SCRIP 1.4 library available from Los Alamos National 
! Laboratory.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 19/03/2007  S. Valcke    Duplicated from the SCRIP library
!
! EOP
!----------------------------------------------------------------------
! $Id: prismtrs_sort_add.F90 2082 2009-10-21 13:31:19Z hanke $
! $Author: hanke $
!----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
!     local variables
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismtrs_sort_add.F90 2082 2009-10-21 13:31:19Z hanke $'
!-----------------------------------------------------------------------

      integer :: 
                add1_tmp, add2_tmp,  ! temp for addresses during swap
                nwgt, 
                lvl, final_lvl,    ! level indexes for heap sort levels
                chk_lvl1, chk_lvl2, max_lvl

      double precision, dimension(SIZE(weights,DIM=1)) :: 
                wgttmp              ! temp for holding wts during swap
!
#ifdef VERBOSE
  PRINT *, '| | | | | | | Enter PRISMTrs_sort_add'
  call psmile_flushstd
#endif
!-----------------------------------------------------------------------
!
!     start at the lowest level (N/2) of the tree and sift lower 
!     values to the bottom of the tree, promoting the larger numbers
!
!-----------------------------------------------------------------------

      do lvl=num_links/2,1,-1

        final_lvl = lvl
        add1_tmp = add1(lvl)
        add2_tmp = add2(lvl)
        wgttmp(:) = weights(:,lvl)

        !***
        !*** loop until proper level is found for this link, or reach
        !*** bottom
        !***

        sift_loop1: do

          !***
          !*** find the largest of the two daughters
          !***

          chk_lvl1 = 2*final_lvl
          chk_lvl2 = 2*final_lvl+1
          if (chk_lvl1 .EQ. num_links) chk_lvl2 = chk_lvl1

          if ((add1(chk_lvl1) >  add1(chk_lvl2)) .OR. &
             ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. &
              (add2(chk_lvl1) >  add2(chk_lvl2)))) then
            max_lvl = chk_lvl1
          else 
            max_lvl = chk_lvl2
          endif

          !***
          !*** if the parent is greater than both daughters,
          !*** the correct level has been found
          !***

          if ((add1_tmp .GT. add1(max_lvl)) .OR. &
             ((add1_tmp .EQ. add1(max_lvl)) .AND. &
              (add2_tmp .GT. add2(max_lvl)))) then
            add1(final_lvl) = add1_tmp
            add2(final_lvl) = add2_tmp
            weights(:,final_lvl) = wgttmp(:)
            exit sift_loop1

          !***
          !*** otherwise, promote the largest daughter and push
          !*** down one level in the tree.  if haven't reached
          !*** the end of the tree, repeat the process.  otherwise
          !*** store last values and exit the loop
          !***

          else 
            add1(final_lvl) = add1(max_lvl)
            add2(final_lvl) = add2(max_lvl)
            weights(:,final_lvl) = weights(:,max_lvl)

            final_lvl = max_lvl
            if (2*final_lvl > num_links) then
              add1(final_lvl) = add1_tmp
              add2(final_lvl) = add2_tmp
              weights(:,final_lvl) = wgttmp(:)
              exit sift_loop1
            endif
          endif
        end do sift_loop1
      end do

!-----------------------------------------------------------------------
!
!     now that the heap has been sorted, strip off the top (largest)
!     value and promote the values below
!
!-----------------------------------------------------------------------

      do lvl=num_links,3,-1

        !***
        !*** move the top value and insert it into the correct place
        !***

        add1_tmp = add1(lvl)
        add1(lvl) = add1(1)

        add2_tmp = add2(lvl)
        add2(lvl) = add2(1)

        wgttmp(:) = weights(:,lvl)
        weights(:,lvl) = weights(:,1)

        !***
        !*** as above this loop sifts the tmp values down until proper 
        !*** level is reached
        !***

        final_lvl = 1

        sift_loop2: do

          !***
          !*** find the largest of the two daughters
          !***

          chk_lvl1 = 2*final_lvl
          chk_lvl2 = 2*final_lvl+1
          if (chk_lvl2 >= lvl) chk_lvl2 = chk_lvl1

          if ((add1(chk_lvl1) >  add1(chk_lvl2)) .OR. &
             ((add1(chk_lvl1) == add1(chk_lvl2)) .AND. &
              (add2(chk_lvl1) >  add2(chk_lvl2)))) then
            max_lvl = chk_lvl1
          else 
            max_lvl = chk_lvl2
          endif

          !***
          !*** if the parent is greater than both daughters,
          !*** the correct level has been found
          !***

          if ((add1_tmp >  add1(max_lvl)) .OR. &
             ((add1_tmp == add1(max_lvl)) .AND. &
              (add2_tmp >  add2(max_lvl)))) then
            add1(final_lvl) = add1_tmp
            add2(final_lvl) = add2_tmp
            weights(:,final_lvl) = wgttmp(:)
            exit sift_loop2

          !***
          !*** otherwise, promote the largest daughter and push
          !*** down one level in the tree.  if haven't reached
          !*** the end of the tree, repeat the process.  otherwise
          !*** store last values and exit the loop
          !***

          else 
            add1(final_lvl) = add1(max_lvl)
            add2(final_lvl) = add2(max_lvl)
            weights(:,final_lvl) = weights(:,max_lvl)

            final_lvl = max_lvl
            if (2*final_lvl >= lvl) then
              add1(final_lvl) = add1_tmp
              add2(final_lvl) = add2_tmp
              weights(:,final_lvl) = wgttmp(:)
              exit sift_loop2
            endif
          endif
        end do sift_loop2
      end do

      !***
      !*** swap the last two entries
      !***


      add1_tmp = add1(2)
      add1(2)  = add1(1)
      add1(1)  = add1_tmp

      add2_tmp = add2(2)
      add2(2)  = add2(1)
      add2(1)  = add2_tmp

      wgttmp (:)   = weights(:,2)
      weights(:,2) = weights(:,1)
      weights(:,1) = wgttmp (:)
!
#ifdef VERBOSE
  PRINT *, '| | | | | | | Quit PRISMTrs_sort_add'
  call psmile_flushstd
#endif
!-----------------------------------------------------------------------

      end subroutine prismtrs_sort_add

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!