LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
•All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Modules Pages

◆ zchk6()

subroutine zchk6 ( character*13 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
complex*16, dimension( nalf ) alf,
integer nbet,
complex*16, dimension( nbet ) bet,
integer nmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax, nmax ) b,
complex*16, dimension( nmax*nmax ) bb,
complex*16, dimension( nmax*nmax ) bs,
complex*16, dimension( nmax, nmax ) c,
complex*16, dimension( nmax*nmax ) cc,
complex*16, dimension( nmax*nmax ) cs,
complex*16, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
integer iorder )

Definition at line 2808 of file c_zblat3.f.

2812 IMPLICIT NONE
2813*
2814* Tests CGEMMTR.
2815*
2816* Auxiliary routine for test program for Level 3 Blas.
2817*
2818* -- Written on 24-June-2024.
2819* Martin Koehler, Max Planck Institute Magdeburg
2820*
2821* .. Parameters ..
2822 COMPLEX*16 ZERO
2823 parameter( zero = ( 0.0, 0.0 ) )
2824 DOUBLE PRECISION RZERO
2825 parameter( rzero = 0.0 )
2826* .. Scalar Arguments ..
2827 DOUBLE PRECISION EPS, THRESH
2828 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
2829 LOGICAL FATAL, REWI, TRACE
2830 CHARACTER*13 SNAME
2831* .. Array Arguments ..
2832 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2833 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
2834 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
2835 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
2836 $ CS( NMAX*NMAX ), CT( NMAX )
2837 DOUBLE PRECISION G( NMAX )
2838 INTEGER IDIM( NIDIM )
2839* .. Local Scalars ..
2840 COMPLEX*16 ALPHA, ALS, BETA, BLS
2841 DOUBLE PRECISION ERR, ERRMAX
2842 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
2843 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
2844 $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
2845 LOGICAL NULL, RESET, SAME, TRANA, TRANB
2846 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
2847 CHARACTER*3 ICH
2848 CHARACTER*2 ISHAPE
2849* .. Local Arrays ..
2850 LOGICAL ISAME( 13 )
2851* .. External Functions ..
2852 LOGICAL LZE, LZERES
2853 EXTERNAL lze, lzeres
2854* .. External Subroutines ..
2855 EXTERNAL czgemmtr, zmake, zmmtch, zprcn8
2856* .. Intrinsic Functions ..
2857 INTRINSIC max
2858* .. Scalars in Common ..
2859 INTEGER INFOT, NOUTC
2860 LOGICAL LERR, OK
2861* .. Common blocks ..
2862 COMMON /infoc/infot, noutc, ok, lerr
2863* .. Data statements ..
2864 DATA ich/'NTC'/
2865 DATA ishape/'UL'/
2866* .. Executable Statements ..
2867*
2868 nargs = 13
2869 nc = 0
2870 reset = .true.
2871 errmax = rzero
2872*
2873 DO 100 in = 1, nidim
2874 n = idim( in )
2875* Set LDC to 1 more than minimum value if room.
2876 ldc = n
2877 IF( ldc.LT.nmax )
2878 $ ldc = ldc + 1
2879* Skip tests if not enough room.
2880 IF( ldc.GT.nmax )
2881 $ GO TO 100
2882 lcc = ldc*n
2883 null = n.LE.0.
2884*
2885 DO 90 ik = 1, nidim
2886 k = idim( ik )
2887*
2888 DO 80 ica = 1, 3
2889 transa = ich( ica: ica )
2890 trana = transa.EQ.'T'.OR.transa.EQ.'C'
2891*
2892 IF( trana )THEN
2893 ma = k
2894 na = n
2895 ELSE
2896 ma = n
2897 na = k
2898 END IF
2899* Set LDA to 1 more than minimum value if room.
2900 lda = ma
2901 IF( lda.LT.nmax )
2902 $ lda = lda + 1
2903* Skip tests if not enough room.
2904 IF( lda.GT.nmax )
2905 $ GO TO 80
2906 laa = lda*na
2907*
2908* Generate the matrix A.
2909*
2910 CALL zmake( 'ge', ' ', ' ', ma, na, a, nmax, aa, lda,
2911 $ reset, zero )
2912*
2913 DO 70 icb = 1, 3
2914 transb = ich( icb: icb )
2915 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2916*
2917 IF( tranb )THEN
2918 mb = n
2919 nb = k
2920 ELSE
2921 mb = k
2922 nb = n
2923 END IF
2924* Set LDB to 1 more than minimum value if room.
2925 ldb = mb
2926 IF( ldb.LT.nmax )
2927 $ ldb = ldb + 1
2928* Skip tests if not enough room.
2929 IF( ldb.GT.nmax )
2930 $ GO TO 70
2931 lbb = ldb*nb
2932*
2933* Generate the matrix B.
2934*
2935 CALL zmake( 'ge', ' ', ' ', mb, nb, b, nmax, bb,
2936 $ ldb, reset, zero )
2937*
2938 DO 60 ia = 1, nalf
2939 alpha = alf( ia )
2940*
2941 DO 50 ib = 1, nbet
2942 beta = bet( ib )
2943 DO 45 is = 1, 2
2944 uplo = ishape(is:is)
2945*
2946* Generate the matrix C.
2947*
2948 CALL zmake( 'ge', uplo, ' ', n, n, c, nmax,
2949 $ cc, ldc, reset, zero )
2950*
2951 nc = nc + 1
2952*
2953* Save every datum before calling the
2954* subroutine.
2955*
2956 uplos = uplo
2957 tranas = transa
2958 tranbs = transb
2959 ns = n
2960 ks = k
2961 als = alpha
2962 DO 10 i = 1, laa
2963 as( i ) = aa( i )
2964 10 CONTINUE
2965 ldas = lda
2966 DO 20 i = 1, lbb
2967 bs( i ) = bb( i )
2968 20 CONTINUE
2969 ldbs = ldb
2970 bls = beta
2971 DO 30 i = 1, lcc
2972 cs( i ) = cc( i )
2973 30 CONTINUE
2974 ldcs = ldc
2975*
2976* Call the subroutine.
2977*
2978 IF( trace )
2979 $ CALL zprcn8(ntra, nc, sname, iorder, uplo,
2980 $ transa, transb, n, k, alpha, lda,
2981 $ ldb, beta, ldc)
2982 IF( rewi )
2983 $ rewind ntra
2984 CALL czgemmtr(iorder, uplo, transa, transb,
2985 $ n, k, alpha, aa, lda, bb, ldb,
2986 $ beta, cc, ldc )
2987*
2988* Check if error-exit was taken incorrectly.
2989*
2990 IF( .NOT.ok )THEN
2991 WRITE( nout, fmt = 9994 )
2992 fatal = .true.
2993 GO TO 120
2994 END IF
2995*
2996* See what data changed inside subroutines.
2997*
2998 isame( 1 ) = uplo .EQ. uplos
2999 isame( 2 ) = transa.EQ.tranas
3000 isame( 3 ) = transb.EQ.tranbs
3001 isame( 4 ) = ns.EQ.n
3002 isame( 5 ) = ks.EQ.k
3003 isame( 6 ) = als.EQ.alpha
3004 isame( 7 ) = lze( as, aa, laa )
3005 isame( 8 ) = ldas.EQ.lda
3006 isame( 9 ) = lze( bs, bb, lbb )
3007 isame( 10 ) = ldbs.EQ.ldb
3008 isame( 11 ) = bls.EQ.beta
3009 IF( null )THEN
3010 isame( 12 ) = lze( cs, cc, lcc )
3011 ELSE
3012 isame( 12 ) = lzeres( 'ge', ' ', n, n, cs,
3013 $ cc, ldc )
3014 END IF
3015 isame( 13 ) = ldcs.EQ.ldc
3016*
3017* If data was incorrectly changed, report
3018* and return.
3019*
3020 same = .true.
3021 DO 40 i = 1, nargs
3022 same = same.AND.isame( i )
3023 IF( .NOT.isame( i ) )
3024 $ WRITE( nout, fmt = 9998 )i
3025 40 CONTINUE
3026 IF( .NOT.same )THEN
3027 fatal = .true.
3028 GO TO 120
3029 END IF
3030*
3031 IF( .NOT.null )THEN
3032*
3033* Check the result.
3034*
3035 CALL zmmtch( uplo, transa, transb, n, k,
3036 $ alpha, a, nmax, b, nmax, beta,
3037 $ c, nmax, ct, g, cc, ldc, eps,
3038 $ err, fatal, nout, .true. )
3039 errmax = max( errmax, err )
3040* If got really bad answer, report and
3041* return.
3042 IF( fatal )
3043 $ GO TO 120
3044 END IF
3045*
3046 45 CONTINUE
3047*
3048 50 CONTINUE
3049*
3050 60 CONTINUE
3051*
3052 70 CONTINUE
3053*
3054 80 CONTINUE
3055*
3056 90 CONTINUE
3057*
3058 100 CONTINUE
3059*
3060*
3061* Report result.
3062*
3063 IF( errmax.LT.thresh )THEN
3064 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
3065 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
3066 ELSE
3067 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
3068 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
3069 END IF
3070 GO TO 130
3071*
3072 120 CONTINUE
3073 WRITE( nout, fmt = 9996 )sname
3074 CALL zprcn8(nout, nc, sname, iorder, uplo, transa, transb,
3075 $ n, k, alpha, lda, ldb, beta, ldc)
3076*
3077 130 CONTINUE
3078 RETURN
3079*
308010003 FORMAT( ' ', a13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
3081 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
3082 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
308310002 FORMAT( ' ', a13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
3084 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
3085 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
308610001 FORMAT( ' ', a13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
3087 $ ' (', i6, ' CALL', 'S)' )
308810000 FORMAT( ' ', a13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
3089 $ ' (', i6, ' CALL', 'S)' )
3090 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
3091 $ 'ANGED INCORRECTLY *******' )
3092 9996 FORMAT( ' ******* ', a13,' FAILED ON CALL NUMBER:' )
3093 9995 FORMAT( 1x, i6, ': ', a13,'(''', a1, ''',''', a1, ''',',
3094 $ 3( i3, ',' ), '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3,
3095 $ ',(', f4.1, ',', f4.1, '), C,', i3, ').' )
3096 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
3097 $ '******' )
3098*
3099* End of ZCHK6.
3100*
zprcn8
subroutine zprcn8(nout, nc, sname, iorder, uplo, transa, transb, n, k, alpha, lda, ldb, beta, ldc)
Definition c_zblat3.f:3106
lze
logical function lze(ri, rj, lr)
Definition zblat2.f:3075
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition zblat2.f:3105
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition zblat2.f:2751
zmmtch
subroutine zmmtch(uplo, transa, transb, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition zblat3.f:4000
Here is the call graph for this function: