Line data    Source code

       1             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
       2             : ! Copyright (c) 2015, Regents of the University of Colorado
       3             : ! All rights reserved.
       4             : !
       5             : ! Redistribution and use in source and binary forms, with or without modification, are 
       6             : ! permitted provided that the following conditions are met:
       7             : !
       8             : ! 1. Redistributions of source code must retain the above copyright notice, this list of 
       9             : !    conditions and the following disclaimer.
      10             : !
      11             : ! 2. Redistributions in binary form must reproduce the above copyright notice, this list
      12             : !    of conditions and the following disclaimer in the documentation and/or other 
      13             : !    materials provided with the distribution.
      14             : !
      15             : ! 3. Neither the name of the copyright holder nor the names of its contributors may be 
      16             : !    used to endorse or promote products derived from this software without specific prior
      17             : !    written permission.
      18             : !
      19             : ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
      20             : ! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
      21             : ! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
      22             : ! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
      23             : ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
      24             : ! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
      25             : ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
      26             : ! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
      27             : ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
      28             : !
      29             : ! History:
      30             : ! 10/16/03  John Haynes   - Original version (haynes@atmos.colostate.edu)
      31             : ! 01/31/06  John Haynes   - IDL to Fortran 90
      32             : ! 01/01/15  Dustin Swales - Modified for COSPv2.0
      33             : ! 
      34             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      35             : module array_lib
      36             :   USE COSP_KINDS, ONLY: wp
      37             :   implicit none
      38             : contains
      39             : 
      40             :   ! ############################################################################
      41             :   !                               function INFIND
      42             :   ! ############################################################################
      43    57569436 :   function infind(list,val)
      44             :     implicit none
      45             :     ! ##########################################################################
      46             :     ! Purpose:
      47             :     !   Finds the index of an array that is closest to a value, plus the
      48             :     !   difference between the value found and the value specified
      49             :     !
      50             :     ! Inputs:
      51             :     !   [list]   an array of sequential values
      52             :     !   [val]    a value to locate
      53             :     ! Optional input:
      54             :     !   [sort]   set to 1 if [list] is in unknown/non-sequential order
      55             :     !
      56             :     ! Returns:
      57             :     !   index of [list] that is closest to [val]
      58             :     !
      59             :     ! Optional output:
      60             :     !   [dist]   set to variable containing [list([result])] - [val]
      61             :     !
      62             :     ! Requires:
      63             :     !   mrgrnk library
      64             :     !
      65             :     ! ##########################################################################
      66             : 
      67             :     ! INPUTS
      68             :     real(wp), dimension(:), intent(in) :: &
      69             :          list   ! An array of sequential values
      70             :     real(wp), intent(in) :: &
      71             :          val    ! A value to locate
      72             :     ! OUTPUTS
      73             :     integer :: &
      74             :          infind ! Index of [list] that is closest to [val]
      75             : 
      76             :     ! Internal Variables
      77   115138872 :     real(wp), dimension(size(list)) :: lists
      78             :     integer :: nlist, result, tmp(1), sort_list
      79   115138872 :     integer, dimension(size(list)) :: mask
      80             :     
      81    57569436 :     sort_list = 0
      82             :     
      83    57569436 :     nlist = size(list)
      84  1240355124 :     lists = list
      85             :     
      86    57569436 :     if (val >= lists(nlist)) then
      87             :        result = nlist
      88    56959102 :     else if (val <= lists(1)) then
      89             :        result = 1
      90             :     else
      91  1168821123 :        mask(:) = 0
      92  1168821123 :        where (lists < val) mask = 1
      93  1225721503 :        tmp = minloc(mask,1)
      94    56900380 :        if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then
      95             :           result = tmp(1) - 1
      96             :       else
      97    28453533 :          result = tmp(1)
      98             :       endif
      99             :    endif
     100    57569436 :    infind = result
     101    57569436 :  end function infind
     102             : 
     103             : end module array_lib