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

◆ dchk6()

subroutine dchk6 ( 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,
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,
integer iorder )

Definition at line 2494 of file c_dblat3.f.

2498*
2499* Tests DGEMMTR.
2500*
2501* Auxiliary routine for test program for Level 3 Blas.
2502*
2503* -- Written on 19-July-2023.
2504* Martin Koehler, MPI Magdeburg
2505*
2506* .. Parameters ..
2507 DOUBLE PRECISION ZERO
2508 parameter( zero = 0.0d0 )
2509* .. Scalar Arguments ..
2510 DOUBLE PRECISION EPS, THRESH
2511 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
2512 LOGICAL FATAL, REWI, TRACE
2513 CHARACTER*13 SNAME
2514* .. Array Arguments ..
2515 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2516 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
2517 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
2518 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
2519 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
2520 INTEGER IDIM( NIDIM )
2521* .. Local Scalars ..
2522 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
2523 INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA,
2524 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
2525 $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
2526 LOGICAL NULL, RESET, SAME, TRANA, TRANB
2527 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
2528 CHARACTER*3 ICH
2529 CHARACTER*2 ISHAPE
2530* .. Local Arrays ..
2531 LOGICAL ISAME( 13 )
2532* .. External Functions ..
2533 LOGICAL LDE, LDERES
2534 EXTERNAL lde, lderes
2535* .. External Subroutines ..
2536 EXTERNAL cdgemmtr, dmake, dmmtch
2537* .. Intrinsic Functions ..
2538 INTRINSIC max
2539* .. Scalars in Common ..
2540 INTEGER INFOT, NOUTC
2541 LOGICAL LERR, OK
2542* .. Common blocks ..
2543 COMMON /infoc/infot, noutc, ok, lerr
2544* .. Data statements ..
2545 DATA ich/'NTC'/
2546 DATA ishape/'UL'/
2547* .. Executable Statements ..
2548*
2549 nargs = 13
2550 nc = 0
2551 reset = .true.
2552 errmax = zero
2553*
2554 DO 100 in = 1, nidim
2555 n = idim( in )
2556* Set LDC to 1 more than minimum value if room.
2557 ldc = n
2558 IF( ldc.LT.nmax )
2559 $ ldc = ldc + 1
2560* Skip tests if not enough room.
2561 IF( ldc.GT.nmax )
2562 $ GO TO 100
2563 lcc = ldc*n
2564 null = n.LE.0
2565*
2566 DO 90 ik = 1, nidim
2567 k = idim( ik )
2568*
2569 DO 80 ica = 1, 3
2570 transa = ich( ica: ica )
2571 trana = transa.EQ.'T'.OR.transa.EQ.'C'
2572*
2573 IF( trana )THEN
2574 ma = k
2575 na = n
2576 ELSE
2577 ma = n
2578 na = k
2579 END IF
2580* Set LDA to 1 more than minimum value if room.
2581 lda = ma
2582 IF( lda.LT.nmax )
2583 $ lda = lda + 1
2584* Skip tests if not enough room.
2585 IF( lda.GT.nmax )
2586 $ GO TO 80
2587 laa = lda*na
2588*
2589* Generate the matrix A.
2590*
2591 CALL dmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
2592 $ reset, zero )
2593*
2594 DO 70 icb = 1, 3
2595 transb = ich( icb: icb )
2596 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2597*
2598 IF( tranb )THEN
2599 mb = n
2600 nb = k
2601 ELSE
2602 mb = k
2603 nb = n
2604 END IF
2605* Set LDB to 1 more than minimum value if room.
2606 ldb = mb
2607 IF( ldb.LT.nmax )
2608 $ ldb = ldb + 1
2609* Skip tests if not enough room.
2610 IF( ldb.GT.nmax )
2611 $ GO TO 70
2612 lbb = ldb*nb
2613*
2614* Generate the matrix B.
2615*
2616 CALL dmake( 'GE', ' ', ' ', mb, nb, b, nmax, bb,
2617 $ ldb, reset, zero )
2618*
2619 DO 60 ia = 1, nalf
2620 alpha = alf( ia )
2621*
2622 DO 50 ib = 1, nbet
2623 beta = bet( ib )
2624
2625 DO 45 is = 1, 2
2626 uplo = ishape( is: is )
2627
2628*
2629* Generate the matrix C.
2630*
2631 CALL dmake( 'GE', uplo, ' ', n, n, c,
2632 $ nmax, cc, ldc, reset, zero )
2633*
2634 nc = nc + 1
2635*
2636* Save every datum before calling the
2637* subroutine.
2638*
2639 uplos = uplo
2640 tranas = transa
2641 tranbs = transb
2642 ns = n
2643 ks = k
2644 als = alpha
2645 DO 10 i = 1, laa
2646 as( i ) = aa( i )
2647 10 CONTINUE
2648 ldas = lda
2649 DO 20 i = 1, lbb
2650 bs( i ) = bb( i )
2651 20 CONTINUE
2652 ldbs = ldb
2653 bls = beta
2654 DO 30 i = 1, lcc
2655 cs( i ) = cc( i )
2656 30 CONTINUE
2657 ldcs = ldc
2658*
2659* Call the subroutine.
2660*
2661 IF( trace )
2662 $ CALL dprcn8(ntra, nc, sname, iorder, uplo,
2663 $ transa, transb, n, k, alpha, lda,
2664 $ ldb, beta, ldc)
2665 IF( rewi )
2666 $ rewind ntra
2667 CALL cdgemmtr( iorder, uplo, transa, transb,
2668 $ n, k, alpha, aa, lda, bb, ldb,
2669 $ beta, cc, ldc )
2670*
2671* Check if error-exit was taken incorrectly.
2672*
2673 IF( .NOT.ok )THEN
2674 WRITE( nout, fmt = 9994 )
2675 fatal = .true.
2676 GO TO 120
2677 END IF
2678*
2679* See what data changed inside subroutines.
2680*
2681 isame( 1 ) = uplo.EQ.uplos
2682 isame( 2 ) = transa.EQ.tranas
2683 isame( 3 ) = transb.EQ.tranbs
2684 isame( 4 ) = ns.EQ.n
2685 isame( 5 ) = ks.EQ.k
2686 isame( 6 ) = als.EQ.alpha
2687 isame( 7 ) = lde( as, aa, laa )
2688 isame( 8 ) = ldas.EQ.lda
2689 isame( 9 ) = lde( bs, bb, lbb )
2690 isame( 10 ) = ldbs.EQ.ldb
2691 isame( 11 ) = bls.EQ.beta
2692 IF( null )THEN
2693 isame( 12 ) = lde( cs, cc, lcc )
2694 ELSE
2695 isame( 12 ) = lderes( 'GE', ' ', n, n,
2696 $ cs, cc, ldc )
2697 END IF
2698 isame( 13 ) = ldcs.EQ.ldc
2699*
2700* If data was incorrectly changed, report
2701* and return.
2702*
2703 same = .true.
2704 DO 40 i = 1, nargs
2705 same = same.AND.isame( i )
2706 IF( .NOT.isame( i ) )
2707 $ WRITE( nout, fmt = 9998 )i
2708 40 CONTINUE
2709 IF( .NOT.same )THEN
2710 fatal = .true.
2711 GO TO 120
2712 END IF
2713*
2714 IF( .NOT.null )THEN
2715*
2716* Check the result.
2717*
2718 CALL dmmtch( uplo, transa, transb,
2719 $ n, k,
2720 $ alpha, a, nmax, b, nmax, beta,
2721 $ c, nmax, ct, g, cc, ldc, eps,
2722 $ err, fatal, nout, .true. )
2723 errmax = max( errmax, err )
2724* If got really bad answer, report and
2725* return.
2726 IF( fatal )
2727 $ GO TO 120
2728 END IF
2729*
2730 45 CONTINUE
2731*
2732 50 CONTINUE
2733*
2734 60 CONTINUE
2735*
2736 70 CONTINUE
2737*
2738 80 CONTINUE
2739*
2740 90 CONTINUE
2741*
2742 100 CONTINUE
2743*
2744*
2745* Report result.
2746*
2747 IF( errmax.LT.thresh )THEN
2748 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2749 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2750 ELSE
2751 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2752 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2753 END IF
2754 GO TO 130
2755*
2756 120 CONTINUE
2757 WRITE( nout, fmt = 9996 )sname
2758 CALL dprcn8(nout, nc, sname, iorder, uplo, transa, transb,
2759 $ n, k, alpha, lda, ldb, beta, ldc)
2760*
2761 130 CONTINUE
2762 RETURN
2763*
276410003 FORMAT( ' ', a13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2765 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2766 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
276710002 FORMAT( ' ', a13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2768 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2769 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
277010001 FORMAT( ' ', a13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2771 $ ' (', i6, ' CALL', 'S)' )
277210000 FORMAT( ' ', a13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2773 $ ' (', i6, ' CALL', 'S)' )
2774 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2775 $ 'ANGED INCORRECTLY *******' )
2776 9997 FORMAT( ' ', a13, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2777 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2778 $ ' - SUSPECT *******' )
2779 9996 FORMAT( ' ******* ', a13, ' FAILED ON CALL NUMBER:' )
2780 9995 FORMAT( 1x, i6, ': ', a13, '(''',a1, ''',''',a1, ''',''', a1,''',',
2781 $ 2( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', ',
2782 $ 'C,', i3, ').' )
2783 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2784 $ '******' )
2785*
2786* End of DCHK6
2787*
dprcn8
subroutine dprcn8(nout, nc, sname, iorder, uplo, transa, transb, n, k, alpha, lda, ldb, beta, ldc)
Definition c_dblat3.f:2793
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
Here is the call graph for this function: