You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

293 lines
6.0 KiB

  1. /* drotmg.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. http://www.netlib.org/f2c/libf2c.zip
  10. */
  11. #include "datatypes.h"
  12. /* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal *
  13. dx1, doublereal *dy1, doublereal *dparam)
  14. {
  15. /* Initialized data */
  16. static doublereal zero = 0.;
  17. static doublereal one = 1.;
  18. static doublereal two = 2.;
  19. static doublereal gam = 4096.;
  20. static doublereal gamsq = 16777216.;
  21. static doublereal rgamsq = 5.9604645e-8;
  22. /* Format strings */
  23. static char fmt_120[] = "";
  24. static char fmt_150[] = "";
  25. static char fmt_180[] = "";
  26. static char fmt_210[] = "";
  27. /* System generated locals */
  28. doublereal d__1;
  29. /* Local variables */
  30. doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22;
  31. integer igo;
  32. doublereal dflag, dtemp;
  33. /* Assigned format variables */
  34. static char *igo_fmt;
  35. /* .. Scalar Arguments .. */
  36. /* .. */
  37. /* .. Array Arguments .. */
  38. /* .. */
  39. /* Purpose */
  40. /* ======= */
  41. /* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
  42. /* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */
  43. /* DY2)**T. */
  44. /* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
  45. /* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
  46. /* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
  47. /* H=( ) ( ) ( ) ( ) */
  48. /* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
  49. /* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */
  50. /* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */
  51. /* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */
  52. /* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
  53. /* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
  54. /* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
  55. /* Arguments */
  56. /* ========= */
  57. /* DD1 (input/output) DOUBLE PRECISION */
  58. /* DD2 (input/output) DOUBLE PRECISION */
  59. /* DX1 (input/output) DOUBLE PRECISION */
  60. /* DY1 (input) DOUBLE PRECISION */
  61. /* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */
  62. /* DPARAM(1)=DFLAG */
  63. /* DPARAM(2)=DH11 */
  64. /* DPARAM(3)=DH21 */
  65. /* DPARAM(4)=DH12 */
  66. /* DPARAM(5)=DH22 */
  67. /* ===================================================================== */
  68. /* .. Local Scalars .. */
  69. /* .. */
  70. /* .. Intrinsic Functions .. */
  71. /* .. */
  72. /* .. Data statements .. */
  73. /* Parameter adjustments */
  74. --dparam;
  75. /* Function Body */
  76. /* .. */
  77. if (! (*dd1 < zero)) {
  78. goto L10;
  79. }
  80. /* GO ZERO-H-D-AND-DX1.. */
  81. goto L60;
  82. L10:
  83. /* CASE-DD1-NONNEGATIVE */
  84. dp2 = *dd2 * *dy1;
  85. if (! (dp2 == zero)) {
  86. goto L20;
  87. }
  88. dflag = -two;
  89. goto L260;
  90. /* REGULAR-CASE.. */
  91. L20:
  92. dp1 = *dd1 * *dx1;
  93. dq2 = dp2 * *dy1;
  94. dq1 = dp1 * *dx1;
  95. if (! (abs(dq1) > abs(dq2))) {
  96. goto L40;
  97. }
  98. dh21 = -(*dy1) / *dx1;
  99. dh12 = dp2 / dp1;
  100. du = one - dh12 * dh21;
  101. if (! (du <= zero)) {
  102. goto L30;
  103. }
  104. /* GO ZERO-H-D-AND-DX1.. */
  105. goto L60;
  106. L30:
  107. dflag = zero;
  108. *dd1 /= du;
  109. *dd2 /= du;
  110. *dx1 *= du;
  111. /* GO SCALE-CHECK.. */
  112. goto L100;
  113. L40:
  114. if (! (dq2 < zero)) {
  115. goto L50;
  116. }
  117. /* GO ZERO-H-D-AND-DX1.. */
  118. goto L60;
  119. L50:
  120. dflag = one;
  121. dh11 = dp1 / dp2;
  122. dh22 = *dx1 / *dy1;
  123. du = one + dh11 * dh22;
  124. dtemp = *dd2 / du;
  125. *dd2 = *dd1 / du;
  126. *dd1 = dtemp;
  127. *dx1 = *dy1 * du;
  128. /* GO SCALE-CHECK */
  129. goto L100;
  130. /* PROCEDURE..ZERO-H-D-AND-DX1.. */
  131. L60:
  132. dflag = -one;
  133. dh11 = zero;
  134. dh12 = zero;
  135. dh21 = zero;
  136. dh22 = zero;
  137. *dd1 = zero;
  138. *dd2 = zero;
  139. *dx1 = zero;
  140. /* RETURN.. */
  141. goto L220;
  142. /* PROCEDURE..FIX-H.. */
  143. L70:
  144. if (! (dflag >= zero)) {
  145. goto L90;
  146. }
  147. if (! (dflag == zero)) {
  148. goto L80;
  149. }
  150. dh11 = one;
  151. dh22 = one;
  152. dflag = -one;
  153. goto L90;
  154. L80:
  155. dh21 = -one;
  156. dh12 = one;
  157. dflag = -one;
  158. L90:
  159. switch (igo) {
  160. case 0: goto L120;
  161. case 1: goto L150;
  162. case 2: goto L180;
  163. case 3: goto L210;
  164. }
  165. /* PROCEDURE..SCALE-CHECK */
  166. L100:
  167. L110:
  168. if (! (*dd1 <= rgamsq)) {
  169. goto L130;
  170. }
  171. if (*dd1 == zero) {
  172. goto L160;
  173. }
  174. igo = 0;
  175. igo_fmt = fmt_120;
  176. /* FIX-H.. */
  177. goto L70;
  178. L120:
  179. /* Computing 2nd power */
  180. d__1 = gam;
  181. *dd1 *= d__1 * d__1;
  182. *dx1 /= gam;
  183. dh11 /= gam;
  184. dh12 /= gam;
  185. goto L110;
  186. L130:
  187. L140:
  188. if (! (*dd1 >= gamsq)) {
  189. goto L160;
  190. }
  191. igo = 1;
  192. igo_fmt = fmt_150;
  193. /* FIX-H.. */
  194. goto L70;
  195. L150:
  196. /* Computing 2nd power */
  197. d__1 = gam;
  198. *dd1 /= d__1 * d__1;
  199. *dx1 *= gam;
  200. dh11 *= gam;
  201. dh12 *= gam;
  202. goto L140;
  203. L160:
  204. L170:
  205. if (! (abs(*dd2) <= rgamsq)) {
  206. goto L190;
  207. }
  208. if (*dd2 == zero) {
  209. goto L220;
  210. }
  211. igo = 2;
  212. igo_fmt = fmt_180;
  213. /* FIX-H.. */
  214. goto L70;
  215. L180:
  216. /* Computing 2nd power */
  217. d__1 = gam;
  218. *dd2 *= d__1 * d__1;
  219. dh21 /= gam;
  220. dh22 /= gam;
  221. goto L170;
  222. L190:
  223. L200:
  224. if (! (abs(*dd2) >= gamsq)) {
  225. goto L220;
  226. }
  227. igo = 3;
  228. igo_fmt = fmt_210;
  229. /* FIX-H.. */
  230. goto L70;
  231. L210:
  232. /* Computing 2nd power */
  233. d__1 = gam;
  234. *dd2 /= d__1 * d__1;
  235. dh21 *= gam;
  236. dh22 *= gam;
  237. goto L200;
  238. L220:
  239. if (dflag < 0.) {
  240. goto L250;
  241. } else if (dflag == 0) {
  242. goto L230;
  243. } else {
  244. goto L240;
  245. }
  246. L230:
  247. dparam[3] = dh21;
  248. dparam[4] = dh12;
  249. goto L260;
  250. L240:
  251. dparam[2] = dh11;
  252. dparam[5] = dh22;
  253. goto L260;
  254. L250:
  255. dparam[2] = dh11;
  256. dparam[3] = dh21;
  257. dparam[4] = dh12;
  258. dparam[5] = dh22;
  259. L260:
  260. dparam[1] = dflag;
  261. return 0;
  262. } /* drotmg_ */