1  /* Implementation of the MAXLOC 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_1) && defined (HAVE_GFC_INTEGER_8)
      32  
      33  static inline int
      34  compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
      35  {
      36    if (sizeof (GFC_UINTEGER_1) == 1)
      37      return memcmp (a, b, n);
      38    else
      39      return memcmp_char4 (a, b, n);
      40  }
      41  
      42  extern GFC_INTEGER_8 maxloc2_8_s1 (gfc_array_s1 * const restrict, GFC_LOGICAL_4 back,
      43         gfc_charlen_type);
      44  export_proto(maxloc2_8_s1);
      45  
      46  GFC_INTEGER_8
      47  maxloc2_8_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
      48  {
      49    index_type ret;
      50    index_type sstride;
      51    index_type extent;
      52    const GFC_UINTEGER_1 *src;
      53    const GFC_UINTEGER_1 *maxval;
      54    index_type i;
      55  
      56    extent = GFC_DESCRIPTOR_EXTENT(array,0);
      57    if (extent <= 0)
      58      return 0;
      59  
      60    sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
      61  
      62    ret = 1;
      63    src = array->base_addr;
      64    maxval = NULL;
      65    for (i=1; i<=extent; i++)
      66      {
      67        if (maxval == NULL || (back ? compare_fcn (src, maxval, len) >= 0 :
      68        	 	    	    	    compare_fcn (src, maxval, len) > 0))
      69        {
      70  	 ret = i;
      71  	 maxval = src;
      72        }
      73        src += sstride;
      74      }
      75    return ret;
      76  }
      77  
      78  extern GFC_INTEGER_8 mmaxloc2_8_s1 (gfc_array_s1 * const restrict,
      79         		    	gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
      80  			gfc_charlen_type);
      81  export_proto(mmaxloc2_8_s1);
      82  
      83  GFC_INTEGER_8
      84  mmaxloc2_8_s1 (gfc_array_s1 * const restrict array,
      85  				 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
      86  				 gfc_charlen_type len)
      87  {
      88    index_type ret;
      89    index_type sstride;
      90    index_type extent;
      91    const GFC_UINTEGER_1 *src;
      92    const GFC_UINTEGER_1 *maxval;
      93    index_type i, j;
      94    GFC_LOGICAL_1 *mbase;
      95    int mask_kind;
      96    index_type mstride;
      97  
      98    extent = GFC_DESCRIPTOR_EXTENT(array,0);
      99    if (extent <= 0)
     100      return 0;
     101  
     102    sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
     103  
     104    mask_kind = GFC_DESCRIPTOR_SIZE (mask);
     105    mbase = mask->base_addr;
     106  
     107    if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
     108  #ifdef HAVE_GFC_LOGICAL_16
     109        || mask_kind == 16
     110  #endif
     111        )
     112      mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
     113    else
     114      internal_error (NULL, "Funny sized logical array");
     115  
     116    mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
     117  
     118    /* Search for the first occurrence of a true element in mask. */
     119    for (j=0; j<extent; j++)
     120      {
     121        if (*mbase)
     122          break;
     123        mbase += mstride;
     124      }
     125  
     126    if (j == extent)
     127      return 0;
     128  
     129    ret = j + 1;
     130    src = array->base_addr + j * sstride;
     131    maxval = src;
     132  
     133    for (i=j+1; i<=extent; i++)
     134      {
     135        if (*mbase && (back ? compare_fcn (src, maxval, len) >= 0 :
     136        	 	    	   compare_fcn (src, maxval, len) > 0))
     137        {
     138  	 ret = i;
     139  	 maxval = src;
     140        }
     141        src += sstride;
     142        mbase += mstride;
     143      }
     144    return ret;
     145  }
     146  
     147  extern GFC_INTEGER_8 smaxloc2_8_s1 (gfc_array_s1 * const restrict,
     148                                 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type);
     149  export_proto(smaxloc2_8_s1);
     150  
     151  GFC_INTEGER_8
     152  smaxloc2_8_s1 (gfc_array_s1 * const restrict array,
     153  				 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
     154  {
     155    if (mask)
     156      return maxloc2_8_s1 (array, len, back);
     157    else
     158      return 0;
     159  }
     160  
     161  #endif