822
823
824
825
826
827
828
829
830
831
832 COMPLEX*16 ZERO, HALF
833 parameter( zero = ( 0.0d0, 0.0d0 ),
834 $ half = ( 0.5d0, 0.0d0 ) )
835 DOUBLE PRECISION RZERO
836 parameter( rzero = 0.0d0 )
837
838 DOUBLE PRECISION EPS, THRESH
839 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
840 $ NOUT, NTRA, IORDER
841 LOGICAL FATAL, REWI, TRACE
842 CHARACTER*12 SNAME
843
844 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
845 $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
846 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
847 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
848 $ YY( NMAX*INCMAX )
849 DOUBLE PRECISION G( NMAX )
850 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
851
852 COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL
853 DOUBLE PRECISION ERR, ERRMAX
854 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
855 $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
856 $ N, NARGS, NC, NK, NS
857 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
858 CHARACTER*1 UPLO, UPLOS
859 CHARACTER*14 CUPLO
860 CHARACTER*2 ICH
861
862 LOGICAL ISAME( 13 )
863
864 LOGICAL LZE, LZERES
866
868
869 INTRINSIC abs, max
870
871 INTEGER INFOT, NOUTC
872 LOGICAL OK
873
874 COMMON /infoc/infot, noutc, ok
875
876 DATA ich/'UL'/
877
878 full = sname( 9: 9 ).EQ.'e'
879 banded = sname( 9: 9 ).EQ.'b'
880 packed = sname( 9: 9 ).EQ.'p'
881
882 IF( full )THEN
883 nargs = 10
884 ELSE IF( banded )THEN
885 nargs = 11
886 ELSE IF( packed )THEN
887 nargs = 9
888 END IF
889
890 nc = 0
891 reset = .true.
892 errmax = rzero
893
894 DO 110 in = 1, nidim
895 n = idim( in )
896
897 IF( banded )THEN
898 nk = nkb
899 ELSE
900 nk = 1
901 END IF
902 DO 100 ik = 1, nk
903 IF( banded )THEN
904 k = kb( ik )
905 ELSE
906 k = n - 1
907 END IF
908
909 IF( banded )THEN
910 lda = k + 1
911 ELSE
912 lda = n
913 END IF
914 IF( lda.LT.nmax )
915 $ lda = lda + 1
916
917 IF( lda.GT.nmax )
918 $ GO TO 100
919 IF( packed )THEN
920 laa = ( n*( n + 1 ) )/2
921 ELSE
922 laa = lda*n
923 END IF
924 null = n.LE.0
925
926 DO 90 ic = 1, 2
927 uplo = ich( ic: ic )
928 IF (uplo.EQ.'U')THEN
929 cuplo = ' CblasUpper'
930 ELSE
931 cuplo = ' CblasLower'
932 END IF
933
934
935
936 transl = zero
937 CALL zmake( sname( 8: 9 ), uplo,
' ', n, n, a, nmax, aa,
938 $ lda, k, k, reset, transl )
939
940 DO 80 ix = 1, ninc
941 incx = inc( ix )
942 lx = abs( incx )*n
943
944
945
946 transl = half
947 CALL zmake(
'ge',
' ',
' ', 1, n, x, 1, xx,
948 $ abs( incx ), 0, n - 1, reset, transl )
949 IF( n.GT.1 )THEN
950 x( n/2 ) = zero
951 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
952 END IF
953
954 DO 70 iy = 1, ninc
955 incy = inc( iy )
956 ly = abs( incy )*n
957
958 DO 60 ia = 1, nalf
959 alpha = alf( ia )
960
961 DO 50 ib = 1, nbet
962 beta = bet( ib )
963
964
965
966 transl = zero
967 CALL zmake(
'ge',
' ',
' ', 1, n, y, 1, yy,
968 $ abs( incy ), 0, n - 1, reset,
969 $ transl )
970
971 nc = nc + 1
972
973
974
975
976 uplos = uplo
977 ns = n
978 ks = k
979 als = alpha
980 DO 10 i = 1, laa
981 as( i ) = aa( i )
982 10 CONTINUE
983 ldas = lda
984 DO 20 i = 1, lx
985 xs( i ) = xx( i )
986 20 CONTINUE
987 incxs = incx
988 bls = beta
989 DO 30 i = 1, ly
990 ys( i ) = yy( i )
991 30 CONTINUE
992 incys = incy
993
994
995
996 IF( full )THEN
997 IF( trace )
998 $ WRITE( ntra, fmt = 9993 )nc, sname,
999 $ cuplo, n, alpha, lda, incx, beta, incy
1000 IF( rewi )
1001 $ rewind ntra
1002 CALL czhemv( iorder, uplo, n, alpha, aa,
1003 $ lda, xx, incx, beta, yy,
1004 $ incy )
1005 ELSE IF( banded )THEN
1006 IF( trace )
1007 $ WRITE( ntra, fmt = 9994 )nc, sname,
1008 $ cuplo, n, k, alpha, lda, incx, beta,
1009 $ incy
1010 IF( rewi )
1011 $ rewind ntra
1012 CALL czhbmv( iorder, uplo, n, k, alpha,
1013 $ aa, lda, xx, incx, beta,
1014 $ yy, incy )
1015 ELSE IF( packed )THEN
1016 IF( trace )
1017 $ WRITE( ntra, fmt = 9995 )nc, sname,
1018 $ cuplo, n, alpha, incx, beta, incy
1019 IF( rewi )
1020 $ rewind ntra
1021 CALL czhpmv( iorder, uplo, n, alpha, aa,
1022 $ xx, incx, beta, yy, incy )
1023 END IF
1024
1025
1026
1027 IF( .NOT.ok )THEN
1028 WRITE( nout, fmt = 9992 )
1029 fatal = .true.
1030 GO TO 120
1031 END IF
1032
1033
1034
1035 isame( 1 ) = uplo.EQ.uplos
1036 isame( 2 ) = ns.EQ.n
1037 IF( full )THEN
1038 isame( 3 ) = als.EQ.alpha
1039 isame( 4 ) =
lze( as, aa, laa )
1040 isame( 5 ) = ldas.EQ.lda
1041 isame( 6 ) =
lze( xs, xx, lx )
1042 isame( 7 ) = incxs.EQ.incx
1043 isame( 8 ) = bls.EQ.beta
1044 IF( null )THEN
1045 isame( 9 ) =
lze( ys, yy, ly )
1046 ELSE
1047 isame( 9 ) =
lzeres(
'ge',
' ', 1, n,
1048 $ ys, yy, abs( incy ) )
1049 END IF
1050 isame( 10 ) = incys.EQ.incy
1051 ELSE IF( banded )THEN
1052 isame( 3 ) = ks.EQ.k
1053 isame( 4 ) = als.EQ.alpha
1054 isame( 5 ) =
lze( as, aa, laa )
1055 isame( 6 ) = ldas.EQ.lda
1056 isame( 7 ) =
lze( xs, xx, lx )
1057 isame( 8 ) = incxs.EQ.incx
1058 isame( 9 ) = bls.EQ.beta
1059 IF( null )THEN
1060 isame( 10 ) =
lze( ys, yy, ly )
1061 ELSE
1062 isame( 10 ) =
lzeres(
'ge',
' ', 1, n,
1063 $ ys, yy, abs( incy ) )
1064 END IF
1065 isame( 11 ) = incys.EQ.incy
1066 ELSE IF( packed )THEN
1067 isame( 3 ) = als.EQ.alpha
1068 isame( 4 ) =
lze( as, aa, laa )
1069 isame( 5 ) =
lze( xs, xx, lx )
1070 isame( 6 ) = incxs.EQ.incx
1071 isame( 7 ) = bls.EQ.beta
1072 IF( null )THEN
1073 isame( 8 ) =
lze( ys, yy, ly )
1074 ELSE
1075 isame( 8 ) =
lzeres(
'ge',
' ', 1, n,
1076 $ ys, yy, abs( incy ) )
1077 END IF
1078 isame( 9 ) = incys.EQ.incy
1079 END IF
1080
1081
1082
1083
1084 same = .true.
1085 DO 40 i = 1, nargs
1086 same = same.AND.isame( i )
1087 IF( .NOT.isame( i ) )
1088 $ WRITE( nout, fmt = 9998 )i
1089 40 CONTINUE
1090 IF( .NOT.same )THEN
1091 fatal = .true.
1092 GO TO 120
1093 END IF
1094
1095 IF( .NOT.null )THEN
1096
1097
1098
1099 CALL zmvch(
'N', n, n, alpha, a, nmax, x,
1100 $ incx, beta, y, incy, yt, g,
1101 $ yy, eps, err, fatal, nout,
1102 $ .true. )
1103 errmax = max( errmax, err )
1104
1105
1106 IF( fatal )
1107 $ GO TO 120
1108 ELSE
1109
1110 GO TO 110
1111 END IF
1112
1113 50 CONTINUE
1114
1115 60 CONTINUE
1116
1117 70 CONTINUE
1118
1119 80 CONTINUE
1120
1121 90 CONTINUE
1122
1123 100 CONTINUE
1124
1125 110 CONTINUE
1126
1127
1128
1129 IF( errmax.LT.thresh )THEN
1130 WRITE( nout, fmt = 9999 )sname, nc
1131 ELSE
1132 WRITE( nout, fmt = 9997 )sname, nc, errmax
1133 END IF
1134 GO TO 130
1135
1136 120 CONTINUE
1137 WRITE( nout, fmt = 9996 )sname
1138 IF( full )THEN
1139 WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, lda, incx,
1140 $ beta, incy
1141 ELSE IF( banded )THEN
1142 WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, k, alpha, lda,
1143 $ incx, beta, incy
1144 ELSE IF( packed )THEN
1145 WRITE( nout, fmt = 9995 )nc, sname, cuplo, n, alpha, incx,
1146 $ beta, incy
1147 END IF
1148
1149 130 CONTINUE
1150 RETURN
1151
1152 9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1153 $ 'S)' )
1154 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1155 $ 'ANGED INCORRECTLY *******' )
1156 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1157 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1158 $ ' - SUSPECT *******' )
1159 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
1160 9995 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
1161 $ f4.1, '), AP, X,',/ 10x, i2, ',(', f4.1, ',', f4.1,
1162 $ '), Y,', i2, ') .' )
1163 9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 2( i3, ',' ), '(',
1164 $ f4.1, ',', f4.1, '), A,', i3, ', X,',/ 10x, i2, ',(',
1165 $ f4.1, ',', f4.1, '), Y,', i2, ') .' )
1166 9993 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
1167 $ f4.1, '), A,', i3, ', X,',/ 10x, i2, ',(', f4.1, ',',
1168 $ f4.1, '), ', 'Y,', i2, ') .' )
1169 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1170 $ '******' )
1171
1172
1173
logical function lze(ri, rj, lr)
logical function lzeres(type, uplo, m, n, aa, as, lda)
subroutine zmvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)