cgerc.c 5.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217
  1. /* cgerc.f -- translated by f2c (version 20061008).
  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 "f2c.h"
  12. #include "blaswrap.h"
  13. /* Subroutine */ int cgerc_(integer *m, integer *n, complex *alpha, complex *
  14. x, integer *incx, complex *y, integer *incy, complex *a, integer *lda)
  15. {
  16. /* System generated locals */
  17. integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
  18. complex q__1, q__2;
  19. /* Builtin functions */
  20. void r_cnjg(complex *, complex *);
  21. /* Local variables */
  22. integer i__, j, ix, jy, kx, info;
  23. complex temp;
  24. extern /* Subroutine */ int xerbla_(char *, integer *);
  25. /* .. Scalar Arguments .. */
  26. /* .. */
  27. /* .. Array Arguments .. */
  28. /* .. */
  29. /* Purpose */
  30. /* ======= */
  31. /* CGERC performs the rank 1 operation */
  32. /* A := alpha*x*conjg( y' ) + A, */
  33. /* where alpha is a scalar, x is an m element vector, y is an n element */
  34. /* vector and A is an m by n matrix. */
  35. /* Arguments */
  36. /* ========== */
  37. /* M - INTEGER. */
  38. /* On entry, M specifies the number of rows of the matrix A. */
  39. /* M must be at least zero. */
  40. /* Unchanged on exit. */
  41. /* N - INTEGER. */
  42. /* On entry, N specifies the number of columns of the matrix A. */
  43. /* N must be at least zero. */
  44. /* Unchanged on exit. */
  45. /* ALPHA - COMPLEX . */
  46. /* On entry, ALPHA specifies the scalar alpha. */
  47. /* Unchanged on exit. */
  48. /* X - COMPLEX array of dimension at least */
  49. /* ( 1 + ( m - 1 )*abs( INCX ) ). */
  50. /* Before entry, the incremented array X must contain the m */
  51. /* element vector x. */
  52. /* Unchanged on exit. */
  53. /* INCX - INTEGER. */
  54. /* On entry, INCX specifies the increment for the elements of */
  55. /* X. INCX must not be zero. */
  56. /* Unchanged on exit. */
  57. /* Y - COMPLEX array of dimension at least */
  58. /* ( 1 + ( n - 1 )*abs( INCY ) ). */
  59. /* Before entry, the incremented array Y must contain the n */
  60. /* element vector y. */
  61. /* Unchanged on exit. */
  62. /* INCY - INTEGER. */
  63. /* On entry, INCY specifies the increment for the elements of */
  64. /* Y. INCY must not be zero. */
  65. /* Unchanged on exit. */
  66. /* A - COMPLEX array of DIMENSION ( LDA, n ). */
  67. /* Before entry, the leading m by n part of the array A must */
  68. /* contain the matrix of coefficients. On exit, A is */
  69. /* overwritten by the updated matrix. */
  70. /* LDA - INTEGER. */
  71. /* On entry, LDA specifies the first dimension of A as declared */
  72. /* in the calling (sub) program. LDA must be at least */
  73. /* max( 1, m ). */
  74. /* Unchanged on exit. */
  75. /* Level 2 Blas routine. */
  76. /* -- Written on 22-October-1986. */
  77. /* Jack Dongarra, Argonne National Lab. */
  78. /* Jeremy Du Croz, Nag Central Office. */
  79. /* Sven Hammarling, Nag Central Office. */
  80. /* Richard Hanson, Sandia National Labs. */
  81. /* .. Parameters .. */
  82. /* .. */
  83. /* .. Local Scalars .. */
  84. /* .. */
  85. /* .. External Subroutines .. */
  86. /* .. */
  87. /* .. Intrinsic Functions .. */
  88. /* .. */
  89. /* Test the input parameters. */
  90. /* Parameter adjustments */
  91. --x;
  92. --y;
  93. a_dim1 = *lda;
  94. a_offset = 1 + a_dim1;
  95. a -= a_offset;
  96. /* Function Body */
  97. info = 0;
  98. if (*m < 0) {
  99. info = 1;
  100. } else if (*n < 0) {
  101. info = 2;
  102. } else if (*incx == 0) {
  103. info = 5;
  104. } else if (*incy == 0) {
  105. info = 7;
  106. } else if (*lda < max(1,*m)) {
  107. info = 9;
  108. }
  109. if (info != 0) {
  110. xerbla_("CGERC ", &info);
  111. return 0;
  112. }
  113. /* Quick return if possible. */
  114. if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
  115. return 0;
  116. }
  117. /* Start the operations. In this version the elements of A are */
  118. /* accessed sequentially with one pass through A. */
  119. if (*incy > 0) {
  120. jy = 1;
  121. } else {
  122. jy = 1 - (*n - 1) * *incy;
  123. }
  124. if (*incx == 1) {
  125. i__1 = *n;
  126. for (j = 1; j <= i__1; ++j) {
  127. i__2 = jy;
  128. if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
  129. r_cnjg(&q__2, &y[jy]);
  130. q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
  131. alpha->r * q__2.i + alpha->i * q__2.r;
  132. temp.r = q__1.r, temp.i = q__1.i;
  133. i__2 = *m;
  134. for (i__ = 1; i__ <= i__2; ++i__) {
  135. i__3 = i__ + j * a_dim1;
  136. i__4 = i__ + j * a_dim1;
  137. i__5 = i__;
  138. q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
  139. x[i__5].r * temp.i + x[i__5].i * temp.r;
  140. q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
  141. a[i__3].r = q__1.r, a[i__3].i = q__1.i;
  142. /* L10: */
  143. }
  144. }
  145. jy += *incy;
  146. /* L20: */
  147. }
  148. } else {
  149. if (*incx > 0) {
  150. kx = 1;
  151. } else {
  152. kx = 1 - (*m - 1) * *incx;
  153. }
  154. i__1 = *n;
  155. for (j = 1; j <= i__1; ++j) {
  156. i__2 = jy;
  157. if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
  158. r_cnjg(&q__2, &y[jy]);
  159. q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
  160. alpha->r * q__2.i + alpha->i * q__2.r;
  161. temp.r = q__1.r, temp.i = q__1.i;
  162. ix = kx;
  163. i__2 = *m;
  164. for (i__ = 1; i__ <= i__2; ++i__) {
  165. i__3 = i__ + j * a_dim1;
  166. i__4 = i__ + j * a_dim1;
  167. i__5 = ix;
  168. q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
  169. x[i__5].r * temp.i + x[i__5].i * temp.r;
  170. q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
  171. a[i__3].r = q__1.r, a[i__3].i = q__1.i;
  172. ix += *incx;
  173. /* L30: */
  174. }
  175. }
  176. jy += *incy;
  177. /* L40: */
  178. }
  179. }
  180. return 0;
  181. /* End of CGERC . */
  182. } /* cgerc_ */