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