1  /* Implementation of the MINLOC intrinsic
       2     Copyright (C) 2017-2023 Free Software Foundation, Inc.
       3     Contributed by Thomas Koenig
       4  
       5  This file is part of the GNU Fortran runtime library (libgfortran).
       6  
       7  Libgfortran is free software; you can redistribute it and/or
       8  modify it under the terms of the GNU General Public
       9  License as published by the Free Software Foundation; either
      10  version 3 of the License, or (at your option) any later version.
      11  
      12  Libgfortran is distributed in the hope that it will be useful,
      13  but WITHOUT ANY WARRANTY; without even the implied warranty of
      14  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      15  GNU General Public License for more details.
      16  
      17  Under Section 7 of GPL version 3, you are granted additional
      18  permissions described in the GCC Runtime Library Exception, version
      19  3.1, as published by the Free Software Foundation.
      20  
      21  You should have received a copy of the GNU General Public License and
      22  a copy of the GCC Runtime Library Exception along with this program;
      23  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
      24  <http://www.gnu.org/licenses/>.  */
      25  
      26  #include "libgfortran.h"
      27  #include <stdlib.h>
      28  #include <string.h>
      29  #include <assert.h>
      30  
      31  #if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
      32  
      33  static inline int
      34  compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
      35  {
      36    if (sizeof (GFC_UINTEGER_4) == 1)
      37      return memcmp (a, b, n);
      38    else
      39      return memcmp_char4 (a, b, n);
      40  }
      41  
      42  extern GFC_INTEGER_4 minloc2_4_s4 (gfc_array_s4 * const restrict, GFC_LOGICAL_4 back,
      43         gfc_charlen_type);
      44  export_proto(minloc2_4_s4);
      45  
      46  GFC_INTEGER_4
      47  minloc2_4_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back,
      48  				gfc_charlen_type len)
      49  {
      50    index_type ret;
      51    index_type sstride;
      52    index_type extent;
      53    const GFC_UINTEGER_4 *src;
      54    const GFC_UINTEGER_4 *minval;
      55    index_type i;
      56  
      57    extent = GFC_DESCRIPTOR_EXTENT(array,0);
      58    if (extent <= 0)
      59      return 0;
      60  
      61    sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
      62  
      63    ret = 1;
      64    src = array->base_addr;
      65    minval = NULL;
      66    for (i=1; i<=extent; i++)
      67      {
      68        if (minval == NULL || (back ? compare_fcn (src, minval, len) <= 0 :
      69        	 	    	    	    compare_fcn (src, minval, len) < 0))
      70        {
      71  	 ret = i;
      72  	 minval = src;
      73        }
      74        src += sstride;
      75      }
      76    return ret;
      77  }
      78  
      79  extern GFC_INTEGER_4 mminloc2_4_s4 (gfc_array_s4 * const restrict,
      80                      gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
      81  		    gfc_charlen_type);
      82  export_proto(mminloc2_4_s4);
      83  
      84  GFC_INTEGER_4
      85  mminloc2_4_s4 (gfc_array_s4 * const restrict array,
      86  				 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
      87  				 gfc_charlen_type len)
      88  {
      89    index_type ret;
      90    index_type sstride;
      91    index_type extent;
      92    const GFC_UINTEGER_4 *src;
      93    const GFC_UINTEGER_4 *maxval;
      94    index_type i, j;
      95    GFC_LOGICAL_1 *mbase;
      96    int mask_kind;
      97    index_type mstride;
      98  
      99    extent = GFC_DESCRIPTOR_EXTENT(array,0);
     100    if (extent <= 0)
     101      return 0;
     102  
     103    sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
     104  
     105    mask_kind = GFC_DESCRIPTOR_SIZE (mask);
     106    mbase = mask->base_addr;
     107  
     108    if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
     109  #ifdef HAVE_GFC_LOGICAL_16
     110        || mask_kind == 16
     111  #endif
     112        )
     113      mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
     114    else
     115      internal_error (NULL, "Funny sized logical array");
     116  
     117    mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
     118  
     119    /* Search for the first occurrence of a true element in mask. */
     120    for (j=0; j<extent; j++)
     121      {
     122        if (*mbase)
     123          break;
     124        mbase += mstride;
     125      }
     126  
     127    if (j == extent)
     128      return 0;
     129  
     130    ret = j + 1;
     131    src = array->base_addr + j * sstride;
     132    maxval = src;
     133  
     134    for (i=j+1; i<=extent; i++)
     135      {
     136  
     137        if (*mbase && (back ? compare_fcn (src, maxval, len) <= 0 :
     138        	 	    	    compare_fcn (src, maxval, len) < 0))
     139        {
     140  	 ret = i;
     141  	 maxval = src;
     142        }
     143        src += sstride;
     144        mbase += mstride;
     145      }
     146    return ret;
     147  }
     148  
     149  extern GFC_INTEGER_4 sminloc2_4_s4 (gfc_array_s4 * const restrict,
     150         		    	GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type);
     151  export_proto(sminloc2_4_s4);
     152  
     153  GFC_INTEGER_4
     154  sminloc2_4_s4 (gfc_array_s4 * const restrict array,
     155  				 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
     156  {
     157    if (mask)
     158      return minloc2_4_s4 (array, len, back);
     159    else
     160      return 0;
     161  }
     162  
     163  #endif