231
232
233
234
235
236
237 CHARACTER DIAG, NORMIN, TRANS, UPLO
238 INTEGER INFO, N
239 DOUBLE PRECISION SCALE
240
241
242 DOUBLE PRECISION CNORM( * )
243 COMPLEX*16 AP( * ), X( * )
244
245
246
247
248
249 DOUBLE PRECISION ZERO, HALF, ONE, TWO
250 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0,
251 $ two = 2.0d+0 )
252
253
254 LOGICAL NOTRAN, NOUNIT, UPPER
255 INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
256 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
257 $ XBND, XJ, XMAX
258 COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM
259
260
261 LOGICAL LSAME
262 INTEGER IDAMAX, IZAMAX
263 DOUBLE PRECISION DLAMCH, DZASUM
264 COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
267
268
270
271
272 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min
273
274
275 DOUBLE PRECISION CABS1, CABS2
276
277
278 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
279 cabs2( zdum ) = abs( dble( zdum ) / 2.d0 ) +
280 $ abs( dimag( zdum ) / 2.d0 )
281
282
283
284 info = 0
285 upper =
lsame( uplo,
'U' )
286 notran =
lsame( trans,
'N' )
287 nounit =
lsame( diag,
'N' )
288
289
290
291 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
292 info = -1
293 ELSE IF( .NOT.notran .AND. .NOT.
lsame( trans,
'T' ) .AND. .NOT.
294 $
lsame( trans,
'C' ) )
THEN
295 info = -2
296 ELSE IF( .NOT.nounit .AND. .NOT.
lsame( diag,
'U' ) )
THEN
297 info = -3
298 ELSE IF( .NOT.
lsame( normin,
'Y' ) .AND. .NOT.
299 $
lsame( normin,
'N' ) )
THEN
300 info = -4
301 ELSE IF( n.LT.0 ) THEN
302 info = -5
303 END IF
304 IF( info.NE.0 ) THEN
305 CALL xerbla(
'ZLATPS', -info )
306 RETURN
307 END IF
308
309
310
311 IF( n.EQ.0 )
312 $ RETURN
313
314
315
316 smlnum =
dlamch(
'Safe minimum' )
317 bignum = one / smlnum
318 smlnum = smlnum /
dlamch(
'Precision' )
319 bignum = one / smlnum
320 scale = one
321
322 IF(
lsame( normin,
'N' ) )
THEN
323
324
325
326 IF( upper ) THEN
327
328
329
330 ip = 1
331 DO 10 j = 1, n
332 cnorm( j ) =
dzasum( j-1, ap( ip ), 1 )
333 ip = ip + j
334 10 CONTINUE
335 ELSE
336
337
338
339 ip = 1
340 DO 20 j = 1, n - 1
341 cnorm( j ) =
dzasum( n-j, ap( ip+1 ), 1 )
342 ip = ip + n - j + 1
343 20 CONTINUE
344 cnorm( n ) = zero
345 END IF
346 END IF
347
348
349
350
351 imax =
idamax( n, cnorm, 1 )
352 tmax = cnorm( imax )
353 IF( tmax.LE.bignum*half ) THEN
354 tscal = one
355 ELSE
356 tscal = half / ( smlnum*tmax )
357 CALL dscal( n, tscal, cnorm, 1 )
358 END IF
359
360
361
362
363 xmax = zero
364 DO 30 j = 1, n
365 xmax = max( xmax, cabs2( x( j ) ) )
366 30 CONTINUE
367 xbnd = xmax
368 IF( notran ) THEN
369
370
371
372 IF( upper ) THEN
373 jfirst = n
374 jlast = 1
375 jinc = -1
376 ELSE
377 jfirst = 1
378 jlast = n
379 jinc = 1
380 END IF
381
382 IF( tscal.NE.one ) THEN
383 grow = zero
384 GO TO 60
385 END IF
386
387 IF( nounit ) THEN
388
389
390
391
392
393
394 grow = half / max( xbnd, smlnum )
395 xbnd = grow
396 ip = jfirst*( jfirst+1 ) / 2
397 jlen = n
398 DO 40 j = jfirst, jlast, jinc
399
400
401
402 IF( grow.LE.smlnum )
403 $ GO TO 60
404
405 tjjs = ap( ip )
406 tjj = cabs1( tjjs )
407
408 IF( tjj.GE.smlnum ) THEN
409
410
411
412 xbnd = min( xbnd, min( one, tjj )*grow )
413 ELSE
414
415
416
417 xbnd = zero
418 END IF
419
420 IF( tjj+cnorm( j ).GE.smlnum ) THEN
421
422
423
424 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
425 ELSE
426
427
428
429 grow = zero
430 END IF
431 ip = ip + jinc*jlen
432 jlen = jlen - 1
433 40 CONTINUE
434 grow = xbnd
435 ELSE
436
437
438
439
440
441 grow = min( one, half / max( xbnd, smlnum ) )
442 DO 50 j = jfirst, jlast, jinc
443
444
445
446 IF( grow.LE.smlnum )
447 $ GO TO 60
448
449
450
451 grow = grow*( one / ( one+cnorm( j ) ) )
452 50 CONTINUE
453 END IF
454 60 CONTINUE
455
456 ELSE
457
458
459
460 IF( upper ) THEN
461 jfirst = 1
462 jlast = n
463 jinc = 1
464 ELSE
465 jfirst = n
466 jlast = 1
467 jinc = -1
468 END IF
469
470 IF( tscal.NE.one ) THEN
471 grow = zero
472 GO TO 90
473 END IF
474
475 IF( nounit ) THEN
476
477
478
479
480
481
482 grow = half / max( xbnd, smlnum )
483 xbnd = grow
484 ip = jfirst*( jfirst+1 ) / 2
485 jlen = 1
486 DO 70 j = jfirst, jlast, jinc
487
488
489
490 IF( grow.LE.smlnum )
491 $ GO TO 90
492
493
494
495 xj = one + cnorm( j )
496 grow = min( grow, xbnd / xj )
497
498 tjjs = ap( ip )
499 tjj = cabs1( tjjs )
500
501 IF( tjj.GE.smlnum ) THEN
502
503
504
505 IF( xj.GT.tjj )
506 $ xbnd = xbnd*( tjj / xj )
507 ELSE
508
509
510
511 xbnd = zero
512 END IF
513 jlen = jlen + 1
514 ip = ip + jinc*jlen
515 70 CONTINUE
516 grow = min( grow, xbnd )
517 ELSE
518
519
520
521
522
523 grow = min( one, half / max( xbnd, smlnum ) )
524 DO 80 j = jfirst, jlast, jinc
525
526
527
528 IF( grow.LE.smlnum )
529 $ GO TO 90
530
531
532
533 xj = one + cnorm( j )
534 grow = grow / xj
535 80 CONTINUE
536 END IF
537 90 CONTINUE
538 END IF
539
540 IF( ( grow*tscal ).GT.smlnum ) THEN
541
542
543
544
545 CALL ztpsv( uplo, trans, diag, n, ap, x, 1 )
546 ELSE
547
548
549
550 IF( xmax.GT.bignum*half ) THEN
551
552
553
554
555 scale = ( bignum*half ) / xmax
556 CALL zdscal( n, scale, x, 1 )
557 xmax = bignum
558 ELSE
559 xmax = xmax*two
560 END IF
561
562 IF( notran ) THEN
563
564
565
566 ip = jfirst*( jfirst+1 ) / 2
567 DO 120 j = jfirst, jlast, jinc
568
569
570
571 xj = cabs1( x( j ) )
572 IF( nounit ) THEN
573 tjjs = ap( ip )*tscal
574 ELSE
575 tjjs = tscal
576 IF( tscal.EQ.one )
577 $ GO TO 110
578 END IF
579 tjj = cabs1( tjjs )
580 IF( tjj.GT.smlnum ) THEN
581
582
583
584 IF( tjj.LT.one ) THEN
585 IF( xj.GT.tjj*bignum ) THEN
586
587
588
589 rec = one / xj
590 CALL zdscal( n, rec, x, 1 )
591 scale = scale*rec
592 xmax = xmax*rec
593 END IF
594 END IF
595 x( j ) =
zladiv( x( j ), tjjs )
596 xj = cabs1( x( j ) )
597 ELSE IF( tjj.GT.zero ) THEN
598
599
600
601 IF( xj.GT.tjj*bignum ) THEN
602
603
604
605
606 rec = ( tjj*bignum ) / xj
607 IF( cnorm( j ).GT.one ) THEN
608
609
610
611
612 rec = rec / cnorm( j )
613 END IF
614 CALL zdscal( n, rec, x, 1 )
615 scale = scale*rec
616 xmax = xmax*rec
617 END IF
618 x( j ) =
zladiv( x( j ), tjjs )
619 xj = cabs1( x( j ) )
620 ELSE
621
622
623
624
625 DO 100 i = 1, n
626 x( i ) = zero
627 100 CONTINUE
628 x( j ) = one
629 xj = one
630 scale = zero
631 xmax = zero
632 END IF
633 110 CONTINUE
634
635
636
637
638 IF( xj.GT.one ) THEN
639 rec = one / xj
640 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
641
642
643
644 rec = rec*half
645 CALL zdscal( n, rec, x, 1 )
646 scale = scale*rec
647 END IF
648 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
649
650
651
652 CALL zdscal( n, half, x, 1 )
653 scale = scale*half
654 END IF
655
656 IF( upper ) THEN
657 IF( j.GT.1 ) THEN
658
659
660
661
662 CALL zaxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,
663 $ 1 )
665 xmax = cabs1( x( i ) )
666 END IF
667 ip = ip - j
668 ELSE
669 IF( j.LT.n ) THEN
670
671
672
673
674 CALL zaxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1,
675 $ x( j+1 ), 1 )
676 i = j +
izamax( n-j, x( j+1 ), 1 )
677 xmax = cabs1( x( i ) )
678 END IF
679 ip = ip + n - j + 1
680 END IF
681 120 CONTINUE
682
683 ELSE IF(
lsame( trans,
'T' ) )
THEN
684
685
686
687 ip = jfirst*( jfirst+1 ) / 2
688 jlen = 1
689 DO 170 j = jfirst, jlast, jinc
690
691
692
693
694 xj = cabs1( x( j ) )
695 uscal = tscal
696 rec = one / max( xmax, one )
697 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
698
699
700
701 rec = rec*half
702 IF( nounit ) THEN
703 tjjs = ap( ip )*tscal
704 ELSE
705 tjjs = tscal
706 END IF
707 tjj = cabs1( tjjs )
708 IF( tjj.GT.one ) THEN
709
710
711
712 rec = min( one, rec*tjj )
713 uscal =
zladiv( uscal, tjjs )
714 END IF
715 IF( rec.LT.one ) THEN
716 CALL zdscal( n, rec, x, 1 )
717 scale = scale*rec
718 xmax = xmax*rec
719 END IF
720 END IF
721
722 csumj = zero
723 IF( uscal.EQ.dcmplx( one ) ) THEN
724
725
726
727
728 IF( upper ) THEN
729 csumj =
zdotu( j-1, ap( ip-j+1 ), 1, x, 1 )
730 ELSE IF( j.LT.n ) THEN
731 csumj =
zdotu( n-j, ap( ip+1 ), 1, x( j+1 ), 1 )
732 END IF
733 ELSE
734
735
736
737 IF( upper ) THEN
738 DO 130 i = 1, j - 1
739 csumj = csumj + ( ap( ip-j+i )*uscal )*x( i )
740 130 CONTINUE
741 ELSE IF( j.LT.n ) THEN
742 DO 140 i = 1, n - j
743 csumj = csumj + ( ap( ip+i )*uscal )*x( j+i )
744 140 CONTINUE
745 END IF
746 END IF
747
748 IF( uscal.EQ.dcmplx( tscal ) ) THEN
749
750
751
752
753 x( j ) = x( j ) - csumj
754 xj = cabs1( x( j ) )
755 IF( nounit ) THEN
756
757
758
759 tjjs = ap( ip )*tscal
760 ELSE
761 tjjs = tscal
762 IF( tscal.EQ.one )
763 $ GO TO 160
764 END IF
765 tjj = cabs1( tjjs )
766 IF( tjj.GT.smlnum ) THEN
767
768
769
770 IF( tjj.LT.one ) THEN
771 IF( xj.GT.tjj*bignum ) THEN
772
773
774
775 rec = one / xj
776 CALL zdscal( n, rec, x, 1 )
777 scale = scale*rec
778 xmax = xmax*rec
779 END IF
780 END IF
781 x( j ) =
zladiv( x( j ), tjjs )
782 ELSE IF( tjj.GT.zero ) THEN
783
784
785
786 IF( xj.GT.tjj*bignum ) THEN
787
788
789
790 rec = ( tjj*bignum ) / xj
791 CALL zdscal( n, rec, x, 1 )
792 scale = scale*rec
793 xmax = xmax*rec
794 END IF
795 x( j ) =
zladiv( x( j ), tjjs )
796 ELSE
797
798
799
800
801 DO 150 i = 1, n
802 x( i ) = zero
803 150 CONTINUE
804 x( j ) = one
805 scale = zero
806 xmax = zero
807 END IF
808 160 CONTINUE
809 ELSE
810
811
812
813
814 x( j ) =
zladiv( x( j ), tjjs ) - csumj
815 END IF
816 xmax = max( xmax, cabs1( x( j ) ) )
817 jlen = jlen + 1
818 ip = ip + jinc*jlen
819 170 CONTINUE
820
821 ELSE
822
823
824
825 ip = jfirst*( jfirst+1 ) / 2
826 jlen = 1
827 DO 220 j = jfirst, jlast, jinc
828
829
830
831
832 xj = cabs1( x( j ) )
833 uscal = tscal
834 rec = one / max( xmax, one )
835 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
836
837
838
839 rec = rec*half
840 IF( nounit ) THEN
841 tjjs = dconjg( ap( ip ) )*tscal
842 ELSE
843 tjjs = tscal
844 END IF
845 tjj = cabs1( tjjs )
846 IF( tjj.GT.one ) THEN
847
848
849
850 rec = min( one, rec*tjj )
851 uscal =
zladiv( uscal, tjjs )
852 END IF
853 IF( rec.LT.one ) THEN
854 CALL zdscal( n, rec, x, 1 )
855 scale = scale*rec
856 xmax = xmax*rec
857 END IF
858 END IF
859
860 csumj = zero
861 IF( uscal.EQ.dcmplx( one ) ) THEN
862
863
864
865
866 IF( upper ) THEN
867 csumj =
zdotc( j-1, ap( ip-j+1 ), 1, x, 1 )
868 ELSE IF( j.LT.n ) THEN
869 csumj =
zdotc( n-j, ap( ip+1 ), 1, x( j+1 ), 1 )
870 END IF
871 ELSE
872
873
874
875 IF( upper ) THEN
876 DO 180 i = 1, j - 1
877 csumj = csumj + ( dconjg( ap( ip-j+i ) )*uscal )
878 $ *x( i )
879 180 CONTINUE
880 ELSE IF( j.LT.n ) THEN
881 DO 190 i = 1, n - j
882 csumj = csumj + ( dconjg( ap( ip+i ) )*uscal )*
883 $ x( j+i )
884 190 CONTINUE
885 END IF
886 END IF
887
888 IF( uscal.EQ.dcmplx( tscal ) ) THEN
889
890
891
892
893 x( j ) = x( j ) - csumj
894 xj = cabs1( x( j ) )
895 IF( nounit ) THEN
896
897
898
899 tjjs = dconjg( ap( ip ) )*tscal
900 ELSE
901 tjjs = tscal
902 IF( tscal.EQ.one )
903 $ GO TO 210
904 END IF
905 tjj = cabs1( tjjs )
906 IF( tjj.GT.smlnum ) THEN
907
908
909
910 IF( tjj.LT.one ) THEN
911 IF( xj.GT.tjj*bignum ) THEN
912
913
914
915 rec = one / xj
916 CALL zdscal( n, rec, x, 1 )
917 scale = scale*rec
918 xmax = xmax*rec
919 END IF
920 END IF
921 x( j ) =
zladiv( x( j ), tjjs )
922 ELSE IF( tjj.GT.zero ) THEN
923
924
925
926 IF( xj.GT.tjj*bignum ) THEN
927
928
929
930 rec = ( tjj*bignum ) / xj
931 CALL zdscal( n, rec, x, 1 )
932 scale = scale*rec
933 xmax = xmax*rec
934 END IF
935 x( j ) =
zladiv( x( j ), tjjs )
936 ELSE
937
938
939
940
941 DO 200 i = 1, n
942 x( i ) = zero
943 200 CONTINUE
944 x( j ) = one
945 scale = zero
946 xmax = zero
947 END IF
948 210 CONTINUE
949 ELSE
950
951
952
953
954 x( j ) =
zladiv( x( j ), tjjs ) - csumj
955 END IF
956 xmax = max( xmax, cabs1( x( j ) ) )
957 jlen = jlen + 1
958 ip = ip + jinc*jlen
959 220 CONTINUE
960 END IF
961 scale = scale / tscal
962 END IF
963
964
965
966 IF( tscal.NE.one ) THEN
967 CALL dscal( n, one / tscal, cnorm, 1 )
968 END IF
969
970 RETURN
971
972
973
subroutine xerbla(srname, info)
double precision function dzasum(n, zx, incx)
DZASUM
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
complex *16 function zdotu(n, zx, incx, zy, incy)
ZDOTU
integer function idamax(n, dx, incx)
IDAMAX
integer function izamax(n, zx, incx)
IZAMAX
complex *16 function zladiv(x, y)
ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
double precision function dlamch(cmach)
DLAMCH
logical function lsame(ca, cb)
LSAME
subroutine dscal(n, da, dx, incx)
DSCAL
subroutine zdscal(n, da, zx, incx)
ZDSCAL
subroutine ztpsv(uplo, trans, diag, n, ap, x, incx)
ZTPSV