131
132
133
134
135
136
137 CHARACTER DIAG, TRANS, UPLO
138 INTEGER INFO, LDB, N, NRHS
139
140
141 INTEGER IPIV( * )
142 COMPLEX*16 A( * ), B( LDB, * )
143
144
145
146
147
148 COMPLEX*16 ONE
149 parameter( one = ( 1.0d+0, 0.0d+0 ) )
150
151
152 LOGICAL NOUNIT
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX*16 D11, D12, D21, D22, T1, T2
155
156
157 LOGICAL LSAME
159
160
162
163
164 INTRINSIC abs, max
165
166
167
168
169
170 info = 0
171 IF( .NOT.
lsame( uplo,
'U' ) .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
172 info = -1
173 ELSE IF( .NOT.
lsame( trans,
'N' ) .AND. .NOT.
lsame( trans,
'T' ) )
174 $ THEN
175 info = -2
176 ELSE IF( .NOT.
lsame( diag,
'U' ) .AND. .NOT.
lsame( diag,
'N' ) )
177 $ THEN
178 info = -3
179 ELSE IF( n.LT.0 ) THEN
180 info = -4
181 ELSE IF( ldb.LT.max( 1, n ) ) THEN
182 info = -8
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla(
'ZLAVSP ', -info )
186 RETURN
187 END IF
188
189
190
191 IF( n.EQ.0 )
192 $ RETURN
193
194 nounit =
lsame( diag,
'N' )
195
196
197
198
199
200 IF(
lsame( trans,
'N' ) )
THEN
201
202
203
204
205 IF(
lsame( uplo,
'U' ) )
THEN
206
207
208
209 k = 1
210 kc = 1
211 10 CONTINUE
212 IF( k.GT.n )
213 $ GO TO 30
214
215
216
217 IF( ipiv( k ).GT.0 ) THEN
218
219
220
221 IF( nounit )
222 $
CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
223
224
225
226 IF( k.GT.1 ) THEN
227
228
229
230 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
231 $ ldb, b( 1, 1 ), ldb )
232
233
234
235 kp = ipiv( k )
236 IF( kp.NE.k )
237 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
238 END IF
239 kc = kc + k
240 k = k + 1
241 ELSE
242
243
244
245 kcnext = kc + k
246
247
248
249 IF( nounit ) THEN
250 d11 = a( kcnext-1 )
251 d22 = a( kcnext+k )
252 d12 = a( kcnext+k-1 )
253 d21 = d12
254 DO 20 j = 1, nrhs
255 t1 = b( k, j )
256 t2 = b( k+1, j )
257 b( k, j ) = d11*t1 + d12*t2
258 b( k+1, j ) = d21*t1 + d22*t2
259 20 CONTINUE
260 END IF
261
262
263
264 IF( k.GT.1 ) THEN
265
266
267
268 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL zgeru( k-1, nrhs, one, a( kcnext ), 1,
271 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
272
273
274
275 kp = abs( ipiv( k ) )
276 IF( kp.NE.k )
277 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
278 END IF
279 kc = kcnext + k + 1
280 k = k + 2
281 END IF
282 GO TO 10
283 30 CONTINUE
284
285
286
287
288 ELSE
289
290
291
292 k = n
293 kc = n*( n+1 ) / 2 + 1
294 40 CONTINUE
295 IF( k.LT.1 )
296 $ GO TO 60
297 kc = kc - ( n-k+1 )
298
299
300
301
302 IF( ipiv( k ).GT.0 ) THEN
303
304
305
306
307
308 IF( nounit )
309 $
CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
310
311
312
313 IF( k.NE.n ) THEN
314 kp = ipiv( k )
315
316
317
318 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
319 $ ldb, b( k+1, 1 ), ldb )
320
321
322
323
324 IF( kp.NE.k )
325 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
326 END IF
327 k = k - 1
328
329 ELSE
330
331
332
333 kcnext = kc - ( n-k+2 )
334
335
336
337 IF( nounit ) THEN
338 d11 = a( kcnext )
339 d22 = a( kc )
340 d21 = a( kcnext+1 )
341 d12 = d21
342 DO 50 j = 1, nrhs
343 t1 = b( k-1, j )
344 t2 = b( k, j )
345 b( k-1, j ) = d11*t1 + d12*t2
346 b( k, j ) = d21*t1 + d22*t2
347 50 CONTINUE
348 END IF
349
350
351
352 IF( k.NE.n ) THEN
353
354
355
356 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL zgeru( n-k, nrhs, one, a( kcnext+2 ), 1,
359 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
360
361
362
363
364 kp = abs( ipiv( k ) )
365 IF( kp.NE.k )
366 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
367 END IF
368 kc = kcnext
369 k = k - 2
370 END IF
371 GO TO 40
372 60 CONTINUE
373 END IF
374
375
376
377
378
379 ELSE
380
381
382
383
384
385 IF(
lsame( uplo,
'U' ) )
THEN
386
387
388
389 k = n
390 kc = n*( n+1 ) / 2 + 1
391 70 CONTINUE
392 IF( k.LT.1 )
393 $ GO TO 90
394 kc = kc - k
395
396
397
398 IF( ipiv( k ).GT.0 ) THEN
399 IF( k.GT.1 ) THEN
400
401
402
403 kp = ipiv( k )
404 IF( kp.NE.k )
405 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
406
407
408
409
410
411 CALL zgemv(
'Transpose', k-1, nrhs, one, b, ldb,
412 $ a( kc ), 1, one, b( k, 1 ), ldb )
413 END IF
414 IF( nounit )
415 $
CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
416 k = k - 1
417
418
419
420 ELSE
421 kcnext = kc - ( k-1 )
422 IF( k.GT.2 ) THEN
423
424
425
426 kp = abs( ipiv( k ) )
427 IF( kp.NE.k-1 )
428 $
CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
429 $ ldb )
430
431
432
433 CALL zgemv(
'Transpose', k-2, nrhs, one, b, ldb,
434 $ a( kc ), 1, one, b( k, 1 ), ldb )
435
436 CALL zgemv(
'Transpose', k-2, nrhs, one, b, ldb,
437 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
438 END IF
439
440
441
442 IF( nounit ) THEN
443 d11 = a( kc-1 )
444 d22 = a( kc+k-1 )
445 d12 = a( kc+k-2 )
446 d21 = d12
447 DO 80 j = 1, nrhs
448 t1 = b( k-1, j )
449 t2 = b( k, j )
450 b( k-1, j ) = d11*t1 + d12*t2
451 b( k, j ) = d21*t1 + d22*t2
452 80 CONTINUE
453 END IF
454 kc = kcnext
455 k = k - 2
456 END IF
457 GO TO 70
458 90 CONTINUE
459
460
461
462
463
464 ELSE
465
466
467
468 k = 1
469 kc = 1
470 100 CONTINUE
471 IF( k.GT.n )
472 $ GO TO 120
473
474
475
476 IF( ipiv( k ).GT.0 ) THEN
477 IF( k.LT.n ) THEN
478
479
480
481 kp = ipiv( k )
482 IF( kp.NE.k )
483 $
CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
484
485
486
487 CALL zgemv(
'Transpose', n-k, nrhs, one, b( k+1, 1 ),
488 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
489 END IF
490 IF( nounit )
491 $
CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
492 kc = kc + n - k + 1
493 k = k + 1
494
495
496
497 ELSE
498 kcnext = kc + n - k + 1
499 IF( k.LT.n-1 ) THEN
500
501
502
503 kp = abs( ipiv( k ) )
504 IF( kp.NE.k+1 )
505 $
CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
506 $ ldb )
507
508
509
510 CALL zgemv(
'Transpose', n-k-1, nrhs, one,
511 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
512 $ b( k+1, 1 ), ldb )
513
514 CALL zgemv(
'Transpose', n-k-1, nrhs, one,
515 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
516 $ b( k, 1 ), ldb )
517 END IF
518
519
520
521 IF( nounit ) THEN
522 d11 = a( kc )
523 d22 = a( kcnext )
524 d21 = a( kc+1 )
525 d12 = d21
526 DO 110 j = 1, nrhs
527 t1 = b( k, j )
528 t2 = b( k+1, j )
529 b( k, j ) = d11*t1 + d12*t2
530 b( k+1, j ) = d21*t1 + d22*t2
531 110 CONTINUE
532 END IF
533 kc = kcnext + ( n-k )
534 k = k + 2
535 END IF
536 GO TO 100
537 120 CONTINUE
538 END IF
539
540 END IF
541 RETURN
542
543
544
subroutine xerbla(srname, info)
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
subroutine zgeru(m, n, alpha, x, incx, y, incy, a, lda)
ZGERU
logical function lsame(ca, cb)
LSAME
subroutine zscal(n, za, zx, incx)
ZSCAL
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP