247 DOUBLE PRECISION FUNCTION zlanhf( NORM, TRANSR, UPLO, N, A, WORK )
255 CHARACTER norm, transr, uplo
259 DOUBLE PRECISION work( 0: * )
266 DOUBLE PRECISION one, zero
267 parameter( one = 1.0d+0, zero = 0.0d+0 )
270 INTEGER i,
j, ifm, ilu, noe, n1, k, l, lda
271 DOUBLE PRECISION scale, s,
value, aa, temp
281 INTRINSIC abs, dble, sqrt
288 ELSE IF( n.EQ.1 )
THEN
296 IF( mod( n, 2 ).EQ.0 )
302 IF(
lsame( transr,
'C' ) )
308 IF(
lsame( uplo,
'U' ) )
327 IF(
lsame( norm,
'M' ) )
THEN
341 temp = abs( dble( a(
j+
j*lda ) ) )
345 temp = abs( a( i+
j*lda ) )
351 temp = abs( a( i+
j*lda ) )
357 temp = abs( dble( a( i+
j*lda ) ) )
362 temp = abs( dble( a( i+
j*lda ) ) )
366 temp = abs( a( i+
j*lda ) )
375 temp = abs( a( i+
j*lda ) )
381 temp = abs( dble( a( i+
j*lda ) ) )
386 temp = abs( dble( a( i+
j*lda ) ) )
389 DO i = k +
j + 1, n - 1
390 temp = abs( a( i+
j*lda ) )
396 temp = abs( a( i+
j*lda ) )
402 temp = abs( dble( a( i+
j*lda ) ) )
412 temp = abs( a( i+
j*lda ) )
418 temp = abs( dble( a( i+
j*lda ) ) )
423 temp = abs( dble( a( i+
j*lda ) ) )
427 temp = abs( a( i+
j*lda ) )
434 temp = abs( a( i+
j*lda ) )
440 temp = abs( dble( a( i+
j*lda ) ) )
445 temp = abs( a( i+
j*lda ) )
454 temp = abs( a( i+
j*lda ) )
461 temp = abs( dble( a( 0+
j*lda ) ) )
465 temp = abs( a( i+
j*lda ) )
471 temp = abs( a( i+
j*lda ) )
477 temp = abs( dble( a( i+
j*lda ) ) )
482 temp = abs( dble( a( i+
j*lda ) ) )
485 DO i =
j - k + 2, k - 1
486 temp = abs( a( i+
j*lda ) )
501 temp = abs( dble( a(
j+
j*lda ) ) )
504 temp = abs( dble( a(
j+1+
j*lda ) ) )
508 temp = abs( a( i+
j*lda ) )
514 temp = abs( a( i+
j*lda ) )
520 temp = abs( dble( a( i+
j*lda ) ) )
525 temp = abs( dble( a( i+
j*lda ) ) )
529 temp = abs( a( i+
j*lda ) )
538 temp = abs( a( i+
j*lda ) )
544 temp = abs( dble( a( i+
j*lda ) ) )
549 temp = abs( dble( a( i+
j*lda ) ) )
553 temp = abs( a( i+
j*lda ) )
559 temp = abs( a( i+
j*lda ) )
565 temp = abs( dble( a( i+
j*lda ) ) )
570 temp = abs( dble( a( i+
j*lda ) ) )
580 temp = abs( dble( a(
j+
j*lda ) ) )
584 temp = abs( a( i+
j*lda ) )
590 temp = abs( a( i+
j*lda ) )
596 temp = abs( dble( a( i+
j*lda ) ) )
601 temp = abs( dble( a( i+
j*lda ) ) )
605 temp = abs( a( i+
j*lda ) )
612 temp = abs( a( i+
j*lda ) )
618 temp = abs( dble( a( i+
j*lda ) ) )
623 temp = abs( a( i+
j*lda ) )
632 temp = abs( a( i+
j*lda ) )
639 temp = abs( dble( a( 0+
j*lda ) ) )
643 temp = abs( a( i+
j*lda ) )
649 temp = abs( a( i+
j*lda ) )
655 temp = abs( dble( a( i+
j*lda ) ) )
660 temp = abs( dble( a( i+
j*lda ) ) )
663 DO i =
j - k + 1, k - 1
664 temp = abs( a( i+
j*lda ) )
671 temp = abs( a( i+
j*lda ) )
677 temp = abs( dble( a( i+
j*lda ) ) )
683 ELSE IF( (
lsame( norm,
'I' ) ) .OR. (
lsame( norm,
'O' ) ) .OR.
684 $ ( norm.EQ.
'1' ) )
THEN
701 aa = abs( a( i+
j*lda ) )
704 work( i ) = work( i ) + aa
706 aa = abs( dble( a( i+
j*lda ) ) )
712 aa = abs( dble( a( i+
j*lda ) ) )
714 work(
j ) = work(
j ) + aa
718 aa = abs( a( i+
j*lda ) )
721 work( l ) = work( l ) + aa
723 work(
j ) = work(
j ) + s
742 aa = abs( a( i+
j*lda ) )
745 work( i+k ) = work( i+k ) + aa
748 aa = abs( dble( a( i+
j*lda ) ) )
751 work( i+k ) = work( i+k ) + s
755 aa = abs( dble( a( i+
j*lda ) ) )
761 aa = abs( a( i+
j*lda ) )
764 work( l ) = work( l ) + aa
766 work(
j ) = work(
j ) + s
785 aa = abs( a( i+
j*lda ) )
788 work( i ) = work( i ) + aa
790 aa = abs( dble( a( i+
j*lda ) ) )
794 aa = abs( dble( a( i+
j*lda ) ) )
796 work(
j ) = work(
j ) + aa
800 aa = abs( a( i+
j*lda ) )
803 work( l ) = work( l ) + aa
805 work(
j ) = work(
j ) + s
821 aa = abs( a( i+
j*lda ) )
824 work( i+k ) = work( i+k ) + aa
826 aa = abs( dble( a( i+
j*lda ) ) )
829 work( i+k ) = work( i+k ) + s
832 aa = abs( dble( a( i+
j*lda ) ) )
838 aa = abs( a( i+
j*lda ) )
841 work( l ) = work( l ) + aa
843 work(
j ) = work(
j ) + s
870 aa = abs( a( i+
j*lda ) )
872 work( i+n1 ) = work( i+n1 ) + aa
878 s = abs( dble( a( 0+
j*lda ) ) )
881 aa = abs( a( i+
j*lda ) )
883 work( i+n1 ) = work( i+n1 ) + aa
886 work(
j ) = work(
j ) + s
890 aa = abs( a( i+
j*lda ) )
892 work( i ) = work( i ) + aa
896 aa = abs( dble( a( i+
j*lda ) ) )
899 work(
j-k ) = work(
j-k ) + s
901 s = abs( dble( a( i+
j*lda ) ) )
905 aa = abs( a( i+
j*lda ) )
907 work( l ) = work( l ) + aa
910 work(
j ) = work(
j ) + s
929 aa = abs( a( i+
j*lda ) )
931 work( i ) = work( i ) + aa
934 aa = abs( dble( a( i+
j*lda ) ) )
941 aa = abs( dble( a( i+
j*lda ) ) )
943 DO l = k +
j + 1, n - 1
945 aa = abs( a( i+
j*lda ) )
948 work( l ) = work( l ) + aa
950 work( k+
j ) = work( k+
j ) + s
955 aa = abs( a( i+
j*lda ) )
957 work( i ) = work( i ) + aa
961 aa = abs( dble( a( i+
j*lda ) ) )
970 aa = abs( a( i+
j*lda ) )
972 work( i ) = work( i ) + aa
975 work(
j ) = work(
j ) + s
994 aa = abs( a( i+
j*lda ) )
996 work( i+k ) = work( i+k ) + aa
1002 aa = abs( dble( a( 0+
j*lda ) ) )
1006 aa = abs( a( i+
j*lda ) )
1008 work( i+k ) = work( i+k ) + aa
1011 work(
j ) = work(
j ) + s
1015 aa = abs( a( i+
j*lda ) )
1017 work( i ) = work( i ) + aa
1021 aa = abs( dble( a( i+
j*lda ) ) )
1024 work(
j-k-1 ) = work(
j-k-1 ) + s
1026 aa = abs( dble( a( i+
j*lda ) ) )
1031 aa = abs( a( i+
j*lda ) )
1033 work( l ) = work( l ) + aa
1036 work(
j ) = work(
j ) + s
1041 aa = abs( a( i+
j*lda ) )
1043 work( i ) = work( i ) + aa
1047 aa = abs( dble( a( i+
j*lda ) ) )
1050 work( i ) = work( i ) + s
1063 s = abs( dble( a( 0 ) ) )
1068 work( i+k ) = work( i+k ) + aa
1071 work( k ) = work( k ) + s
1076 aa = abs( a( i+
j*lda ) )
1078 work( i ) = work( i ) + aa
1081 aa = abs( dble( a( i+
j*lda ) ) )
1088 aa = abs( dble( a( i+
j*lda ) ) )
1090 DO l = k +
j + 1, n - 1
1092 aa = abs( a( i+
j*lda ) )
1095 work( l ) = work( l ) + aa
1097 work( k+
j ) = work( k+
j ) + s
1102 aa = abs( a( i+
j*lda ) )
1104 work( i ) = work( i ) + aa
1109 aa = abs( dble( a( i+
j*lda ) ) )
1119 aa = abs( a( i+
j*lda ) )
1121 work( i ) = work( i ) + aa
1124 work(
j-1 ) = work(
j-1 ) + s
1135 ELSE IF( (
lsame( norm,
'F' ) ) .OR. (
lsame( norm,
'E' ) ) )
THEN
1149 CALL
zlassq( k-
j-2, a( k+
j+1+
j*lda ), 1, scale, s )
1153 CALL
zlassq( k+
j-1, a( 0+
j*lda ), 1, scale, s )
1163 IF( aa.NE.zero )
THEN
1164 IF( scale.LT.aa )
THEN
1165 s = one + s*( scale / aa )**2
1168 s = s + ( aa / scale )**2
1171 aa = dble( a( l+1 ) )
1173 IF( aa.NE.zero )
THEN
1174 IF( scale.LT.aa )
THEN
1175 s = one + s*( scale / aa )**2
1178 s = s + ( aa / scale )**2
1185 IF( aa.NE.zero )
THEN
1186 IF( scale.LT.aa )
THEN
1187 s = one + s*( scale / aa )**2
1190 s = s + ( aa / scale )**2
1196 CALL
zlassq( n-
j-1, a(
j+1+
j*lda ), 1, scale, s )
1200 CALL
zlassq(
j, a( 0+( 1+
j )*lda ), 1, scale, s )
1207 IF( aa.NE.zero )
THEN
1208 IF( scale.LT.aa )
THEN
1209 s = one + s*( scale / aa )**2
1212 s = s + ( aa / scale )**2
1220 IF( aa.NE.zero )
THEN
1221 IF( scale.LT.aa )
THEN
1222 s = one + s*( scale / aa )**2
1225 s = s + ( aa / scale )**2
1228 aa = dble( a( l+1 ) )
1230 IF( aa.NE.zero )
THEN
1231 IF( scale.LT.aa )
THEN
1232 s = one + s*( scale / aa )**2
1235 s = s + ( aa / scale )**2
1246 CALL
zlassq(
j, a( 0+( k+
j )*lda ), 1, scale, s )
1250 CALL
zlassq( k, a( 0+
j*lda ), 1, scale, s )
1254 CALL
zlassq( k-
j-1, a(
j+1+(
j+k-1 )*lda ), 1,
1264 IF( aa.NE.zero )
THEN
1265 IF( scale.LT.aa )
THEN
1266 s = one + s*( scale / aa )**2
1269 s = s + ( aa / scale )**2
1277 IF( aa.NE.zero )
THEN
1278 IF( scale.LT.aa )
THEN
1279 s = one + s*( scale / aa )**2
1282 s = s + ( aa / scale )**2
1285 aa = dble( a( l+1 ) )
1287 IF( aa.NE.zero )
THEN
1288 IF( scale.LT.aa )
THEN
1289 s = one + s*( scale / aa )**2
1292 s = s + ( aa / scale )**2
1300 CALL
zlassq(
j, a( 0+
j*lda ), 1, scale, s )
1304 CALL
zlassq( k, a( 0+
j*lda ), 1, scale, s )
1308 CALL
zlassq( k-
j-2, a(
j+2+
j*lda ), 1, scale, s )
1318 IF( aa.NE.zero )
THEN
1319 IF( scale.LT.aa )
THEN
1320 s = one + s*( scale / aa )**2
1323 s = s + ( aa / scale )**2
1326 aa = dble( a( l+1 ) )
1328 IF( aa.NE.zero )
THEN
1329 IF( scale.LT.aa )
THEN
1330 s = one + s*( scale / aa )**2
1333 s = s + ( aa / scale )**2
1341 IF( aa.NE.zero )
THEN
1342 IF( scale.LT.aa )
THEN
1343 s = one + s*( scale / aa )**2
1346 s = s + ( aa / scale )**2
1358 CALL
zlassq( k-
j-1, a( k+
j+2+
j*lda ), 1, scale, s )
1362 CALL
zlassq( k+
j, a( 0+
j*lda ), 1, scale, s )
1372 IF( aa.NE.zero )
THEN
1373 IF( scale.LT.aa )
THEN
1374 s = one + s*( scale / aa )**2
1377 s = s + ( aa / scale )**2
1380 aa = dble( a( l+1 ) )
1382 IF( aa.NE.zero )
THEN
1383 IF( scale.LT.aa )
THEN
1384 s = one + s*( scale / aa )**2
1387 s = s + ( aa / scale )**2
1395 CALL
zlassq( n-
j-1, a(
j+2+
j*lda ), 1, scale, s )
1399 CALL
zlassq(
j, a( 0+
j*lda ), 1, scale, s )
1409 IF( aa.NE.zero )
THEN
1410 IF( scale.LT.aa )
THEN
1411 s = one + s*( scale / aa )**2
1414 s = s + ( aa / scale )**2
1417 aa = dble( a( l+1 ) )
1419 IF( aa.NE.zero )
THEN
1420 IF( scale.LT.aa )
THEN
1421 s = one + s*( scale / aa )**2
1424 s = s + ( aa / scale )**2
1435 CALL
zlassq(
j, a( 0+( k+1+
j )*lda ), 1, scale, s )
1439 CALL
zlassq( k, a( 0+
j*lda ), 1, scale, s )
1443 CALL
zlassq( k-
j-1, a(
j+1+(
j+k )*lda ), 1, scale,
1453 IF( aa.NE.zero )
THEN
1454 IF( scale.LT.aa )
THEN
1455 s = one + s*( scale / aa )**2
1458 s = s + ( aa / scale )**2
1466 IF( aa.NE.zero )
THEN
1467 IF( scale.LT.aa )
THEN
1468 s = one + s*( scale / aa )**2
1471 s = s + ( aa / scale )**2
1474 aa = dble( a( l+1 ) )
1476 IF( aa.NE.zero )
THEN
1477 IF( scale.LT.aa )
THEN
1478 s = one + s*( scale / aa )**2
1481 s = s + ( aa / scale )**2
1490 IF( aa.NE.zero )
THEN
1491 IF( scale.LT.aa )
THEN
1492 s = one + s*( scale / aa )**2
1495 s = s + ( aa / scale )**2
1501 CALL
zlassq(
j, a( 0+(
j+1 )*lda ), 1, scale, s )
1505 CALL
zlassq( k, a( 0+
j*lda ), 1, scale, s )
1509 CALL
zlassq( k-
j-1, a(
j+1+
j*lda ), 1, scale, s )
1518 IF( aa.NE.zero )
THEN
1519 IF( scale.LT.aa )
THEN
1520 s = one + s*( scale / aa )**2
1523 s = s + ( aa / scale )**2
1531 IF( aa.NE.zero )
THEN
1532 IF( scale.LT.aa )
THEN
1533 s = one + s*( scale / aa )**2
1536 s = s + ( aa / scale )**2
1539 aa = dble( a( l+1 ) )
1541 IF( aa.NE.zero )
THEN
1542 IF( scale.LT.aa )
THEN
1543 s = one + s*( scale / aa )**2
1546 s = s + ( aa / scale )**2
1554 IF( aa.NE.zero )
THEN
1555 IF( scale.LT.aa )
THEN
1556 s = one + s*( scale / aa )**2
1559 s = s + ( aa / scale )**2
1565 value = scale*sqrt( s )
subroutine zlassq(N, X, INCX, SCALE, SUMSQ)
ZLASSQ updates a sum of squares represented in scaled form.
input scalars passed by value
logical function lsame(CA, CB)
LSAME
double precision function zlanhf(NORM, TRANSR, UPLO, N, A, WORK)
ZLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian matrix in RFP format.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
logical function disnan(DIN)
DISNAN tests input for NaN.