131
132
133
134
135
136
137 CHARACTER DIAG, TRANS, UPLO
138 INTEGER INFO, LDB, N, NRHS
139
140
141 INTEGER IPIV( * )
142 COMPLEX A( * ), B( LDB, * )
143
144
145
146
147
148 COMPLEX ONE
149 parameter( one = ( 1.0e+0, 0.0e+0 ) )
150
151
152 LOGICAL NOUNIT
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX 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(
'CLAVSP ', -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 cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
223
224
225
226 IF( k.GT.1 ) THEN
227
228
229
230 CALL cgeru( 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 cswap( 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 cgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL cgeru( 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 cswap( 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 cscal( 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 cgeru( 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 cswap( 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 cgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL cgeru( 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 cswap( 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 IF( k.LT.1 )
392 $ GO TO 90
393 kc = kc - k
394
395
396
397 IF( ipiv( k ).GT.0 ) THEN
398 IF( k.GT.1 ) THEN
399
400
401
402 kp = ipiv( k )
403 IF( kp.NE.k )
404 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
405
406
407
408
409
410 CALL cgemv(
'Transpose', k-1, nrhs, one, b, ldb,
411 $ a( kc ), 1, one, b( k, 1 ), ldb )
412 END IF
413 IF( nounit )
414 $
CALL cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
415 k = k - 1
416
417
418
419 ELSE
420 kcnext = kc - ( k-1 )
421 IF( k.GT.2 ) THEN
422
423
424
425 kp = abs( ipiv( k ) )
426 IF( kp.NE.k-1 )
427 $
CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
428 $ ldb )
429
430
431
432 CALL cgemv(
'Transpose', k-2, nrhs, one, b, ldb,
433 $ a( kc ), 1, one, b( k, 1 ), ldb )
434
435 CALL cgemv(
'Transpose', k-2, nrhs, one, b, ldb,
436 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
437 END IF
438
439
440
441 IF( nounit ) THEN
442 d11 = a( kc-1 )
443 d22 = a( kc+k-1 )
444 d12 = a( kc+k-2 )
445 d21 = d12
446 DO 80 j = 1, nrhs
447 t1 = b( k-1, j )
448 t2 = b( k, j )
449 b( k-1, j ) = d11*t1 + d12*t2
450 b( k, j ) = d21*t1 + d22*t2
451 80 CONTINUE
452 END IF
453 kc = kcnext
454 k = k - 2
455 END IF
456 GO TO 70
457 90 CONTINUE
458
459
460
461
462
463 ELSE
464
465
466
467 k = 1
468 kc = 1
469 100 CONTINUE
470 IF( k.GT.n )
471 $ GO TO 120
472
473
474
475 IF( ipiv( k ).GT.0 ) THEN
476 IF( k.LT.n ) THEN
477
478
479
480 kp = ipiv( k )
481 IF( kp.NE.k )
482 $
CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
483
484
485
486 CALL cgemv(
'Transpose', n-k, nrhs, one, b( k+1, 1 ),
487 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
488 END IF
489 IF( nounit )
490 $
CALL cscal( nrhs, a( kc ), b( k, 1 ), ldb )
491 kc = kc + n - k + 1
492 k = k + 1
493
494
495
496 ELSE
497 kcnext = kc + n - k + 1
498 IF( k.LT.n-1 ) THEN
499
500
501
502 kp = abs( ipiv( k ) )
503 IF( kp.NE.k+1 )
504 $
CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
505 $ ldb )
506
507
508
509 CALL cgemv(
'Transpose', n-k-1, nrhs, one,
510 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
511 $ b( k+1, 1 ), ldb )
512
513 CALL cgemv(
'Transpose', n-k-1, nrhs, one,
514 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
515 $ b( k, 1 ), ldb )
516 END IF
517
518
519
520 IF( nounit ) THEN
521 d11 = a( kc )
522 d22 = a( kcnext )
523 d21 = a( kc+1 )
524 d12 = d21
525 DO 110 j = 1, nrhs
526 t1 = b( k, j )
527 t2 = b( k+1, j )
528 b( k, j ) = d11*t1 + d12*t2
529 b( k+1, j ) = d21*t1 + d22*t2
530 110 CONTINUE
531 END IF
532 kc = kcnext + ( n-k )
533 k = k + 2
534 END IF
535 GO TO 100
536 120 CONTINUE
537 END IF
538
539 END IF
540 RETURN
541
542
543
subroutine xerbla(srname, info)
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
subroutine cgeru(m, n, alpha, x, incx, y, incy, a, lda)
CGERU
logical function lsame(ca, cb)
LSAME
subroutine cscal(n, ca, cx, incx)
CSCAL
subroutine cswap(n, cx, incx, cy, incy)
CSWAP