1 /* -- translated by f2c (version 20191129). 2 You must link the resulting object file with libf2c: 3 on Microsoft Windows system, link with libf2c.lib; 4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 5 or, if you install libf2c.a in a standard place, with -lf2c -lm 6 -- in that order, at the end of the command line, as in 7 cc *.o -lf2c -lm 8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 9 10 http://www.netlib.org/f2c/libf2c.zip 11 */ 12 13 #include "f2c.h" 14 15 /* > \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. 16 17 =========== DOCUMENTATION =========== 18 19 Online html documentation available at 20 http://www.netlib.org/lapack/explore-html/ 21 22 > \htmlonly 23 > Download DLASQ6 + dependencies 24 > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq6. 25 f"> 26 > [TGZ]</a> 27 > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq6. 28 f"> 29 > [ZIP]</a> 30 > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq6. 31 f"> 32 > [TXT]</a> 33 > \endhtmlonly 34 35 Definition: 36 =========== 37 38 SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, 39 DNM1, DNM2 ) 40 41 INTEGER I0, N0, PP 42 DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 43 DOUBLE PRECISION Z( * ) 44 45 46 > \par Purpose: 47 ============= 48 > 49 > \verbatim 50 > 51 > DLASQ6 computes one dqd (shift equal to zero) transform in 52 > ping-pong form, with protection against underflow and overflow. 53 > \endverbatim 54 55 Arguments: 56 ========== 57 58 > \param[in] I0 59 > \verbatim 60 > I0 is INTEGER 61 > First index. 62 > \endverbatim 63 > 64 > \param[in] N0 65 > \verbatim 66 > N0 is INTEGER 67 > Last index. 68 > \endverbatim 69 > 70 > \param[in] Z 71 > \verbatim 72 > Z is DOUBLE PRECISION array, dimension ( 4*N ) 73 > Z holds the qd array. EMIN is stored in Z(4*N0) to avoid 74 > an extra argument. 75 > \endverbatim 76 > 77 > \param[in] PP 78 > \verbatim 79 > PP is INTEGER 80 > PP=0 for ping, PP=1 for pong. 81 > \endverbatim 82 > 83 > \param[out] DMIN 84 > \verbatim 85 > DMIN is DOUBLE PRECISION 86 > Minimum value of d. 87 > \endverbatim 88 > 89 > \param[out] DMIN1 90 > \verbatim 91 > DMIN1 is DOUBLE PRECISION 92 > Minimum value of d, excluding D( N0 ). 93 > \endverbatim 94 > 95 > \param[out] DMIN2 96 > \verbatim 97 > DMIN2 is DOUBLE PRECISION 98 > Minimum value of d, excluding D( N0 ) and D( N0-1 ). 99 > \endverbatim 100 > 101 > \param[out] DN 102 > \verbatim 103 > DN is DOUBLE PRECISION 104 > d(N0), the last value of d. 105 > \endverbatim 106 > 107 > \param[out] DNM1 108 > \verbatim 109 > DNM1 is DOUBLE PRECISION 110 > d(N0-1). 111 > \endverbatim 112 > 113 > \param[out] DNM2 114 > \verbatim 115 > DNM2 is DOUBLE PRECISION 116 > d(N0-2). 117 > \endverbatim 118 119 Authors: 120 ======== 121 122 > \author Univ. of Tennessee 123 > \author Univ. of California Berkeley 124 > \author Univ. of Colorado Denver 125 > \author NAG Ltd. 126 127 > \date September 2012 128 129 > \ingroup auxOTHERcomputational 130 131 ===================================================================== igraphdlasq6_(integer * i0,integer * n0,doublereal * z__,integer * pp,doublereal * dmin__,doublereal * dmin1,doublereal * dmin2,doublereal * dn,doublereal * dnm1,doublereal * dnm2)132 Subroutine */ int igraphdlasq6_(integer *i0, integer *n0, doublereal *z__, 133 integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, 134 doublereal *dn, doublereal *dnm1, doublereal *dnm2) 135 { 136 /* System generated locals */ 137 integer i__1; 138 doublereal d__1, d__2; 139 140 /* Local variables */ 141 doublereal d__; 142 integer j4, j4p2; 143 doublereal emin, temp; 144 extern doublereal igraphdlamch_(char *); 145 doublereal safmin; 146 147 148 /* -- LAPACK computational routine (version 3.4.2) -- 149 -- LAPACK is a software package provided by Univ. of Tennessee, -- 150 -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 151 September 2012 152 153 154 ===================================================================== 155 156 157 Parameter adjustments */ 158 --z__; 159 160 /* Function Body */ 161 if (*n0 - *i0 - 1 <= 0) { 162 return 0; 163 } 164 165 safmin = igraphdlamch_("Safe minimum"); 166 j4 = (*i0 << 2) + *pp - 3; 167 emin = z__[j4 + 4]; 168 d__ = z__[j4]; 169 *dmin__ = d__; 170 171 if (*pp == 0) { 172 i__1 = *n0 - 3 << 2; 173 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { 174 z__[j4 - 2] = d__ + z__[j4 - 1]; 175 if (z__[j4 - 2] == 0.) { 176 z__[j4] = 0.; 177 d__ = z__[j4 + 1]; 178 *dmin__ = d__; 179 emin = 0.; 180 } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 181 - 2] < z__[j4 + 1]) { 182 temp = z__[j4 + 1] / z__[j4 - 2]; 183 z__[j4] = z__[j4 - 1] * temp; 184 d__ *= temp; 185 } else { 186 z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); 187 d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); 188 } 189 *dmin__ = min(*dmin__,d__); 190 /* Computing MIN */ 191 d__1 = emin, d__2 = z__[j4]; 192 emin = min(d__1,d__2); 193 /* L10: */ 194 } 195 } else { 196 i__1 = *n0 - 3 << 2; 197 for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { 198 z__[j4 - 3] = d__ + z__[j4]; 199 if (z__[j4 - 3] == 0.) { 200 z__[j4 - 1] = 0.; 201 d__ = z__[j4 + 2]; 202 *dmin__ = d__; 203 emin = 0.; 204 } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 205 - 3] < z__[j4 + 2]) { 206 temp = z__[j4 + 2] / z__[j4 - 3]; 207 z__[j4 - 1] = z__[j4] * temp; 208 d__ *= temp; 209 } else { 210 z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); 211 d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); 212 } 213 *dmin__ = min(*dmin__,d__); 214 /* Computing MIN */ 215 d__1 = emin, d__2 = z__[j4 - 1]; 216 emin = min(d__1,d__2); 217 /* L20: */ 218 } 219 } 220 221 /* Unroll last two steps. */ 222 223 *dnm2 = d__; 224 *dmin2 = *dmin__; 225 j4 = (*n0 - 2 << 2) - *pp; 226 j4p2 = j4 + (*pp << 1) - 1; 227 z__[j4 - 2] = *dnm2 + z__[j4p2]; 228 if (z__[j4 - 2] == 0.) { 229 z__[j4] = 0.; 230 *dnm1 = z__[j4p2 + 2]; 231 *dmin__ = *dnm1; 232 emin = 0.; 233 } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < 234 z__[j4p2 + 2]) { 235 temp = z__[j4p2 + 2] / z__[j4 - 2]; 236 z__[j4] = z__[j4p2] * temp; 237 *dnm1 = *dnm2 * temp; 238 } else { 239 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); 240 *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); 241 } 242 *dmin__ = min(*dmin__,*dnm1); 243 244 *dmin1 = *dmin__; 245 j4 += 4; 246 j4p2 = j4 + (*pp << 1) - 1; 247 z__[j4 - 2] = *dnm1 + z__[j4p2]; 248 if (z__[j4 - 2] == 0.) { 249 z__[j4] = 0.; 250 *dn = z__[j4p2 + 2]; 251 *dmin__ = *dn; 252 emin = 0.; 253 } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < 254 z__[j4p2 + 2]) { 255 temp = z__[j4p2 + 2] / z__[j4 - 2]; 256 z__[j4] = z__[j4p2] * temp; 257 *dn = *dnm1 * temp; 258 } else { 259 z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); 260 *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); 261 } 262 *dmin__ = min(*dmin__,*dn); 263 264 z__[j4 + 2] = *dn; 265 z__[(*n0 << 2) - *pp] = emin; 266 return 0; 267 268 /* End of DLASQ6 */ 269 270 } /* igraphdlasq6_ */ 271 272