LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ schk6()

subroutine schk6 ( character*7 sname,
real eps,
real thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
real, dimension( nalf ) alf,
integer nbet,
real, dimension( nbet ) bet,
integer nmax,
real, dimension( nmax, nmax ) a,
real, dimension( nmax*nmax ) aa,
real, dimension( nmax*nmax ) as,
real, dimension( nmax, nmax ) b,
real, dimension( nmax*nmax ) bb,
real, dimension( nmax*nmax ) bs,
real, dimension( nmax, nmax ) c,
real, dimension( nmax*nmax ) cc,
real, dimension( nmax*nmax ) cs,
real, dimension( nmax ) ct,
real, dimension( nmax ) g )

Definition at line 2958 of file sblat3.f.

2961*
2962* Tests SGEMMTR.
2963*
2964* Auxiliary routine for test program for Level 3 Blas.
2965*
2966* -- Written on 19-July-2023.
2967* Martin Koehler, MPI Magdeburg
2968*
2969* .. Parameters ..
2970 REAL ZERO
2971 parameter( zero = 0.0d0 )
2972* .. Scalar Arguments ..
2973 REAL EPS, THRESH
2974 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
2975 LOGICAL FATAL, REWI, TRACE
2976 CHARACTER*7 SNAME
2977* .. Array Arguments ..
2978 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2979 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
2980 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
2981 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
2982 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
2983 INTEGER IDIM( NIDIM )
2984* .. Local Scalars ..
2985 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
2986 INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA,
2987 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
2988 $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
2989 LOGICAL NULL, RESET, SAME, TRANA, TRANB
2990 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
2991 CHARACTER*3 ICH
2992 CHARACTER*2 ISHAPE
2993* .. Local Arrays ..
2994 LOGICAL ISAME( 13 )
2995* .. External Functions ..
2996 LOGICAL LSE, LSERES
2997 EXTERNAL lse, lseres
2998* .. External Subroutines ..
2999 EXTERNAL sgemmtr, dmake, dmmtch
3000* .. Intrinsic Functions ..
3001 INTRINSIC max
3002* .. Scalars in Common ..
3003 INTEGER INFOT, NOUTC
3004 LOGICAL LERR, OK
3005* .. Common blocks ..
3006 COMMON /infoc/infot, noutc, ok, lerr
3007* .. Data statements ..
3008 DATA ich/'NTC'/
3009 DATA ishape/'UL'/
3010* .. Executable Statements ..
3011*
3012 nargs = 13
3013 nc = 0
3014 reset = .true.
3015 errmax = zero
3016*
3017 DO 100 in = 1, nidim
3018 n = idim( in )
3019* Set LDC to 1 more than minimum value if room.
3020 ldc = n
3021 IF( ldc.LT.nmax )
3022 $ ldc = ldc + 1
3023* Skip tests if not enough room.
3024 IF( ldc.GT.nmax )
3025 $ GO TO 100
3026 lcc = ldc*n
3027 null = n.LE.0
3028*
3029 DO 90 ik = 1, nidim
3030 k = idim( ik )
3031*
3032 DO 80 ica = 1, 3
3033 transa = ich( ica: ica )
3034 trana = transa.EQ.'T'.OR.transa.EQ.'C'
3035*
3036 IF( trana )THEN
3037 ma = k
3038 na = n
3039 ELSE
3040 ma = n
3041 na = k
3042 END IF
3043* Set LDA to 1 more than minimum value if room.
3044 lda = ma
3045 IF( lda.LT.nmax )
3046 $ lda = lda + 1
3047* Skip tests if not enough room.
3048 IF( lda.GT.nmax )
3049 $ GO TO 80
3050 laa = lda*na
3051*
3052* Generate the matrix A.
3053*
3054 CALL smake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
3055 $ reset, zero )
3056*
3057 DO 70 icb = 1, 3
3058 transb = ich( icb: icb )
3059 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
3060*
3061 IF( tranb )THEN
3062 mb = n
3063 nb = k
3064 ELSE
3065 mb = k
3066 nb = n
3067 END IF
3068* Set LDB to 1 more than minimum value if room.
3069 ldb = mb
3070 IF( ldb.LT.nmax )
3071 $ ldb = ldb + 1
3072* Skip tests if not enough room.
3073 IF( ldb.GT.nmax )
3074 $ GO TO 70
3075 lbb = ldb*nb
3076*
3077* Generate the matrix B.
3078*
3079 CALL smake( 'GE', ' ', ' ', mb, nb, b, nmax, bb,
3080 $ ldb, reset, zero )
3081*
3082 DO 60 ia = 1, nalf
3083 alpha = alf( ia )
3084*
3085 DO 50 ib = 1, nbet
3086 beta = bet( ib )
3087
3088 DO 45 is = 1, 2
3089 uplo = ishape( is: is )
3090
3091*
3092* Generate the matrix C.
3093*
3094 CALL smake( 'GE', uplo, ' ', n, n, c,
3095 $ nmax, cc, ldc, reset, zero )
3096*
3097 nc = nc + 1
3098*
3099* Save every datum before calling the
3100* subroutine.
3101*
3102 uplos = uplo
3103 tranas = transa
3104 tranbs = transb
3105 ns = n
3106 ks = k
3107 als = alpha
3108 DO 10 i = 1, laa
3109 as( i ) = aa( i )
3110 10 CONTINUE
3111 ldas = lda
3112 DO 20 i = 1, lbb
3113 bs( i ) = bb( i )
3114 20 CONTINUE
3115 ldbs = ldb
3116 bls = beta
3117 DO 30 i = 1, lcc
3118 cs( i ) = cc( i )
3119 30 CONTINUE
3120 ldcs = ldc
3121*
3122* Call the subroutine.
3123*
3124 IF( trace )
3125 $ WRITE( ntra, fmt = 9995 )nc, sname,
3126 $ uplo, transa, transb, n, k, alpha, lda,
3127 $ ldb, beta, ldc
3128 IF( rewi )
3129 $ rewind ntra
3130 CALL sgemmtr( uplo, transa, transb, n,
3131 $ k, alpha, aa, lda, bb, ldb,
3132 $ beta, cc, ldc )
3133*
3134* Check if error-exit was taken incorrectly.
3135*
3136 IF( .NOT.ok )THEN
3137 WRITE( nout, fmt = 9994 )
3138 fatal = .true.
3139 GO TO 120
3140 END IF
3141*
3142* See what data changed inside subroutines.
3143*
3144 isame( 1 ) = uplo.EQ.uplos
3145 isame( 2 ) = transa.EQ.tranas
3146 isame( 3 ) = transb.EQ.tranbs
3147 isame( 4 ) = ns.EQ.n
3148 isame( 5 ) = ks.EQ.k
3149 isame( 6 ) = als.EQ.alpha
3150 isame( 7 ) = lse( as, aa, laa )
3151 isame( 8 ) = ldas.EQ.lda
3152 isame( 9 ) = lse( bs, bb, lbb )
3153 isame( 10 ) = ldbs.EQ.ldb
3154 isame( 11 ) = bls.EQ.beta
3155 IF( null )THEN
3156 isame( 12 ) = lse( cs, cc, lcc )
3157 ELSE
3158 isame( 12 ) = lseres( 'GE', ' ', n, n,
3159 $ cs, cc, ldc )
3160 END IF
3161 isame( 13 ) = ldcs.EQ.ldc
3162*
3163* If data was incorrectly changed, report
3164* and return.
3165*
3166 same = .true.
3167 DO 40 i = 1, nargs
3168 same = same.AND.isame( i )
3169 IF( .NOT.isame( i ) )
3170 $ WRITE( nout, fmt = 9998 )i
3171 40 CONTINUE
3172 IF( .NOT.same )THEN
3173 fatal = .true.
3174 GO TO 120
3175 END IF
3176*
3177 IF( .NOT.null )THEN
3178*
3179* Check the result.
3180*
3181 CALL smmtch( uplo, transa, transb,
3182 $ n, k,
3183 $ alpha, a, nmax, b, nmax, beta,
3184 $ c, nmax, ct, g, cc, ldc, eps,
3185 $ err, fatal, nout, .true. )
3186 errmax = max( errmax, err )
3187* If got really bad answer, report and
3188* return.
3189 IF( fatal )
3190 $ GO TO 120
3191 END IF
3192*
3193 45 CONTINUE
3194*
3195 50 CONTINUE
3196*
3197 60 CONTINUE
3198*
3199 70 CONTINUE
3200*
3201 80 CONTINUE
3202*
3203 90 CONTINUE
3204*
3205 100 CONTINUE
3206*
3207*
3208* Report result.
3209*
3210 IF( errmax.LT.thresh )THEN
3211 WRITE( nout, fmt = 9999 )sname, nc
3212 ELSE
3213 WRITE( nout, fmt = 9997 )sname, nc, errmax
3214 END IF
3215 GO TO 130
3216*
3217 120 CONTINUE
3218 WRITE( nout, fmt = 9996 )sname
3219 WRITE( nout, fmt = 9995 )nc, sname, uplo, transa, transb, n, k,
3220 $ alpha, lda, ldb, beta, ldc
3221*
3222 130 CONTINUE
3223 RETURN
3224*
3225 9999 FORMAT( ' ', a7, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
3226 $ 'S)' )
3227 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
3228 $ 'ANGED INCORRECTLY *******' )
3229 9997 FORMAT( ' ', a7, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
3230 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
3231 $ ' - SUSPECT *******' )
3232 9996 FORMAT( ' ******* ', a7, ' FAILED ON CALL NUMBER:' )
3233 9995 FORMAT( 1x, i6, ': ', a7, '(''',a1, ''',''',a1, ''',''', a1,''',',
3234 $ 2( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', ',
3235 $ 'C,', i3, ').' )
3236 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
3237 $ '******' )
3238*
3239* End of DCHK6
3240*
dmake
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition dblat2.f:2678
dmmtch
subroutine dmmtch(uplo, transa, transb, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition dblat3.f:3245
sgemmtr
subroutine sgemmtr(uplo, transa, transb, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMMTR
Definition sgemmtr.f:191
lseres
logical function lseres(type, uplo, m, n, aa, as, lda)
Definition sblat2.f:3000
smake
subroutine smake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition sblat2.f:2678
lse
logical function lse(ri, rj, lr)
Definition sblat2.f:2970
smmtch
subroutine smmtch(uplo, transa, transb, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition sblat3.f:3246
Here is the call graph for this function: