findvalue.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

function findvalue(ix,n,ain,indxa)
!----------------------------------------------------------------------- 
! 
! Purpose: 
! Subroutine for finding ix-th smallest value in the array
! The elements are rearranged so that the ix-th smallest
! element is in the ix place and all smaller elements are
! moved to the elements up to ix (with random order).
!
! Algorithm: Based on the quicksort algorithm.
!
! Author:       T. Craig
! 
!-----------------------------------------------------------------------
   use precision, only: r8
   implicit none
!
! arguments
!
   integer, intent(in) :: ix                ! element to search for
   integer, intent(in) :: n                 ! total number of elements
   integer, intent(inout):: indxa(n)        ! array of integers
   real(r8), intent(in) :: ain(n)           ! array to search
!
   integer findvalue                        ! return value
!
! local variables
!
   integer i,j                              ! loop variables
   integer ir,il,im                         ! Right, left, and middle index
   integer itmp                             ! Index to switch
   logical found                            ! If found value
!
!---------------------------Routine-----------------------------
!
   found = .false.
   il=1
   ir=n
   do while (.not.found)
      if (ir-il <= 1) then
         if (ir-il == 1) then
            if (ain(indxa(ir)) < ain(indxa(il))) then
               call findvalue_swap(indxa(il),indxa(ir))
            endif
         endif
         findvalue=indxa(ix)
         found = .true.
      else
         im=(il+ir)/2
         call findvalue_swap(indxa(im),indxa(il+1))
         if (ain(indxa(il+1)) > ain(indxa(ir))) then
            call findvalue_swap(indxa(il+1),indxa(ir))
         endif
         if (ain(indxa(il)) > ain(indxa(ir))) then
            call findvalue_swap(indxa(il),indxa(ir))
         endif
         if (ain(indxa(il+1)) > ain(indxa(il))) then
            call findvalue_swap(indxa(il),indxa(il+1))
         endif
         i=il+2
         j=ir-1
         itmp=indxa(il)
         do while (j >= i)
            do while (ain(indxa(i)) < ain(itmp))
               i=i+1
            end do
            do while (ain(indxa(j)) > ain(itmp))
               j=j-1
            end do
            if (j >= i) then
              call findvalue_swap(indxa(i),indxa(j))
            endif
         end do
         indxa(il)=indxa(j)
         indxa(j)=itmp
         if (j >= ix) ir=j-1
         if (j <= ix) il=i
      endif
   end do
   return

end function findvalue


subroutine findvalue_swap(k1,k2)
!----------------------------------------------------------------------- 
! 
! Purpose: 
! Simple subroutine to swap two integer values
!
! Author:       T. Craig
! 
!-----------------------------------------------------------------------
   implicit none
   integer k1,k2,ktmp

   ktmp = k1
   k1=k2
   k2=ktmp

   return

end subroutine findvalue_swap