Home | History | Annotate | Line # | Download | only in m4 
      1      1.1  mrg `/* Implementation of the NORM2 intrinsic
      2  1.1.1.4  mrg    Copyright (C) 2010-2024 Free Software Foundation, Inc.
      3      1.1  mrg    Contributed by Tobias Burnus  <burnus (a] net-b.de>
      4      1.1  mrg 
      5      1.1  mrg This file is part of the GNU Fortran runtime library (libgfortran).
      6      1.1  mrg 
      7      1.1  mrg Libgfortran is free software; you can redistribute it and/or
      8      1.1  mrg modify it under the terms of the GNU General Public
      9      1.1  mrg License as published by the Free Software Foundation; either
     10      1.1  mrg version 3 of the License, or (at your option) any later version.
     11      1.1  mrg 
     12      1.1  mrg Libgfortran is distributed in the hope that it will be useful,
     13      1.1  mrg but WITHOUT ANY WARRANTY; without even the implied warranty of
     14      1.1  mrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     15      1.1  mrg GNU General Public License for more details.
     16      1.1  mrg 
     17      1.1  mrg Under Section 7 of GPL version 3, you are granted additional
     18      1.1  mrg permissions described in the GCC Runtime Library Exception, version
     19      1.1  mrg 3.1, as published by the Free Software Foundation.
     20      1.1  mrg 
     21      1.1  mrg You should have received a copy of the GNU General Public License and
     22      1.1  mrg a copy of the GCC Runtime Library Exception along with this program;
     23      1.1  mrg see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
     24      1.1  mrg <http://www.gnu.org/licenses/>.  */
     25      1.1  mrg 
     26      1.1  mrg #include "libgfortran.h"'
     27      1.1  mrg 
     28      1.1  mrg include(iparm.m4)dnl
     29      1.1  mrg include(ifunction.m4)dnl
     30      1.1  mrg include(`mtype.m4')dnl
     31      1.1  mrg 
     32      1.1  mrg `#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`) && 'hasmathfunc(sqrt) && hasmathfunc(fabs)
     33      1.1  mrg 
     34      1.1  mrg mathfunc_macro
     35      1.1  mrg 
     36      1.1  mrg ARRAY_FUNCTION(0,
     37      1.1  mrg `	'rtype_name` scale;
     38      1.1  mrg 	result = 0;
     39      1.1  mrg 	scale = 1;',
     40      1.1  mrg `	  if (*src != 0)
     41      1.1  mrg 	    {
     42      1.1  mrg 	      'rtype_name` absX, val;
     43      1.1  mrg 	      absX = MATHFUNC(fabs) (*src);
     44      1.1  mrg 	      if (scale < absX)
     45      1.1  mrg 		{
     46      1.1  mrg 		  val = scale / absX;
     47      1.1  mrg 		  result = 1 + result * val * val;
     48      1.1  mrg 		  scale = absX;
     49      1.1  mrg 		}
     50      1.1  mrg 	      else
     51      1.1  mrg 		{
     52      1.1  mrg 		  val = absX / scale;
     53      1.1  mrg 		  result += val * val;
     54      1.1  mrg 		}
     55      1.1  mrg 	    }',
     56      1.1  mrg `   result = scale * MATHFUNC(sqrt) (result);')
     57      1.1  mrg 
     58      1.1  mrg #endif
     59