← Back to branch summary

~ubuntu-branches/ubuntu/wily/julia/wily

« back to all changes in this revision

Viewing changes to deps/openlibm/slatec/cher.f

  • Committer: Package Import Robot
  • Author(s): Sébastien Villemot
  • Date: 2013-01-16 12:29:42 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20130116122942-x86e42akjq31repw
Tags: 0.0.0+20130107.gitd9656f41-1
* New upstream snashot
* No longer try to rebuild helpdb.jl.
   + debian/rules: remove helpdb.jl from build-arch rule
   + debian/control: move back python-sphinx to Build-Depends-Indep
* debian/copyright: reflect upstream changes
* Add Build-Conflicts on libatlas3-base (makes linalg tests fail)
* debian/rules: replace obsolete USE_DEBIAN makeflag by a list of
  USE_SYSTEM_* flags
* debian/rules: on non-x86 systems, use libm instead of openlibm
* dpkg-buildflags.patch: remove patch, applied upstream
* Refreshed other patches

Show diffs side-by-side

added added

removed removed

Lines of Context:
deps/openlibm/slatec/cher.f
 
1
*DECK CHER
 
2
      SUBROUTINE CHER (UPLO, N, ALPHA, X, INCX, A, LDA)
 
3
C***BEGIN PROLOGUE  CHER
 
4
C***PURPOSE  Perform Hermitian rank 1 update of a complex Hermitian
 
5
C            matrix.
 
6
C***LIBRARY   SLATEC (BLAS)
 
7
C***CATEGORY  D1B4
 
8
C***TYPE      COMPLEX (SHER-S, DHER-D, CHER-C)
 
9
C***KEYWORDS  LEVEL 2 BLAS, LINEAR ALGEBRA
 
10
C***AUTHOR  Dongarra, J. J., (ANL)
 
11
C           Du Croz, J., (NAG)
 
12
C           Hammarling, S., (NAG)
 
13
C           Hanson, R. J., (SNLA)
 
14
C***DESCRIPTION
 
15
C
 
16
C  CHER   performs the hermitian rank 1 operation
 
17
C
 
18
C     A := alpha*x*conjg( x') + A,
 
19
C
 
20
C  where alpha is a real scalar, x is an n element vector and A is an
 
21
C  n by n hermitian matrix.
 
22
C
 
23
C  Parameters
 
24
C  ==========
 
25
C
 
26
C  UPLO   - CHARACTER*1.
 
27
C           On entry, UPLO specifies whether the upper or lower
 
28
C           triangular part of the array A is to be referenced as
 
29
C           follows:
 
30
C
 
31
C              UPLO = 'U' or 'u'   Only the upper triangular part of A
 
32
C                                  is to be referenced.
 
33
C
 
34
C              UPLO = 'L' or 'l'   Only the lower triangular part of A
 
35
C                                  is to be referenced.
 
36
C
 
37
C           Unchanged on exit.
 
38
C
 
39
C  N      - INTEGER.
 
40
C           On entry, N specifies the order of the matrix A.
 
41
C           N must be at least zero.
 
42
C           Unchanged on exit.
 
43
C
 
44
C  ALPHA  - REAL            .
 
45
C           On entry, ALPHA specifies the scalar alpha.
 
46
C           Unchanged on exit.
 
47
C
 
48
C  X      - COMPLEX          array of dimension at least
 
49
C           ( 1 + ( n - 1 )*abs( INCX ) ).
 
50
C           Before entry, the incremented array X must contain the n
 
51
C           element vector x.
 
52
C           Unchanged on exit.
 
53
C
 
54
C  INCX   - INTEGER.
 
55
C           On entry, INCX specifies the increment for the elements of
 
56
C           X. INCX must not be zero.
 
57
C           Unchanged on exit.
 
58
C
 
59
C  A      - COMPLEX          array of DIMENSION ( LDA, n ).
 
60
C           Before entry with  UPLO = 'U' or 'u', the leading n by n
 
61
C           upper triangular part of the array A must contain the upper
 
62
C           triangular part of the hermitian matrix and the strictly
 
63
C           lower triangular part of A is not referenced. On exit, the
 
64
C           upper triangular part of the array A is overwritten by the
 
65
C           upper triangular part of the updated matrix.
 
66
C           Before entry with UPLO = 'L' or 'l', the leading n by n
 
67
C           lower triangular part of the array A must contain the lower
 
68
C           triangular part of the hermitian matrix and the strictly
 
69
C           upper triangular part of A is not referenced. On exit, the
 
70
C           lower triangular part of the array A is overwritten by the
 
71
C           lower triangular part of the updated matrix.
 
72
C           Note that the imaginary parts of the diagonal elements need
 
73
C           not be set, they are assumed to be zero, and on exit they
 
74
C           are set to zero.
 
75
C
 
76
C  LDA    - INTEGER.
 
77
C           On entry, LDA specifies the first dimension of A as declared
 
78
C           in the calling (sub) program. LDA must be at least
 
79
C           max( 1, n ).
 
80
C           Unchanged on exit.
 
81
C
 
82
C***REFERENCES  Dongarra, J. J., Du Croz, J., Hammarling, S., and
 
83
C                 Hanson, R. J.  An extended set of Fortran basic linear
 
84
C                 algebra subprograms.  ACM TOMS, Vol. 14, No. 1,
 
85
C                 pp. 1-17, March 1988.
 
86
C***ROUTINES CALLED  LSAME, XERBLA
 
87
C***REVISION HISTORY  (YYMMDD)
 
88
C   861022  DATE WRITTEN
 
89
C   910605  Modified to meet SLATEC prologue standards.  Only comment
 
90
C           lines were modified.  (BKS)
 
91
C***END PROLOGUE  CHER
 
92
C     .. Scalar Arguments ..
 
93
      REAL               ALPHA
 
94
      INTEGER            INCX, LDA, N
 
95
      CHARACTER*1        UPLO
 
96
C     .. Array Arguments ..
 
97
      COMPLEX            A( LDA, * ), X( * )
 
98
C     .. Parameters ..
 
99
      COMPLEX            ZERO
 
100
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
 
101
C     .. Local Scalars ..
 
102
      COMPLEX            TEMP
 
103
      INTEGER            I, INFO, IX, J, JX, KX
 
104
C     .. External Functions ..
 
105
      LOGICAL            LSAME
 
106
      EXTERNAL           LSAME
 
107
C     .. External Subroutines ..
 
108
      EXTERNAL           XERBLA
 
109
C     .. Intrinsic Functions ..
 
110
      INTRINSIC          CONJG, MAX, REAL
 
111
C***FIRST EXECUTABLE STATEMENT  CHER
 
112
C
 
113
C     Test the input parameters.
 
114
C
 
115
      INFO = 0
 
116
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
 
117
     $         .NOT.LSAME( UPLO, 'L' )      )THEN
 
118
         INFO = 1
 
119
      ELSE IF( N.LT.0 )THEN
 
120
         INFO = 2
 
121
      ELSE IF( INCX.EQ.0 )THEN
 
122
         INFO = 5
 
123
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
 
124
         INFO = 7
 
125
      END IF
 
126
      IF( INFO.NE.0 )THEN
 
127
         CALL XERBLA( 'CHER  ', INFO )
 
128
         RETURN
 
129
      END IF
 
130
C
 
131
C     Quick return if possible.
 
132
C
 
133
      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.REAL( ZERO ) ) )
 
134
     $   RETURN
 
135
C
 
136
C     Set the start point in X if the increment is not unity.
 
137
C
 
138
      IF( INCX.LE.0 )THEN
 
139
         KX = 1 - ( N - 1 )*INCX
 
140
      ELSE IF( INCX.NE.1 )THEN
 
141
         KX = 1
 
142
      END IF
 
143
C
 
144
C     Start the operations. In this version the elements of A are
 
145
C     accessed sequentially with one pass through the triangular part
 
146
C     of A.
 
147
C
 
148
      IF( LSAME( UPLO, 'U' ) )THEN
 
149
C
 
150
C        Form  A  when A is stored in upper triangle.
 
151
C
 
152
         IF( INCX.EQ.1 )THEN
 
153
            DO 20, J = 1, N
 
154
               IF( X( J ).NE.ZERO )THEN
 
155
                  TEMP = ALPHA*CONJG( X( J ) )
 
156
                  DO 10, I = 1, J - 1
 
157
                     A( I, J ) = A( I, J ) + X( I )*TEMP
 
158
   10             CONTINUE
 
159
                  A( J, J ) = REAL( A( J, J ) ) + REAL( X( J )*TEMP )
 
160
               ELSE
 
161
                  A( J, J ) = REAL( A( J, J ) )
 
162
               END IF
 
163
   20       CONTINUE
 
164
         ELSE
 
165
            JX = KX
 
166
            DO 40, J = 1, N
 
167
               IF( X( JX ).NE.ZERO )THEN
 
168
                  TEMP = ALPHA*CONJG( X( JX ) )
 
169
                  IX   = KX
 
170
                  DO 30, I = 1, J - 1
 
171
                     A( I, J ) = A( I, J ) + X( IX )*TEMP
 
172
                     IX        = IX        + INCX
 
173
   30             CONTINUE
 
174
                  A( J, J ) = REAL( A( J, J ) ) + REAL( X( JX )*TEMP )
 
175
               ELSE
 
176
                  A( J, J ) = REAL( A( J, J ) )
 
177
               END IF
 
178
               JX = JX + INCX
 
179
   40       CONTINUE
 
180
         END IF
 
181
      ELSE
 
182
C
 
183
C        Form  A  when A is stored in lower triangle.
 
184
C
 
185
         IF( INCX.EQ.1 )THEN
 
186
            DO 60, J = 1, N
 
187
               IF( X( J ).NE.ZERO )THEN
 
188
                  TEMP      = ALPHA*CONJG( X( J ) )
 
189
                  A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( J ) )
 
190
                  DO 50, I = J + 1, N
 
191
                     A( I, J ) = A( I, J ) + X( I )*TEMP
 
192
   50             CONTINUE
 
193
               ELSE
 
194
                  A( J, J ) = REAL( A( J, J ) )
 
195
               END IF
 
196
   60       CONTINUE
 
197
         ELSE
 
198
            JX = KX
 
199
            DO 80, J = 1, N
 
200
               IF( X( JX ).NE.ZERO )THEN
 
201
                  TEMP      = ALPHA*CONJG( X( JX ) )
 
202
                  A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( JX ) )
 
203
                  IX        = JX
 
204
                  DO 70, I = J + 1, N
 
205
                     IX        = IX        + INCX
 
206
                     A( I, J ) = A( I, J ) + X( IX )*TEMP
 
207
   70             CONTINUE
 
208
               ELSE
 
209
                  A( J, J ) = REAL( A( J, J ) )
 
210
               END IF
 
211
               JX = JX + INCX
 
212
   80       CONTINUE
 
213
         END IF
 
214
      END IF
 
215
C
 
216
      RETURN
 
217
C
 
218
C     End of CHER  .
 
219
C
 
220
      END