`/* Implementation of the MINLOC intrinsic
- Copyright 2017 Free Software Foundation, Inc.
+ Copyright (C) 2017-2024 Free Software Foundation, Inc.
Contributed by Thomas Koenig
This file is part of the GNU Fortran runtime library (libgfortran).
#include "libgfortran.h"
#include <stdlib.h>
-#include <string.h>'
+#include <string.h>
+#include <assert.h>'
include(iparm.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)
return memcmp_char4 (a, b, n);
}
-extern 'rtype_name` 'name`'rtype_qual`_'atype_code` ('atype` * const restrict, gfc_charlen_type);
+extern 'rtype_name` 'name`'rtype_qual`_'atype_code` ('atype` * const restrict'back_arg`,
+ gfc_charlen_type);
export_proto('name`'rtype_qual`_'atype_code`);
'rtype_name`
-'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, gfc_charlen_type len)
+'name`'rtype_qual`_'atype_code` ('atype` * const restrict array'back_arg`,
+ gfc_charlen_type len)
{
index_type ret;
index_type sstride;
index_type extent;
const 'atype_name` *src;
- const 'atype_name` *maxval;
+ const 'atype_name` *minval;
index_type i;
extent = GFC_DESCRIPTOR_EXTENT(array,0);
ret = 1;
src = array->base_addr;
- maxval = src;
- for (i=2; i<=extent; i++)
+ minval = NULL;
+ for (i=1; i<=extent; i++)
{
- src += sstride;
- if (compare_fcn (src, maxval, len) < 0)
+ if (minval == NULL || (back ? compare_fcn (src, minval, len) <= 0 :
+ compare_fcn (src, minval, len) < 0))
{
ret = i;
- maxval = src;
+ minval = src;
}
+ src += sstride;
}
return ret;
}
extern 'rtype_name` m'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
- gfc_array_l1 *const restrict mask, int);
+ gfc_array_l1 *const restrict mask'back_arg`,
+ gfc_charlen_type);
export_proto(m'name`'rtype_qual`_'atype_code`);
'rtype_name`
m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
- gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+ gfc_array_l1 * const restrict mask'back_arg`,
+ gfc_charlen_type len)
{
index_type ret;
index_type sstride;
for (i=j+1; i<=extent; i++)
{
- if (*mbase && compare_fcn (src, maxval, len) < 0)
+
+ if (*mbase && (back ? compare_fcn (src, maxval, len) <= 0 :
+ compare_fcn (src, maxval, len) < 0))
{
ret = i;
maxval = src;
}
extern 'rtype_name` s'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
- GFC_LOGICAL_4 *mask, gfc_charlen_type);
+ GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type);
export_proto(s'name`'rtype_qual`_'atype_code`);
'rtype_name`
s'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
- GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+ GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type len)
{
if (mask)
- return 'name`'rtype_qual`_'atype_code` (array, len);
+ return 'name`'rtype_qual`_'atype_code` (array, len, back);
else
return 0;
}