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

◆ dchk6()

subroutine dchk6 ( character*7 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,
double precision, dimension( nalf ) alf,
integer nbet,
double precision, dimension( nbet ) bet,
integer nmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax, nmax ) b,
double precision, dimension( nmax*nmax ) bb,
double precision, dimension( nmax*nmax ) bs,
double precision, dimension( nmax, nmax ) c,
double precision, dimension( nmax*nmax ) cc,
double precision, dimension( nmax*nmax ) cs,
double precision, dimension( nmax ) ct,
double precision, dimension( nmax ) g )

Definition at line 2957 of file dblat3.f.

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