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