2
3
4
5
6
7
8
9 CHARACTER*1 UPLO
10 INTEGER IOFFD, LDA, M, N
11 DOUBLE PRECISION ALPHA
12
13
14 COMPLEX*16 A( LDA, * )
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108 DOUBLE PRECISION RONE, RZERO
109 parameter( rone = 1.0d+0, rzero = 0.0d+0 )
110 COMPLEX*16 ZERO
111 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
112
113
114 INTEGER J, JTMP, MN
115
116
118
119
120 LOGICAL LSAME
122
123
124 INTRINSIC dble, dcmplx,
max,
min
125
126
127
128
129
130 IF( m.LE.0 .OR. n.LE.0 )
131 $ RETURN
132
133
134
135 IF( alpha.EQ.rone ) THEN
136
137
138
139 IF(
lsame( uplo,
'L' ).OR.
lsame( uplo,
'U' ).OR.
140 $
lsame( uplo,
'D' ) )
THEN
141 DO 10 j =
max( 0, -ioffd ) + 1,
min( m - ioffd, n )
142 jtmp = j + ioffd
143 a( jtmp, j ) = dcmplx( dble( a( jtmp, j ) ), rzero )
144 10 CONTINUE
145 END IF
146 RETURN
147 ELSE IF( alpha.EQ.rzero ) THEN
148 CALL ztzpad( uplo,
'N', m, n, ioffd, zero, zero, a, lda )
149 RETURN
150 END IF
151
152 IF(
lsame( uplo,
'L' ) )
THEN
153
154
155
156 mn =
max( 0, -ioffd )
157 DO 20 j = 1,
min( mn, n )
158 CALL zdscal( m, alpha, a( 1, j ), 1 )
159 20 CONTINUE
160 DO 30 j = mn + 1,
min( m - ioffd, n )
161 jtmp = j + ioffd
162 a( jtmp, j ) = dcmplx( alpha * dble( a( jtmp, j ) ), rzero )
163 IF( m.GT.jtmp )
164 $ CALL zdscal( m-jtmp, alpha, a( jtmp + 1, j ), 1 )
165 30 CONTINUE
166
167 ELSE IF(
lsame( uplo,
'U' ) )
THEN
168
169
170
171 mn =
min( m - ioffd, n )
172 DO 40 j =
max( 0, -ioffd ) + 1, mn
173 jtmp = j + ioffd
174 CALL zdscal( jtmp - 1, alpha, a( 1, j ), 1 )
175 a( jtmp, j ) = dcmplx( alpha * dble( a( jtmp, j ) ), rzero )
176 40 CONTINUE
177 DO 50 j =
max( 0, mn ) + 1, n
178 CALL zdscal( m, alpha, a( 1, j ), 1 )
179 50 CONTINUE
180
181 ELSE IF(
lsame( uplo,
'D' ) )
THEN
182
183
184
185 DO 60 j =
max( 0, -ioffd ) + 1,
min( m - ioffd, n )
186 jtmp = j + ioffd
187 a( jtmp, j ) = dcmplx( alpha * dble( a( jtmp, j ) ), rzero )
188 60 CONTINUE
189
190 ELSE
191
192
193
194 DO 70 j = 1, n
195 CALL zdscal( m, alpha, a( 1, j ), 1 )
196 70 CONTINUE
197
198 END IF
199
200 RETURN
201
202
203
subroutine ztzpad(uplo, herm, m, n, ioffd, alpha, beta, a, lda)