697
698
699
700
701
702
703
704
705
706
707
708
709 COMPLEX ZERO
710 parameter( zero = ( 0.0, 0.0 ) )
711 REAL RZERO
712 parameter( rzero = 0.0 )
713
714 REAL EPS, THRESH
715 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
716 LOGICAL FATAL, REWI, TRACE
717 CHARACTER*7 SNAME
718
719 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
720 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
721 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
722 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
723 $ CS( NMAX*NMAX ), CT( NMAX )
724 REAL G( NMAX )
725 INTEGER IDIM( NIDIM )
726
727 COMPLEX ALPHA, ALS, BETA, BLS
728 REAL ERR, ERRMAX
729 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
730 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
731 $ NARGS, NC, NS
732 LOGICAL CONJ, LEFT, NULL, RESET, SAME
733 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
734 CHARACTER*2 ICHS, ICHU
735
736 LOGICAL ISAME( 13 )
737
738 LOGICAL LCE, LCERES
740
742
743 INTRINSIC max
744
745 INTEGER INFOT, NOUTC
746 LOGICAL LERR, OK
747
748 COMMON /infoc/infot, noutc, ok, lerr
749
750 DATA ichs/'LR'/, ichu/'UL'/
751
752 conj = sname( 2: 3 ).EQ.'HE'
753
754 nargs = 12
755 nc = 0
756 reset = .true.
757 errmax = rzero
758
759 DO 100 im = 1, nidim
760 m = idim( im )
761
762 DO 90 in = 1, nidim
763 n = idim( in )
764
765 ldc = m
766 IF( ldc.LT.nmax )
767 $ ldc = ldc + 1
768
769 IF( ldc.GT.nmax )
770 $ GO TO 90
771 lcc = ldc*n
772 null = n.LE.0.OR.m.LE.0
773
774 ldb = m
775 IF( ldb.LT.nmax )
776 $ ldb = ldb + 1
777
778 IF( ldb.GT.nmax )
779 $ GO TO 90
780 lbb = ldb*n
781
782
783
784 CALL cmake(
'GE',
' ',
' ', m, n, b, nmax, bb, ldb, reset,
785 $ zero )
786
787 DO 80 ics = 1, 2
788 side = ichs( ics: ics )
789 left = side.EQ.'L'
790
791 IF( left )THEN
792 na = m
793 ELSE
794 na = n
795 END IF
796
797 lda = na
798 IF( lda.LT.nmax )
799 $ lda = lda + 1
800
801 IF( lda.GT.nmax )
802 $ GO TO 80
803 laa = lda*na
804
805 DO 70 icu = 1, 2
806 uplo = ichu( icu: icu )
807
808
809
810 CALL cmake( sname( 2: 3 ), uplo,
' ', na, na, a, nmax,
811 $ aa, lda, reset, zero )
812
813 DO 60 ia = 1, nalf
814 alpha = alf( ia )
815
816 DO 50 ib = 1, nbet
817 beta = bet( ib )
818
819
820
821 CALL cmake(
'GE',
' ',
' ', m, n, c, nmax, cc,
822 $ ldc, reset, zero )
823
824 nc = nc + 1
825
826
827
828
829 sides = side
830 uplos = uplo
831 ms = m
832 ns = n
833 als = alpha
834 DO 10 i = 1, laa
835 as( i ) = aa( i )
836 10 CONTINUE
837 ldas = lda
838 DO 20 i = 1, lbb
839 bs( i ) = bb( i )
840 20 CONTINUE
841 ldbs = ldb
842 bls = beta
843 DO 30 i = 1, lcc
844 cs( i ) = cc( i )
845 30 CONTINUE
846 ldcs = ldc
847
848
849
850 IF( trace )
851 $ WRITE( ntra, fmt = 9995 )nc, sname, side,
852 $ uplo, m, n, alpha, lda, ldb, beta, ldc
853 IF( rewi )
854 $ rewind ntra
855 IF( conj )THEN
856 CALL chemm( side, uplo, m, n, alpha, aa, lda,
857 $ bb, ldb, beta, cc, ldc )
858 ELSE
859 CALL csymm( side, uplo, m, n, alpha, aa, lda,
860 $ bb, ldb, beta, cc, ldc )
861 END IF
862
863
864
865 IF( .NOT.ok )THEN
866 WRITE( nout, fmt = 9994 )
867 fatal = .true.
868 GO TO 110
869 END IF
870
871
872
873 isame( 1 ) = sides.EQ.side
874 isame( 2 ) = uplos.EQ.uplo
875 isame( 3 ) = ms.EQ.m
876 isame( 4 ) = ns.EQ.n
877 isame( 5 ) = als.EQ.alpha
878 isame( 6 ) =
lce( as, aa, laa )
879 isame( 7 ) = ldas.EQ.lda
880 isame( 8 ) =
lce( bs, bb, lbb )
881 isame( 9 ) = ldbs.EQ.ldb
882 isame( 10 ) = bls.EQ.beta
883 IF( null )THEN
884 isame( 11 ) =
lce( cs, cc, lcc )
885 ELSE
886 isame( 11 ) =
lceres(
'GE',
' ', m, n, cs,
887 $ cc, ldc )
888 END IF
889 isame( 12 ) = ldcs.EQ.ldc
890
891
892
893
894 same = .true.
895 DO 40 i = 1, nargs
896 same = same.AND.isame( i )
897 IF( .NOT.isame( i ) )
898 $ WRITE( nout, fmt = 9998 )i
899 40 CONTINUE
900 IF( .NOT.same )THEN
901 fatal = .true.
902 GO TO 110
903 END IF
904
905 IF( .NOT.null )THEN
906
907
908
909 IF( left )THEN
910 CALL cmmch(
'N',
'N', m, n, m, alpha, a,
911 $ nmax, b, nmax, beta, c, nmax,
912 $ ct, g, cc, ldc, eps, err,
913 $ fatal, nout, .true. )
914 ELSE
915 CALL cmmch(
'N',
'N', m, n, n, alpha, b,
916 $ nmax, a, nmax, beta, c, nmax,
917 $ ct, g, cc, ldc, eps, err,
918 $ fatal, nout, .true. )
919 END IF
920 errmax = max( errmax, err )
921
922
923 IF( fatal )
924 $ GO TO 110
925 END IF
926
927 50 CONTINUE
928
929 60 CONTINUE
930
931 70 CONTINUE
932
933 80 CONTINUE
934
935 90 CONTINUE
936
937 100 CONTINUE
938
939
940
941 IF( errmax.LT.thresh )THEN
942 WRITE( nout, fmt = 9999 )sname, nc
943 ELSE
944 WRITE( nout, fmt = 9997 )sname, nc, errmax
945 END IF
946 GO TO 120
947
948 110 CONTINUE
949 WRITE( nout, fmt = 9996 )sname
950 WRITE( nout, fmt = 9995 )nc, sname, side, uplo, m, n, alpha, lda,
951 $ ldb, beta, ldc
952
953 120 CONTINUE
954 RETURN
955
956 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
957 $ 'S)' )
958 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
959 $ 'ANGED INCORRECTLY *******' )
960 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
961 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
962 $ ' - SUSPECT *******' )
963 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
964 9995 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
965 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
966 $ ',', f4.1, '), C,', i3, ') .' )
967 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
968 $ '******' )
969
970
971
subroutine cmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
logical function lceres(type, uplo, m, n, aa, as, lda)
logical function lce(ri, rj, lr)
subroutine cmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
subroutine chemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CHEMM
subroutine csymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CSYMM