00001 /* Ergo, version 3.7, a program for linear scaling electronic structure 00002 * calculations. 00003 * Copyright (C) 2018 Elias Rudberg, Emanuel H. Rubensson, Pawel Salek, 00004 * and Anastasia Kruchinina. 00005 * 00006 * This program is free software: you can redistribute it and/or modify 00007 * it under the terms of the GNU General Public License as published by 00008 * the Free Software Foundation, either version 3 of the License, or 00009 * (at your option) any later version. 00010 * 00011 * This program is distributed in the hope that it will be useful, 00012 * but WITHOUT ANY WARRANTY; without even the implied warranty of 00013 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00014 * GNU General Public License for more details. 00015 * 00016 * You should have received a copy of the GNU General Public License 00017 * along with this program. If not, see <http://www.gnu.org/licenses/>. 00018 * 00019 * Primary academic reference: 00020 * Ergo: An open-source program for linear-scaling electronic structure 00021 * calculations, 00022 * Elias Rudberg, Emanuel H. Rubensson, Pawel Salek, and Anastasia 00023 * Kruchinina, 00024 * SoftwareX 7, 107 (2018), 00025 * <http://dx.doi.org/10.1016/j.softx.2018.03.005> 00026 * 00027 * For further information about Ergo, see <http://www.ergoscf.org>. 00028 */ 00029 00030 /* This file belongs to the template_lapack part of the Ergo source 00031 * code. The source files in the template_lapack directory are modified 00032 * versions of files originally distributed as CLAPACK, see the 00033 * Copyright/license notice in the file template_lapack/COPYING. 00034 */ 00035 00036 00037 #ifndef TEMPLATE_BLAS_NRM2_HEADER 00038 #define TEMPLATE_BLAS_NRM2_HEADER 00039 00040 00041 template<class Treal> 00042 Treal template_blas_nrm2(const integer *n, const Treal *x, const integer *incx) 00043 { 00044 /* The following loop is equivalent to this call to the LAPACK 00045 auxiliary routine: 00046 CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ 00047 /* System generated locals */ 00048 integer i__1, i__2; 00049 Treal ret_val, d__1; 00050 /* Local variables */ 00051 Treal norm, scale, absxi; 00052 integer ix; 00053 Treal ssq; 00054 /* DNRM2 returns the euclidean norm of a vector via the function 00055 name, so that 00056 DNRM2 := sqrt( x'*x ) 00057 -- This version written on 25-October-1982. 00058 Modified on 14-October-1993 to inline the call to DLASSQ. 00059 Sven Hammarling, Nag Ltd. 00060 Parameter adjustments */ 00061 --x; 00062 /* Function Body */ 00063 if (*n < 1 || *incx < 1) { 00064 norm = 0.; 00065 } else if (*n == 1) { 00066 norm = absMACRO(x[1]); 00067 } else { 00068 scale = 0.; 00069 ssq = 1.; 00070 00071 00072 i__1 = (*n - 1) * *incx + 1; 00073 i__2 = *incx; 00074 for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { 00075 if (x[ix] != 0.) { 00076 absxi = (d__1 = x[ix], absMACRO(d__1)); 00077 if (scale < absxi) { 00078 /* Computing 2nd power */ 00079 d__1 = scale / absxi; 00080 ssq = ssq * (d__1 * d__1) + 1.; 00081 scale = absxi; 00082 } else { 00083 /* Computing 2nd power */ 00084 d__1 = absxi / scale; 00085 ssq += d__1 * d__1; 00086 } 00087 } 00088 /* L10: */ 00089 } 00090 norm = scale * template_blas_sqrt(ssq); 00091 } 00092 00093 ret_val = norm; 00094 return ret_val; 00095 00096 /* End of DNRM2. */ 00097 00098 } /* dnrm2_ */ 00099 00100 #endif