1 /* srotm.f -- translated by f2c (version 20100827). 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 "datatypes.h" 14 15 /* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy, 16 integer *incy, real *sparam) 17 { 18 /* Initialized data */ 19 20 static real zero = 0.f; 21 static real two = 2.f; 22 23 /* System generated locals */ 24 integer i__1, i__2; 25 26 /* Local variables */ 27 integer i__; 28 real w, z__; 29 integer kx, ky; 30 real sh11, sh12, sh21, sh22, sflag; 31 integer nsteps; 32 33 /* .. Scalar Arguments .. */ 34 /* .. */ 35 /* .. Array Arguments .. */ 36 /* .. */ 37 38 /* Purpose */ 39 /* ======= */ 40 41 /* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ 42 43 /* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */ 44 /* (DX**T) */ 45 46 /* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ 47 /* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */ 48 /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ 49 50 /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ 51 52 /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ 53 /* H=( ) ( ) ( ) ( ) */ 54 /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ 55 /* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */ 56 57 58 /* Arguments */ 59 /* ========= */ 60 61 /* N (input) INTEGER */ 62 /* number of elements in input vector(s) */ 63 64 /* SX (input/output) REAL array, dimension N */ 65 /* double precision vector with N elements */ 66 67 /* INCX (input) INTEGER */ 68 /* storage spacing between elements of SX */ 69 70 /* SY (input/output) REAL array, dimension N */ 71 /* double precision vector with N elements */ 72 73 /* INCY (input) INTEGER */ 74 /* storage spacing between elements of SY */ 75 76 /* SPARAM (input/output) REAL array, dimension 5 */ 77 /* SPARAM(1)=SFLAG */ 78 /* SPARAM(2)=SH11 */ 79 /* SPARAM(3)=SH21 */ 80 /* SPARAM(4)=SH12 */ 81 /* SPARAM(5)=SH22 */ 82 83 /* ===================================================================== */ 84 85 /* .. Local Scalars .. */ 86 /* .. */ 87 /* .. Data statements .. */ 88 /* Parameter adjustments */ 89 --sparam; 90 --sy; 91 --sx; 92 93 /* Function Body */ 94 /* .. */ 95 96 sflag = sparam[1]; 97 if (*n <= 0 || sflag + two == zero) { 98 goto L140; 99 } 100 if (! (*incx == *incy && *incx > 0)) { 101 goto L70; 102 } 103 104 nsteps = *n * *incx; 105 if (sflag < 0.f) { 106 goto L50; 107 } else if (sflag == 0) { 108 goto L10; 109 } else { 110 goto L30; 111 } 112 L10: 113 sh12 = sparam[4]; 114 sh21 = sparam[3]; 115 i__1 = nsteps; 116 i__2 = *incx; 117 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { 118 w = sx[i__]; 119 z__ = sy[i__]; 120 sx[i__] = w + z__ * sh12; 121 sy[i__] = w * sh21 + z__; 122 /* L20: */ 123 } 124 goto L140; 125 L30: 126 sh11 = sparam[2]; 127 sh22 = sparam[5]; 128 i__2 = nsteps; 129 i__1 = *incx; 130 for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { 131 w = sx[i__]; 132 z__ = sy[i__]; 133 sx[i__] = w * sh11 + z__; 134 sy[i__] = -w + sh22 * z__; 135 /* L40: */ 136 } 137 goto L140; 138 L50: 139 sh11 = sparam[2]; 140 sh12 = sparam[4]; 141 sh21 = sparam[3]; 142 sh22 = sparam[5]; 143 i__1 = nsteps; 144 i__2 = *incx; 145 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { 146 w = sx[i__]; 147 z__ = sy[i__]; 148 sx[i__] = w * sh11 + z__ * sh12; 149 sy[i__] = w * sh21 + z__ * sh22; 150 /* L60: */ 151 } 152 goto L140; 153 L70: 154 kx = 1; 155 ky = 1; 156 if (*incx < 0) { 157 kx = (1 - *n) * *incx + 1; 158 } 159 if (*incy < 0) { 160 ky = (1 - *n) * *incy + 1; 161 } 162 163 if (sflag < 0.f) { 164 goto L120; 165 } else if (sflag == 0) { 166 goto L80; 167 } else { 168 goto L100; 169 } 170 L80: 171 sh12 = sparam[4]; 172 sh21 = sparam[3]; 173 i__2 = *n; 174 for (i__ = 1; i__ <= i__2; ++i__) { 175 w = sx[kx]; 176 z__ = sy[ky]; 177 sx[kx] = w + z__ * sh12; 178 sy[ky] = w * sh21 + z__; 179 kx += *incx; 180 ky += *incy; 181 /* L90: */ 182 } 183 goto L140; 184 L100: 185 sh11 = sparam[2]; 186 sh22 = sparam[5]; 187 i__2 = *n; 188 for (i__ = 1; i__ <= i__2; ++i__) { 189 w = sx[kx]; 190 z__ = sy[ky]; 191 sx[kx] = w * sh11 + z__; 192 sy[ky] = -w + sh22 * z__; 193 kx += *incx; 194 ky += *incy; 195 /* L110: */ 196 } 197 goto L140; 198 L120: 199 sh11 = sparam[2]; 200 sh12 = sparam[4]; 201 sh21 = sparam[3]; 202 sh22 = sparam[5]; 203 i__2 = *n; 204 for (i__ = 1; i__ <= i__2; ++i__) { 205 w = sx[kx]; 206 z__ = sy[ky]; 207 sx[kx] = w * sh11 + z__ * sh12; 208 sy[ky] = w * sh21 + z__ * sh22; 209 kx += *incx; 210 ky += *incy; 211 /* L130: */ 212 } 213 L140: 214 return 0; 215 } /* srotm_ */ 216 217
