OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
c_sblat3.f File Reference

Go to the source code of this file.

Functions/Subroutines

program sblat3
subroutine schk1 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, nbet, bet, nmax, a, aa, as, b, bb, bs, c, cc, cs, ct, g, iorder)
subroutine sprcn1 (nout, nc, sname, iorder, transa, transb, m, n, k, alpha, lda, ldb, beta, ldc)
subroutine schk2 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, nbet, bet, nmax, a, aa, as, b, bb, bs, c, cc, cs, ct, g, iorder)
subroutine sprcn2 (nout, nc, sname, iorder, side, uplo, m, n, alpha, lda, ldb, beta, ldc)
subroutine schk3 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, nmax, a, aa, as, b, bb, bs, ct, g, c, iorder)
subroutine sprcn3 (nout, nc, sname, iorder, side, uplo, transa, diag, m, n, alpha, lda, ldb)
subroutine schk4 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, nbet, bet, nmax, a, aa, as, b, bb, bs, c, cc, cs, ct, g, iorder)
subroutine sprcn4 (nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
subroutine schk5 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, nbet, bet, nmax, ab, aa, as, bb, bs, c, cc, cs, ct, g, w, iorder)
subroutine sprcn5 (nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
subroutine smake (type, uplo, diag, m, n, a, nmax, aa, lda, reset, transl)
subroutine smmch (transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
logical function lse (ri, rj, lr)
logical function lseres (type, uplo, m, n, aa, as, lda)
real function sbeg (reset)
real function sdiff (x, y)

Function/Subroutine Documentation

◆ lse()

logical function lse ( real, dimension( * ) ri,
real, dimension( * ) rj,
integer lr )

Definition at line 2322 of file c_sblat3.f.

2323*
2324* Tests if two arrays are identical.
2325*
2326* Auxiliary routine for test program for Level 3 Blas.
2327*
2328* -- Written on 8-February-1989.
2329* Jack Dongarra, Argonne National Laboratory.
2330* Iain Duff, AERE Harwell.
2331* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2332* Sven Hammarling, Numerical Algorithms Group Ltd.
2333*
2334* .. Scalar Arguments ..
2335 INTEGER LR
2336* .. Array Arguments ..
2337 REAL RI( * ), RJ( * )
2338* .. Local Scalars ..
2339 INTEGER I
2340* .. Executable Statements ..
2341 DO 10 i = 1, lr
2342 IF( ri( i ).NE.rj( i ) )
2343 $ GO TO 20
2344 10 CONTINUE
2345 lse = .true.
2346 GO TO 30
2347 20 CONTINUE
2348 lse = .false.
2349 30 RETURN
2350*
2351* End of LSE.
2352*
lse
logical function lse(ri, rj, lr)
Definition c_sblat3.f:2323

◆ lseres()

logical function lseres ( character*2 type,
character*1 uplo,
integer m,
integer n,
real, dimension( lda, * ) aa,
real, dimension( lda, * ) as,
integer lda )

Definition at line 2354 of file c_sblat3.f.

2355*
2356* Tests if selected elements in two arrays are equal.
2357*
2358* TYPE is 'GE' or 'SY'.
2359*
2360* Auxiliary routine for test program for Level 3 Blas.
2361*
2362* -- Written on 8-February-1989.
2363* Jack Dongarra, Argonne National Laboratory.
2364* Iain Duff, AERE Harwell.
2365* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2366* Sven Hammarling, Numerical Algorithms Group Ltd.
2367*
2368* .. Scalar Arguments ..
2369 INTEGER LDA, M, N
2370 CHARACTER*1 UPLO
2371 CHARACTER*2 TYPE
2372* .. Array Arguments ..
2373 REAL AA( LDA, * ), AS( LDA, * )
2374* .. Local Scalars ..
2375 INTEGER I, IBEG, IEND, J
2376 LOGICAL UPPER
2377* .. Executable Statements ..
2378 upper = uplo.EQ.'U'
2379 IF( type.EQ.'GE' )THEN
2380 DO 20 j = 1, n
2381 DO 10 i = m + 1, lda
2382 IF( aa( i, j ).NE.as( i, j ) )
2383 $ GO TO 70
2384 10 CONTINUE
2385 20 CONTINUE
2386 ELSE IF( type.EQ.'SY' )THEN
2387 DO 50 j = 1, n
2388 IF( upper )THEN
2389 ibeg = 1
2390 iend = j
2391 ELSE
2392 ibeg = j
2393 iend = n
2394 END IF
2395 DO 30 i = 1, ibeg - 1
2396 IF( aa( i, j ).NE.as( i, j ) )
2397 $ GO TO 70
2398 30 CONTINUE
2399 DO 40 i = iend + 1, lda
2400 IF( aa( i, j ).NE.as( i, j ) )
2401 $ GO TO 70
2402 40 CONTINUE
2403 50 CONTINUE
2404 END IF
2405*
2406 60 CONTINUE
2407 lseres = .true.
2408 GO TO 80
2409 70 CONTINUE
2410 lseres = .false.
2411 80 RETURN
2412*
2413* End of LSERES.
2414*
lseres
logical function lseres(type, uplo, m, n, aa, as, lda)
Definition c_sblat3.f:2355

◆ sbeg()

real function sbeg ( logical reset)

Definition at line 2416 of file c_sblat3.f.

2417*
2418* Generates random numbers uniformly distributed between -0.5 and 0.5.
2419*
2420* Auxiliary routine for test program for Level 3 Blas.
2421*
2422* -- Written on 8-February-1989.
2423* Jack Dongarra, Argonne National Laboratory.
2424* Iain Duff, AERE Harwell.
2425* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2426* Sven Hammarling, Numerical Algorithms Group Ltd.
2427*
2428* .. Scalar Arguments ..
2429 LOGICAL RESET
2430* .. Local Scalars ..
2431 INTEGER I, IC, MI
2432* .. Save statement ..
2433 SAVE i, ic, mi
2434* .. Executable Statements ..
2435 IF( reset )THEN
2436* Initialize local variables.
2437 mi = 891
2438 i = 7
2439 ic = 0
2440 reset = .false.
2441 END IF
2442*
2443* The sequence of values of I is bounded between 1 and 999.
2444* If initial I = 1,2,3,6,7 or 9, the period will be 50.
2445* If initial I = 4 or 8, the period will be 25.
2446* If initial I = 5, the period will be 10.
2447* IC is used to break up the period by skipping 1 value of I in 6.
2448*
2449 ic = ic + 1
2450 10 i = i*mi
2451 i = i - 1000*( i/1000 )
2452 IF( ic.GE.5 )THEN
2453 ic = 0
2454 GO TO 10
2455 END IF
2456 sbeg = ( i - 500 )/1001.0
2457 RETURN
2458*
2459* End of SBEG.
2460*
sbeg
real function sbeg(reset)
Definition c_sblat3.f:2417

◆ sblat3()

program sblat3

Definition at line 1 of file c_sblat3.f.

◆ schk1()

subroutine schk1 ( character*12 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,
integer iorder )

Definition at line 416 of file c_sblat3.f.

420*
421* Tests SGEMM.
422*
423* Auxiliary routine for test program for Level 3 Blas.
424*
425* -- Written on 8-February-1989.
426* Jack Dongarra, Argonne National Laboratory.
427* Iain Duff, AERE Harwell.
428* Jeremy Du Croz, Numerical Algorithms Group Ltd.
429* Sven Hammarling, Numerical Algorithms Group Ltd.
430*
431* .. Parameters ..
432 REAL ZERO
433 parameter( zero = 0.0 )
434* .. Scalar Arguments ..
435 REAL EPS, THRESH
436 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
437 LOGICAL FATAL, REWI, TRACE
438 CHARACTER*12 SNAME
439* .. Array Arguments ..
440 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
441 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
442 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
443 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
444 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
445 INTEGER IDIM( NIDIM )
446* .. Local Scalars ..
447 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
448 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
449 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
450 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
451 LOGICAL NULL, RESET, SAME, TRANA, TRANB
452 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
453 CHARACTER*3 ICH
454* .. Local Arrays ..
455 LOGICAL ISAME( 13 )
456* .. External Functions ..
457 LOGICAL LSE, LSERES
458 EXTERNAL lse, lseres
459* .. External Subroutines ..
460 EXTERNAL csgemm, smake, smmch
461* .. Intrinsic Functions ..
462 INTRINSIC max
463* .. Scalars in Common ..
464 INTEGER INFOT, NOUTC
465 LOGICAL OK
466* .. Common blocks ..
467 COMMON /infoc/infot, noutc, ok
468* .. Data statements ..
469 DATA ich/'NTC'/
470* .. Executable Statements ..
471*
472 nargs = 13
473 nc = 0
474 reset = .true.
475 errmax = zero
476*
477 DO 110 im = 1, nidim
478 m = idim( im )
479*
480 DO 100 in = 1, nidim
481 n = idim( in )
482* Set LDC to 1 more than minimum value if room.
483 ldc = m
484 IF( ldc.LT.nmax )
485 $ ldc = ldc + 1
486* Skip tests if not enough room.
487 IF( ldc.GT.nmax )
488 $ GO TO 100
489 lcc = ldc*n
490 null = n.LE.0.OR.m.LE.0
491*
492 DO 90 ik = 1, nidim
493 k = idim( ik )
494*
495 DO 80 ica = 1, 3
496 transa = ich( ica: ica )
497 trana = transa.EQ.'T'.OR.transa.EQ.'C'
498*
499 IF( trana )THEN
500 ma = k
501 na = m
502 ELSE
503 ma = m
504 na = k
505 END IF
506* Set LDA to 1 more than minimum value if room.
507 lda = ma
508 IF( lda.LT.nmax )
509 $ lda = lda + 1
510* Skip tests if not enough room.
511 IF( lda.GT.nmax )
512 $ GO TO 80
513 laa = lda*na
514*
515* Generate the matrix A.
516*
517 CALL smake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
518 $ reset, zero )
519*
520 DO 70 icb = 1, 3
521 transb = ich( icb: icb )
522 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
523*
524 IF( tranb )THEN
525 mb = n
526 nb = k
527 ELSE
528 mb = k
529 nb = n
530 END IF
531* Set LDB to 1 more than minimum value if room.
532 ldb = mb
533 IF( ldb.LT.nmax )
534 $ ldb = ldb + 1
535* Skip tests if not enough room.
536 IF( ldb.GT.nmax )
537 $ GO TO 70
538 lbb = ldb*nb
539*
540* Generate the matrix B.
541*
542 CALL smake( 'GE', ' ', ' ', mb, nb, b, nmax, bb,
543 $ ldb, reset, zero )
544*
545 DO 60 ia = 1, nalf
546 alpha = alf( ia )
547*
548 DO 50 ib = 1, nbet
549 beta = bet( ib )
550*
551* Generate the matrix C.
552*
553 CALL smake( 'GE', ' ', ' ', m, n, c, nmax,
554 $ cc, ldc, reset, zero )
555*
556 nc = nc + 1
557*
558* Save every datum before calling the
559* subroutine.
560*
561 tranas = transa
562 tranbs = transb
563 ms = m
564 ns = n
565 ks = k
566 als = alpha
567 DO 10 i = 1, laa
568 as( i ) = aa( i )
569 10 CONTINUE
570 ldas = lda
571 DO 20 i = 1, lbb
572 bs( i ) = bb( i )
573 20 CONTINUE
574 ldbs = ldb
575 bls = beta
576 DO 30 i = 1, lcc
577 cs( i ) = cc( i )
578 30 CONTINUE
579 ldcs = ldc
580*
581* Call the subroutine.
582*
583 IF( trace )
584 $ CALL sprcn1(ntra, nc, sname, iorder,
585 $ transa, transb, m, n, k, alpha, lda,
586 $ ldb, beta, ldc)
587 IF( rewi )
588 $ rewind ntra
589 CALL csgemm( iorder, transa, transb, m, n,
590 $ k, alpha, aa, lda, bb, ldb,
591 $ beta, cc, ldc )
592*
593* Check if error-exit was taken incorrectly.
594*
595 IF( .NOT.ok )THEN
596 WRITE( nout, fmt = 9994 )
597 fatal = .true.
598 GO TO 120
599 END IF
600*
601* See what data changed inside subroutines.
602*
603 isame( 1 ) = transa.EQ.tranas
604 isame( 2 ) = transb.EQ.tranbs
605 isame( 3 ) = ms.EQ.m
606 isame( 4 ) = ns.EQ.n
607 isame( 5 ) = ks.EQ.k
608 isame( 6 ) = als.EQ.alpha
609 isame( 7 ) = lse( as, aa, laa )
610 isame( 8 ) = ldas.EQ.lda
611 isame( 9 ) = lse( bs, bb, lbb )
612 isame( 10 ) = ldbs.EQ.ldb
613 isame( 11 ) = bls.EQ.beta
614 IF( null )THEN
615 isame( 12 ) = lse( cs, cc, lcc )
616 ELSE
617 isame( 12 ) = lseres( 'GE', ' ', m, n, cs,
618 $ cc, ldc )
619 END IF
620 isame( 13 ) = ldcs.EQ.ldc
621*
622* If data was incorrectly changed, report
623* and return.
624*
625 same = .true.
626 DO 40 i = 1, nargs
627 same = same.AND.isame( i )
628 IF( .NOT.isame( i ) )
629 $ WRITE( nout, fmt = 9998 )i+1
630 40 CONTINUE
631 IF( .NOT.same )THEN
632 fatal = .true.
633 GO TO 120
634 END IF
635*
636 IF( .NOT.null )THEN
637*
638* Check the result.
639*
640 CALL smmch( transa, transb, m, n, k,
641 $ alpha, a, nmax, b, nmax, beta,
642 $ c, nmax, ct, g, cc, ldc, eps,
643 $ err, fatal, nout, .true. )
644 errmax = max( errmax, err )
645* If got really bad answer, report and
646* return.
647 IF( fatal )
648 $ GO TO 120
649 END IF
650*
651 50 CONTINUE
652*
653 60 CONTINUE
654*
655 70 CONTINUE
656*
657 80 CONTINUE
658*
659 90 CONTINUE
660*
661 100 CONTINUE
662*
663 110 CONTINUE
664*
665* Report result.
666*
667 IF( errmax.LT.thresh )THEN
668 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
669 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
670 ELSE
671 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
672 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
673 END IF
674 GO TO 130
675*
676 120 CONTINUE
677 WRITE( nout, fmt = 9996 )sname
678 CALL sprcn1(nout, nc, sname, iorder, transa, transb,
679 $ m, n, k, alpha, lda, ldb, beta, ldc)
680*
681 130 CONTINUE
682 RETURN
683*
68410003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
685 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
686 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
68710002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
688 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
689 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
69010001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
691 $ ' (', i6, ' CALL', 'S)' )
69210000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
693 $ ' (', i6, ' CALL', 'S)' )
694 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
695 $ 'ANGED INCORRECTLY *******' )
696 9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
697 9995 FORMAT( 1x, i6, ': ', a12,'(''', a1, ''',''', a1, ''',',
698 $ 3( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', ',
699 $ 'C,', i3, ').' )
700 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
701 $ '******' )
702*
703* End of SCHK1.
704*
smake
subroutine smake(type, uplo, diag, m, n, a, nmax, aa, lda, reset, transl)
Definition c_sblat3.f:2089
smmch
subroutine smmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition c_sblat3.f:2203
sprcn1
subroutine sprcn1(nout, nc, sname, iorder, transa, transb, m, n, k, alpha, lda, ldb, beta, ldc)
Definition c_sblat3.f:711
alpha
#define alpha
Definition eval.h:35
max
#define max(a, b)
Definition macros.h:21
fatal
void fatal(char *msg)
Definition sys_pipes_c.c:76

◆ schk2()

subroutine schk2 ( character*12 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,
integer iorder )

Definition at line 744 of file c_sblat3.f.

748*
749* Tests SSYMM.
750*
751* Auxiliary routine for test program for Level 3 Blas.
752*
753* -- Written on 8-February-1989.
754* Jack Dongarra, Argonne National Laboratory.
755* Iain Duff, AERE Harwell.
756* Jeremy Du Croz, Numerical Algorithms Group Ltd.
757* Sven Hammarling, Numerical Algorithms Group Ltd.
758*
759* .. Parameters ..
760 REAL ZERO
761 parameter( zero = 0.0 )
762* .. Scalar Arguments ..
763 REAL EPS, THRESH
764 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
765 LOGICAL FATAL, REWI, TRACE
766 CHARACTER*12 SNAME
767* .. Array Arguments ..
768 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
769 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
770 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
771 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
772 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
773 INTEGER IDIM( NIDIM )
774* .. Local Scalars ..
775 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
776 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
777 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
778 $ NARGS, NC, NS
779 LOGICAL LEFT, NULL, RESET, SAME
780 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
781 CHARACTER*2 ICHS, ICHU
782* .. Local Arrays ..
783 LOGICAL ISAME( 13 )
784* .. External Functions ..
785 LOGICAL LSE, LSERES
786 EXTERNAL lse, lseres
787* .. External Subroutines ..
788 EXTERNAL smake, smmch, cssymm
789* .. Intrinsic Functions ..
790 INTRINSIC max
791* .. Scalars in Common ..
792 INTEGER INFOT, NOUTC
793 LOGICAL OK
794* .. Common blocks ..
795 COMMON /infoc/infot, noutc, ok
796* .. Data statements ..
797 DATA ichs/'LR'/, ichu/'UL'/
798* .. Executable Statements ..
799*
800 nargs = 12
801 nc = 0
802 reset = .true.
803 errmax = zero
804*
805 DO 100 im = 1, nidim
806 m = idim( im )
807*
808 DO 90 in = 1, nidim
809 n = idim( in )
810* Set LDC to 1 more than minimum value if room.
811 ldc = m
812 IF( ldc.LT.nmax )
813 $ ldc = ldc + 1
814* Skip tests if not enough room.
815 IF( ldc.GT.nmax )
816 $ GO TO 90
817 lcc = ldc*n
818 null = n.LE.0.OR.m.LE.0
819*
820* Set LDB to 1 more than minimum value if room.
821 ldb = m
822 IF( ldb.LT.nmax )
823 $ ldb = ldb + 1
824* Skip tests if not enough room.
825 IF( ldb.GT.nmax )
826 $ GO TO 90
827 lbb = ldb*n
828*
829* Generate the matrix B.
830*
831 CALL smake( 'GE', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
832 $ zero )
833*
834 DO 80 ics = 1, 2
835 side = ichs( ics: ics )
836 left = side.EQ.'L'
837*
838 IF( left )THEN
839 na = m
840 ELSE
841 na = n
842 END IF
843* Set LDA to 1 more than minimum value if room.
844 lda = na
845 IF( lda.LT.nmax )
846 $ lda = lda + 1
847* Skip tests if not enough room.
848 IF( lda.GT.nmax )
849 $ GO TO 80
850 laa = lda*na
851*
852 DO 70 icu = 1, 2
853 uplo = ichu( icu: icu )
854*
855* Generate the symmetric matrix A.
856*
857 CALL smake( 'SY', uplo, ' ', na, na, a, nmax, aa, lda,
858 $ reset, zero )
859*
860 DO 60 ia = 1, nalf
861 alpha = alf( ia )
862*
863 DO 50 ib = 1, nbet
864 beta = bet( ib )
865*
866* Generate the matrix C.
867*
868 CALL smake( 'GE', ' ', ' ', m, n, c, nmax, cc,
869 $ ldc, reset, zero )
870*
871 nc = nc + 1
872*
873* Save every datum before calling the
874* subroutine.
875*
876 sides = side
877 uplos = uplo
878 ms = m
879 ns = n
880 als = alpha
881 DO 10 i = 1, laa
882 as( i ) = aa( i )
883 10 CONTINUE
884 ldas = lda
885 DO 20 i = 1, lbb
886 bs( i ) = bb( i )
887 20 CONTINUE
888 ldbs = ldb
889 bls = beta
890 DO 30 i = 1, lcc
891 cs( i ) = cc( i )
892 30 CONTINUE
893 ldcs = ldc
894*
895* Call the subroutine.
896*
897 IF( trace )
898 $ CALL sprcn2(ntra, nc, sname, iorder,
899 $ side, uplo, m, n, alpha, lda, ldb,
900 $ beta, ldc)
901 IF( rewi )
902 $ rewind ntra
903 CALL cssymm( iorder, side, uplo, m, n, alpha,
904 $ aa, lda, bb, ldb, beta, cc, ldc )
905*
906* Check if error-exit was taken incorrectly.
907*
908 IF( .NOT.ok )THEN
909 WRITE( nout, fmt = 9994 )
910 fatal = .true.
911 GO TO 110
912 END IF
913*
914* See what data changed inside subroutines.
915*
916 isame( 1 ) = sides.EQ.side
917 isame( 2 ) = uplos.EQ.uplo
918 isame( 3 ) = ms.EQ.m
919 isame( 4 ) = ns.EQ.n
920 isame( 5 ) = als.EQ.alpha
921 isame( 6 ) = lse( as, aa, laa )
922 isame( 7 ) = ldas.EQ.lda
923 isame( 8 ) = lse( bs, bb, lbb )
924 isame( 9 ) = ldbs.EQ.ldb
925 isame( 10 ) = bls.EQ.beta
926 IF( null )THEN
927 isame( 11 ) = lse( cs, cc, lcc )
928 ELSE
929 isame( 11 ) = lseres( 'GE', ' ', m, n, cs,
930 $ cc, ldc )
931 END IF
932 isame( 12 ) = ldcs.EQ.ldc
933*
934* If data was incorrectly changed, report and
935* return.
936*
937 same = .true.
938 DO 40 i = 1, nargs
939 same = same.AND.isame( i )
940 IF( .NOT.isame( i ) )
941 $ WRITE( nout, fmt = 9998 )i+1
942 40 CONTINUE
943 IF( .NOT.same )THEN
944 fatal = .true.
945 GO TO 110
946 END IF
947*
948 IF( .NOT.null )THEN
949*
950* Check the result.
951*
952 IF( left )THEN
953 CALL smmch( 'N', 'N', m, n, m, alpha, a,
954 $ nmax, b, nmax, beta, c, nmax,
955 $ ct, g, cc, ldc, eps, err,
956 $ fatal, nout, .true. )
957 ELSE
958 CALL smmch( 'N', 'N', m, n, n, alpha, b,
959 $ nmax, a, nmax, beta, c, nmax,
960 $ ct, g, cc, ldc, eps, err,
961 $ fatal, nout, .true. )
962 END IF
963 errmax = max( errmax, err )
964* If got really bad answer, report and
965* return.
966 IF( fatal )
967 $ GO TO 110
968 END IF
969*
970 50 CONTINUE
971*
972 60 CONTINUE
973*
974 70 CONTINUE
975*
976 80 CONTINUE
977*
978 90 CONTINUE
979*
980 100 CONTINUE
981*
982* Report result.
983*
984 IF( errmax.LT.thresh )THEN
985 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
986 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
987 ELSE
988 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
989 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
990 END IF
991 GO TO 120
992*
993 110 CONTINUE
994 WRITE( nout, fmt = 9996 )sname
995 CALL sprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda,
996 $ ldb, beta, ldc)
997*
998 120 CONTINUE
999 RETURN
1000*
100110003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1002 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1003 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
100410002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1005 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1006 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
100710001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1008 $ ' (', i6, ' CALL', 'S)' )
100910000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1010 $ ' (', i6, ' CALL', 'S)' )
1011 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1012 $ 'ANGED INCORRECTLY *******' )
1013 9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
1014 9995 FORMAT( 1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1015 $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
1016 $ ' .' )
1017 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1018 $ '******' )
1019*
1020* End of SCHK2.
1021*
sprcn2
subroutine sprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda, ldb, beta, ldc)
Definition c_sblat3.f:1026

◆ schk3()

subroutine schk3 ( character*12 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 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 ) ct,
real, dimension( nmax ) g,
real, dimension( nmax, nmax ) c,
integer iorder )

Definition at line 1055 of file c_sblat3.f.

1058*
1059* Tests STRMM and STRSM.
1060*
1061* Auxiliary routine for test program for Level 3 Blas.
1062*
1063* -- Written on 8-February-1989.
1064* Jack Dongarra, Argonne National Laboratory.
1065* Iain Duff, AERE Harwell.
1066* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1067* Sven Hammarling, Numerical Algorithms Group Ltd.
1068*
1069* .. Parameters ..
1070 REAL ZERO, ONE
1071 parameter( zero = 0.0, one = 1.0 )
1072* .. Scalar Arguments ..
1073 REAL EPS, THRESH
1074 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
1075 LOGICAL FATAL, REWI, TRACE
1076 CHARACTER*12 SNAME
1077* .. Array Arguments ..
1078 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1079 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1080 $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
1081 $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
1082 INTEGER IDIM( NIDIM )
1083* .. Local Scalars ..
1084 REAL ALPHA, ALS, ERR, ERRMAX
1085 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
1086 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
1087 $ NS
1088 LOGICAL LEFT, NULL, RESET, SAME
1089 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
1090 $ UPLOS
1091 CHARACTER*2 ICHD, ICHS, ICHU
1092 CHARACTER*3 ICHT
1093* .. Local Arrays ..
1094 LOGICAL ISAME( 13 )
1095* .. External Functions ..
1096 LOGICAL LSE, LSERES
1097 EXTERNAL lse, lseres
1098* .. External Subroutines ..
1099 EXTERNAL smake, smmch, cstrmm, cstrsm
1100* .. Intrinsic Functions ..
1101 INTRINSIC max
1102* .. Scalars in Common ..
1103 INTEGER INFOT, NOUTC
1104 LOGICAL OK
1105* .. Common blocks ..
1106 COMMON /infoc/infot, noutc, ok
1107* .. Data statements ..
1108 DATA ichu/'ul'/, ICHT/'ntc'/, ICHD/'un'/, ICHS/'lr'/
1109* .. Executable Statements ..
1110*
1111 NARGS = 11
1112 NC = 0
1113 RESET = .TRUE.
1114 ERRMAX = ZERO
1115* Set up zero matrix for SMMCH.
1116 DO 20 J = 1, NMAX
1117 DO 10 I = 1, NMAX
1118 C( I, J ) = ZERO
1119 10 CONTINUE
1120 20 CONTINUE
1121*
1122 DO 140 IM = 1, NIDIM
1123 M = IDIM( IM )
1124*
1125 DO 130 IN = 1, NIDIM
1126 N = IDIM( IN )
1127* Set LDB to 1 more than minimum value if room.
1128 LDB = M
1129.LT. IF( LDBNMAX )
1130 $ LDB = LDB + 1
1131* Skip tests if not enough room.
1132.GT. IF( LDBNMAX )
1133 $ GO TO 130
1134 LBB = LDB*N
1135.LE..OR..LE. NULL = M0N0
1136*
1137 DO 120 ICS = 1, 2
1138 SIDE = ICHS( ICS: ICS )
1139.EQ. LEFT = SIDE'l'
1140 IF( LEFT )THEN
1141 NA = M
1142 ELSE
1143 NA = N
1144 END IF
1145* Set LDA to 1 more than minimum value if room.
1146 LDA = NA
1147.LT. IF( LDANMAX )
1148 $ LDA = LDA + 1
1149* Skip tests if not enough room.
1150.GT. IF( LDANMAX )
1151 $ GO TO 130
1152 LAA = LDA*NA
1153*
1154 DO 110 ICU = 1, 2
1155 UPLO = ICHU( ICU: ICU )
1156*
1157 DO 100 ICT = 1, 3
1158 TRANSA = ICHT( ICT: ICT )
1159*
1160 DO 90 ICD = 1, 2
1161 DIAG = ICHD( ICD: ICD )
1162*
1163 DO 80 IA = 1, NALF
1164 ALPHA = ALF( IA )
1165*
1166* Generate the matrix A.
1167*
1168 CALL SMAKE( 'tr', UPLO, DIAG, NA, NA, A,
1169 $ NMAX, AA, LDA, RESET, ZERO )
1170*
1171* Generate the matrix B.
1172*
1173 CALL SMAKE( 'ge', ' ', ' ', M, N, B, NMAX,
1174 $ BB, LDB, RESET, ZERO )
1175*
1176 NC = NC + 1
1177*
1178* Save every datum before calling the
1179* subroutine.
1180*
1181 SIDES = SIDE
1182 UPLOS = UPLO
1183 TRANAS = TRANSA
1184 DIAGS = DIAG
1185 MS = M
1186 NS = N
1187 ALS = ALPHA
1188 DO 30 I = 1, LAA
1189 AS( I ) = AA( I )
1190 30 CONTINUE
1191 LDAS = LDA
1192 DO 40 I = 1, LBB
1193 BS( I ) = BB( I )
1194 40 CONTINUE
1195 LDBS = LDB
1196*
1197* Call the subroutine.
1198*
1199.EQ. IF( SNAME( 10: 11 )'mm' )THEN
1200 IF( TRACE )
1201 $ CALL SPRCN3( NTRA, NC, SNAME, IORDER,
1202 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1203 $ LDA, LDB)
1204 IF( REWI )
1205 $ REWIND NTRA
1206 CALL CSTRMM( IORDER, SIDE, UPLO, TRANSA,
1207 $ DIAG, M, N, ALPHA, AA, LDA,
1208 $ BB, LDB )
1209.EQ. ELSE IF( SNAME( 10: 11 )'sm' )THEN
1210 IF( TRACE )
1211 $ CALL SPRCN3( NTRA, NC, SNAME, IORDER,
1212 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1213 $ LDA, LDB)
1214 IF( REWI )
1215 $ REWIND NTRA
1216 CALL CSTRSM( IORDER, SIDE, UPLO, TRANSA,
1217 $ DIAG, M, N, ALPHA, AA, LDA,
1218 $ BB, LDB )
1219 END IF
1220*
1221* Check if error-exit was taken incorrectly.
1222*
1223.NOT. IF( OK )THEN
1224 WRITE( NOUT, FMT = 9994 )
1225 FATAL = .TRUE.
1226 GO TO 150
1227 END IF
1228*
1229* See what data changed inside subroutines.
1230*
1231.EQ. ISAME( 1 ) = SIDESSIDE
1232.EQ. ISAME( 2 ) = UPLOSUPLO
1233.EQ. ISAME( 3 ) = TRANASTRANSA
1234.EQ. ISAME( 4 ) = DIAGSDIAG
1235.EQ. ISAME( 5 ) = MSM
1236.EQ. ISAME( 6 ) = NSN
1237.EQ. ISAME( 7 ) = ALSALPHA
1238 ISAME( 8 ) = LSE( AS, AA, LAA )
1239.EQ. ISAME( 9 ) = LDASLDA
1240 IF( NULL )THEN
1241 ISAME( 10 ) = LSE( BS, BB, LBB )
1242 ELSE
1243 ISAME( 10 ) = LSERES( 'ge', ' ', M, N, BS,
1244 $ BB, LDB )
1245 END IF
1246.EQ. ISAME( 11 ) = LDBSLDB
1247*
1248* If data was incorrectly changed, report and
1249* return.
1250*
1251 SAME = .TRUE.
1252 DO 50 I = 1, NARGS
1253.AND. SAME = SAMEISAME( I )
1254.NOT. IF( ISAME( I ) )
1255 $ WRITE( NOUT, FMT = 9998 )I+1
1256 50 CONTINUE
1257.NOT. IF( SAME )THEN
1258 FATAL = .TRUE.
1259 GO TO 150
1260 END IF
1261*
1262.NOT. IF( NULL )THEN
1263.EQ. IF( SNAME( 10: 11 )'mm' )THEN
1264*
1265* Check the result.
1266*
1267 IF( LEFT )THEN
1268 CALL SMMCH( TRANSA, 'n', M, N, M,
1269 $ ALPHA, A, NMAX, B, NMAX,
1270 $ ZERO, C, NMAX, CT, G,
1271 $ BB, LDB, EPS, ERR,
1272 $ FATAL, NOUT, .TRUE. )
1273 ELSE
1274 CALL SMMCH( 'n', TRANSA, M, N, N,
1275 $ ALPHA, B, NMAX, A, NMAX,
1276 $ ZERO, C, NMAX, CT, G,
1277 $ BB, LDB, EPS, ERR,
1278 $ FATAL, NOUT, .TRUE. )
1279 END IF
1280.EQ. ELSE IF( SNAME( 10: 11 )'sm' )THEN
1281*
1282* Compute approximation to original
1283* matrix.
1284*
1285 DO 70 J = 1, N
1286 DO 60 I = 1, M
1287 C( I, J ) = BB( I + ( J - 1 )*
1288 $ LDB )
1289 BB( I + ( J - 1 )*LDB ) = ALPHA*
1290 $ B( I, J )
1291 60 CONTINUE
1292 70 CONTINUE
1293*
1294 IF( LEFT )THEN
1295 CALL SMMCH( TRANSA, 'n', M, N, M,
1296 $ ONE, A, NMAX, C, NMAX,
1297 $ ZERO, B, NMAX, CT, G,
1298 $ BB, LDB, EPS, ERR,
1299 $ FATAL, NOUT, .FALSE. )
1300 ELSE
1301 CALL SMMCH( 'n', TRANSA, M, N, N,
1302 $ ONE, C, NMAX, A, NMAX,
1303 $ ZERO, B, NMAX, CT, G,
1304 $ BB, LDB, EPS, ERR,
1305 $ FATAL, NOUT, .FALSE. )
1306 END IF
1307 END IF
1308 ERRMAX = MAX( ERRMAX, ERR )
1309* If got really bad answer, report and
1310* return.
1311 IF( FATAL )
1312 $ GO TO 150
1313 END IF
1314*
1315 80 CONTINUE
1316*
1317 90 CONTINUE
1318*
1319 100 CONTINUE
1320*
1321 110 CONTINUE
1322*
1323 120 CONTINUE
1324*
1325 130 CONTINUE
1326*
1327 140 CONTINUE
1328*
1329* Report result.
1330*
1331.LT. IF( ERRMAXTHRESH )THEN
1332.EQ. IF ( IORDER0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1333.EQ. IF ( IORDER1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1334 ELSE
1335.EQ. IF ( IORDER0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1336.EQ. IF ( IORDER1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1337 END IF
1338 GO TO 160
1339*
1340 150 CONTINUE
1341 WRITE( NOUT, FMT = 9996 )SNAME
1342 IF( TRACE )
1343 $ CALL SPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG,
1344 $ M, N, ALPHA, LDA, LDB)
1345*
1346 160 CONTINUE
1347 RETURN
1348*
134910003 FORMAT( ' ', A12,' completed the row-major computational ',
1350 $ 'tests(', I6, ' calls)', /' ******* but with maximum test ',
1351 $ 'ratio ', F8.2, ' - suspect *******' )
135210002 FORMAT( ' ', A12,' completed the column-major computational ',
1353 $ 'tests(', I6, ' calls)', /' ******* but with maximum test ',
1354 $ 'ratio ', F8.2, ' - suspect *******' )
135510001 FORMAT( ' ', A12,' passed the row-major computational tests',
1356 $ ' (', I6, ' call', 's)' )
135710000 FORMAT( ' ', A12,' passed the column-major computational tests',
1358 $ ' (', I6, ' call', 's)' )
1359 9998 FORMAT( ' ******* fatal error - PARAMETER number ', I2, ' was ch',
1360 $ 'anged incorrectly *******' )
1361 9996 FORMAT( ' ******* ', A12,' failed on CALL number:' )
1362 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1363 $ f4.1, ', A,', i3, ', B,', i3, ') .' )
1364 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1365 $ '******' )
1366*
1367* End of SCHK3.
1368*
the
end diagonal values have been computed in the(sparse) matrix id.SOL

◆ schk4()

subroutine schk4 ( character*12 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,
integer iorder )

Definition at line 1414 of file c_sblat3.f.

1418*
1419* Tests SSYRK.
1420*
1421* Auxiliary routine for test program for Level 3 Blas.
1422*
1423* -- Written on 8-February-1989.
1424* Jack Dongarra, Argonne National Laboratory.
1425* Iain Duff, AERE Harwell.
1426* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1427* Sven Hammarling, Numerical Algorithms Group Ltd.
1428*
1429* .. Parameters ..
1430 REAL ZERO
1431 parameter( zero = 0.0 )
1432* .. Scalar Arguments ..
1433 REAL EPS, THRESH
1434 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1435 LOGICAL FATAL, REWI, TRACE
1436 CHARACTER*12 SNAME
1437* .. Array Arguments ..
1438 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1439 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1440 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1441 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1442 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
1443 INTEGER IDIM( NIDIM )
1444* .. Local Scalars ..
1445 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1446 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1447 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1448 $ NARGS, NC, NS
1449 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1450 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1451 CHARACTER*2 ICHU
1452 CHARACTER*3 ICHT
1453* .. Local Arrays ..
1454 LOGICAL ISAME( 13 )
1455* .. External Functions ..
1456 LOGICAL LSE, LSERES
1457 EXTERNAL lse, lseres
1458* .. External Subroutines ..
1459 EXTERNAL smake, smmch, cssyrk
1460* .. Intrinsic Functions ..
1461 INTRINSIC max
1462* .. Scalars in Common ..
1463 INTEGER INFOT, NOUTC
1464 LOGICAL OK
1465* .. Common blocks ..
1466 COMMON /infoc/infot, noutc, ok
1467* .. Data statements ..
1468 DATA icht/'NTC'/, ichu/'UL'/
1469* .. Executable Statements ..
1470*
1471 nargs = 10
1472 nc = 0
1473 reset = .true.
1474 errmax = zero
1475*
1476 DO 100 in = 1, nidim
1477 n = idim( in )
1478* Set LDC to 1 more than minimum value if room.
1479 ldc = n
1480 IF( ldc.LT.nmax )
1481 $ ldc = ldc + 1
1482* Skip tests if not enough room.
1483 IF( ldc.GT.nmax )
1484 $ GO TO 100
1485 lcc = ldc*n
1486 null = n.LE.0
1487*
1488 DO 90 ik = 1, nidim
1489 k = idim( ik )
1490*
1491 DO 80 ict = 1, 3
1492 trans = icht( ict: ict )
1493 tran = trans.EQ.'T'.OR.trans.EQ.'C'
1494 IF( tran )THEN
1495 ma = k
1496 na = n
1497 ELSE
1498 ma = n
1499 na = k
1500 END IF
1501* Set LDA to 1 more than minimum value if room.
1502 lda = ma
1503 IF( lda.LT.nmax )
1504 $ lda = lda + 1
1505* Skip tests if not enough room.
1506 IF( lda.GT.nmax )
1507 $ GO TO 80
1508 laa = lda*na
1509*
1510* Generate the matrix A.
1511*
1512 CALL smake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
1513 $ reset, zero )
1514*
1515 DO 70 icu = 1, 2
1516 uplo = ichu( icu: icu )
1517 upper = uplo.EQ.'U'
1518*
1519 DO 60 ia = 1, nalf
1520 alpha = alf( ia )
1521*
1522 DO 50 ib = 1, nbet
1523 beta = bet( ib )
1524*
1525* Generate the matrix C.
1526*
1527 CALL smake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1528 $ ldc, reset, zero )
1529*
1530 nc = nc + 1
1531*
1532* Save every datum before calling the subroutine.
1533*
1534 uplos = uplo
1535 transs = trans
1536 ns = n
1537 ks = k
1538 als = alpha
1539 DO 10 i = 1, laa
1540 as( i ) = aa( i )
1541 10 CONTINUE
1542 ldas = lda
1543 bets = beta
1544 DO 20 i = 1, lcc
1545 cs( i ) = cc( i )
1546 20 CONTINUE
1547 ldcs = ldc
1548*
1549* Call the subroutine.
1550*
1551 IF( trace )
1552 $ CALL sprcn4( ntra, nc, sname, iorder, uplo,
1553 $ trans, n, k, alpha, lda, beta, ldc)
1554 IF( rewi )
1555 $ rewind ntra
1556 CALL cssyrk( iorder, uplo, trans, n, k, alpha,
1557 $ aa, lda, beta, cc, ldc )
1558*
1559* Check if error-exit was taken incorrectly.
1560*
1561 IF( .NOT.ok )THEN
1562 WRITE( nout, fmt = 9993 )
1563 fatal = .true.
1564 GO TO 120
1565 END IF
1566*
1567* See what data changed inside subroutines.
1568*
1569 isame( 1 ) = uplos.EQ.uplo
1570 isame( 2 ) = transs.EQ.trans
1571 isame( 3 ) = ns.EQ.n
1572 isame( 4 ) = ks.EQ.k
1573 isame( 5 ) = als.EQ.alpha
1574 isame( 6 ) = lse( as, aa, laa )
1575 isame( 7 ) = ldas.EQ.lda
1576 isame( 8 ) = bets.EQ.beta
1577 IF( null )THEN
1578 isame( 9 ) = lse( cs, cc, lcc )
1579 ELSE
1580 isame( 9 ) = lseres( 'SY', uplo, n, n, cs,
1581 $ cc, ldc )
1582 END IF
1583 isame( 10 ) = ldcs.EQ.ldc
1584*
1585* If data was incorrectly changed, report and
1586* return.
1587*
1588 same = .true.
1589 DO 30 i = 1, nargs
1590 same = same.AND.isame( i )
1591 IF( .NOT.isame( i ) )
1592 $ WRITE( nout, fmt = 9998 )i+1
1593 30 CONTINUE
1594 IF( .NOT.same )THEN
1595 fatal = .true.
1596 GO TO 120
1597 END IF
1598*
1599 IF( .NOT.null )THEN
1600*
1601* Check the result column by column.
1602*
1603 jc = 1
1604 DO 40 j = 1, n
1605 IF( upper )THEN
1606 jj = 1
1607 lj = j
1608 ELSE
1609 jj = j
1610 lj = n - j + 1
1611 END IF
1612 IF( tran )THEN
1613 CALL smmch( 'T', 'N', lj, 1, k, alpha,
1614 $ a( 1, jj ), nmax,
1615 $ a( 1, j ), nmax, beta,
1616 $ c( jj, j ), nmax, ct, g,
1617 $ cc( jc ), ldc, eps, err,
1618 $ fatal, nout, .true. )
1619 ELSE
1620 CALL smmch( 'N', 'T', lj, 1, k, alpha,
1621 $ a( jj, 1 ), nmax,
1622 $ a( j, 1 ), nmax, beta,
1623 $ c( jj, j ), nmax, ct, g,
1624 $ cc( jc ), ldc, eps, err,
1625 $ fatal, nout, .true. )
1626 END IF
1627 IF( upper )THEN
1628 jc = jc + ldc
1629 ELSE
1630 jc = jc + ldc + 1
1631 END IF
1632 errmax = max( errmax, err )
1633* If got really bad answer, report and
1634* return.
1635 IF( fatal )
1636 $ GO TO 110
1637 40 CONTINUE
1638 END IF
1639*
1640 50 CONTINUE
1641*
1642 60 CONTINUE
1643*
1644 70 CONTINUE
1645*
1646 80 CONTINUE
1647*
1648 90 CONTINUE
1649*
1650 100 CONTINUE
1651*
1652* Report result.
1653*
1654 IF( errmax.LT.thresh )THEN
1655 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1656 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1657 ELSE
1658 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1659 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1660 END IF
1661 GO TO 130
1662*
1663 110 CONTINUE
1664 IF( n.GT.1 )
1665 $ WRITE( nout, fmt = 9995 )j
1666*
1667 120 CONTINUE
1668 WRITE( nout, fmt = 9996 )sname
1669 CALL sprcn4( nout, nc, sname, iorder, uplo, trans, n, k, alpha,
1670 $ lda, beta, ldc)
1671*
1672 130 CONTINUE
1673 RETURN
1674*
167510003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1676 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1677 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
167810002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1679 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1680 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
168110001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1682 $ ' (', i6, ' CALL', 'S)' )
168310000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1684 $ ' (', i6, ' CALL', 'S)' )
1685 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1686 $ 'ANGED INCORRECTLY *******' )
1687 9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
1688 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1689 9994 FORMAT( 1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1690 $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ') .' )
1691 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1692 $ '******' )
1693*
1694* End of SCHK4.
1695*
sprcn4
subroutine sprcn4(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
Definition c_sblat3.f:1700
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ schk5()

subroutine schk5 ( character*12 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( 2*nmax*nmax ) ab,
real, dimension( nmax*nmax ) aa,
real, dimension( nmax*nmax ) as,
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,
real, dimension( 2*nmax ) w,
integer iorder )

Definition at line 1731 of file c_sblat3.f.

1735*
1736* Tests SSYR2K.
1737*
1738* Auxiliary routine for test program for Level 3 Blas.
1739*
1740* -- Written on 8-February-1989.
1741* Jack Dongarra, Argonne National Laboratory.
1742* Iain Duff, AERE Harwell.
1743* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1744* Sven Hammarling, Numerical Algorithms Group Ltd.
1745*
1746* .. Parameters ..
1747 REAL ZERO
1748 parameter( zero = 0.0 )
1749* .. Scalar Arguments ..
1750 REAL EPS, THRESH
1751 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1752 LOGICAL FATAL, REWI, TRACE
1753 CHARACTER*12 SNAME
1754* .. Array Arguments ..
1755 REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1756 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1757 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1758 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1759 $ G( NMAX ), W( 2*NMAX )
1760 INTEGER IDIM( NIDIM )
1761* .. Local Scalars ..
1762 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1763 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1764 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1765 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1766 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1767 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1768 CHARACTER*2 ICHU
1769 CHARACTER*3 ICHT
1770* .. Local Arrays ..
1771 LOGICAL ISAME( 13 )
1772* .. External Functions ..
1773 LOGICAL LSE, LSERES
1774 EXTERNAL lse, lseres
1775* .. External Subroutines ..
1776 EXTERNAL smake, smmch, cssyr2k
1777* .. Intrinsic Functions ..
1778 INTRINSIC max
1779* .. Scalars in Common ..
1780 INTEGER INFOT, NOUTC
1781 LOGICAL OK
1782* .. Common blocks ..
1783 COMMON /infoc/infot, noutc, ok
1784* .. Data statements ..
1785 DATA icht/'NTC'/, ichu/'UL'/
1786* .. Executable Statements ..
1787*
1788 nargs = 12
1789 nc = 0
1790 reset = .true.
1791 errmax = zero
1792*
1793 DO 130 in = 1, nidim
1794 n = idim( in )
1795* Set LDC to 1 more than minimum value if room.
1796 ldc = n
1797 IF( ldc.LT.nmax )
1798 $ ldc = ldc + 1
1799* Skip tests if not enough room.
1800 IF( ldc.GT.nmax )
1801 $ GO TO 130
1802 lcc = ldc*n
1803 null = n.LE.0
1804*
1805 DO 120 ik = 1, nidim
1806 k = idim( ik )
1807*
1808 DO 110 ict = 1, 3
1809 trans = icht( ict: ict )
1810 tran = trans.EQ.'T'.OR.trans.EQ.'C'
1811 IF( tran )THEN
1812 ma = k
1813 na = n
1814 ELSE
1815 ma = n
1816 na = k
1817 END IF
1818* Set LDA to 1 more than minimum value if room.
1819 lda = ma
1820 IF( lda.LT.nmax )
1821 $ lda = lda + 1
1822* Skip tests if not enough room.
1823 IF( lda.GT.nmax )
1824 $ GO TO 110
1825 laa = lda*na
1826*
1827* Generate the matrix A.
1828*
1829 IF( tran )THEN
1830 CALL smake( 'GE', ' ', ' ', ma, na, ab, 2*nmax, aa,
1831 $ lda, reset, zero )
1832 ELSE
1833 CALL smake( 'GE', ' ', ' ', ma, na, ab, nmax, aa, lda,
1834 $ reset, zero )
1835 END IF
1836*
1837* Generate the matrix B.
1838*
1839 ldb = lda
1840 lbb = laa
1841 IF( tran )THEN
1842 CALL smake( 'GE', ' ', ' ', ma, na, ab( k + 1 ),
1843 $ 2*nmax, bb, ldb, reset, zero )
1844 ELSE
1845 CALL smake( 'GE', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1846 $ nmax, bb, ldb, reset, zero )
1847 END IF
1848*
1849 DO 100 icu = 1, 2
1850 uplo = ichu( icu: icu )
1851 upper = uplo.EQ.'U'
1852*
1853 DO 90 ia = 1, nalf
1854 alpha = alf( ia )
1855*
1856 DO 80 ib = 1, nbet
1857 beta = bet( ib )
1858*
1859* Generate the matrix C.
1860*
1861 CALL smake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1862 $ ldc, reset, zero )
1863*
1864 nc = nc + 1
1865*
1866* Save every datum before calling the subroutine.
1867*
1868 uplos = uplo
1869 transs = trans
1870 ns = n
1871 ks = k
1872 als = alpha
1873 DO 10 i = 1, laa
1874 as( i ) = aa( i )
1875 10 CONTINUE
1876 ldas = lda
1877 DO 20 i = 1, lbb
1878 bs( i ) = bb( i )
1879 20 CONTINUE
1880 ldbs = ldb
1881 bets = beta
1882 DO 30 i = 1, lcc
1883 cs( i ) = cc( i )
1884 30 CONTINUE
1885 ldcs = ldc
1886*
1887* Call the subroutine.
1888*
1889 IF( trace )
1890 $ CALL sprcn5( ntra, nc, sname, iorder, uplo,
1891 $ trans, n, k, alpha, lda, ldb, beta, ldc)
1892 IF( rewi )
1893 $ rewind ntra
1894 CALL cssyr2k( iorder, uplo, trans, n, k, alpha,
1895 $ aa, lda, bb, ldb, beta, cc, ldc )
1896*
1897* Check if error-exit was taken incorrectly.
1898*
1899 IF( .NOT.ok )THEN
1900 WRITE( nout, fmt = 9993 )
1901 fatal = .true.
1902 GO TO 150
1903 END IF
1904*
1905* See what data changed inside subroutines.
1906*
1907 isame( 1 ) = uplos.EQ.uplo
1908 isame( 2 ) = transs.EQ.trans
1909 isame( 3 ) = ns.EQ.n
1910 isame( 4 ) = ks.EQ.k
1911 isame( 5 ) = als.EQ.alpha
1912 isame( 6 ) = lse( as, aa, laa )
1913 isame( 7 ) = ldas.EQ.lda
1914 isame( 8 ) = lse( bs, bb, lbb )
1915 isame( 9 ) = ldbs.EQ.ldb
1916 isame( 10 ) = bets.EQ.beta
1917 IF( null )THEN
1918 isame( 11 ) = lse( cs, cc, lcc )
1919 ELSE
1920 isame( 11 ) = lseres( 'SY', uplo, n, n, cs,
1921 $ cc, ldc )
1922 END IF
1923 isame( 12 ) = ldcs.EQ.ldc
1924*
1925* If data was incorrectly changed, report and
1926* return.
1927*
1928 same = .true.
1929 DO 40 i = 1, nargs
1930 same = same.AND.isame( i )
1931 IF( .NOT.isame( i ) )
1932 $ WRITE( nout, fmt = 9998 )i+1
1933 40 CONTINUE
1934 IF( .NOT.same )THEN
1935 fatal = .true.
1936 GO TO 150
1937 END IF
1938*
1939 IF( .NOT.null )THEN
1940*
1941* Check the result column by column.
1942*
1943 jjab = 1
1944 jc = 1
1945 DO 70 j = 1, n
1946 IF( upper )THEN
1947 jj = 1
1948 lj = j
1949 ELSE
1950 jj = j
1951 lj = n - j + 1
1952 END IF
1953 IF( tran )THEN
1954 DO 50 i = 1, k
1955 w( i ) = ab( ( j - 1 )*2*nmax + k +
1956 $ i )
1957 w( k + i ) = ab( ( j - 1 )*2*nmax +
1958 $ i )
1959 50 CONTINUE
1960 CALL smmch( 'T', 'N', lj, 1, 2*k,
1961 $ alpha, ab( jjab ), 2*nmax,
1962 $ w, 2*nmax, beta,
1963 $ c( jj, j ), nmax, ct, g,
1964 $ cc( jc ), ldc, eps, err,
1965 $ fatal, nout, .true. )
1966 ELSE
1967 DO 60 i = 1, k
1968 w( i ) = ab( ( k + i - 1 )*nmax +
1969 $ j )
1970 w( k + i ) = ab( ( i - 1 )*nmax +
1971 $ j )
1972 60 CONTINUE
1973 CALL smmch( 'N', 'N', lj, 1, 2*k,
1974 $ alpha, ab( jj ), nmax, w,
1975 $ 2*nmax, beta, c( jj, j ),
1976 $ nmax, ct, g, cc( jc ), ldc,
1977 $ eps, err, fatal, nout,
1978 $ .true. )
1979 END IF
1980 IF( upper )THEN
1981 jc = jc + ldc
1982 ELSE
1983 jc = jc + ldc + 1
1984 IF( tran )
1985 $ jjab = jjab + 2*nmax
1986 END IF
1987 errmax = max( errmax, err )
1988* If got really bad answer, report and
1989* return.
1990 IF( fatal )
1991 $ GO TO 140
1992 70 CONTINUE
1993 END IF
1994*
1995 80 CONTINUE
1996*
1997 90 CONTINUE
1998*
1999 100 CONTINUE
2000*
2001 110 CONTINUE
2002*
2003 120 CONTINUE
2004*
2005 130 CONTINUE
2006*
2007* Report result.
2008*
2009 IF( errmax.LT.thresh )THEN
2010 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2011 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2012 ELSE
2013 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2014 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2015 END IF
2016 GO TO 160
2017*
2018 140 CONTINUE
2019 IF( n.GT.1 )
2020 $ WRITE( nout, fmt = 9995 )j
2021*
2022 150 CONTINUE
2023 WRITE( nout, fmt = 9996 )sname
2024 CALL sprcn5( nout, nc, sname, iorder, uplo, trans, n, k, alpha,
2025 $ lda, ldb, beta, ldc)
2026*
2027 160 CONTINUE
2028 RETURN
2029*
203010003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2031 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2032 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
203310002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2034 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2035 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
203610001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2037 $ ' (', i6, ' CALL', 'S)' )
203810000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2039 $ ' (', i6, ' CALL', 'S)' )
2040 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2041 $ 'ANGED INCORRECTLY *******' )
2042 9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
2043 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2044 9994 FORMAT( 1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2045 $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
2046 $ ' .' )
2047 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2048 $ '******' )
2049*
2050* End of SCHK5.
2051*
sprcn5
subroutine sprcn5(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_sblat3.f:2056

◆ sdiff()

real function sdiff ( real x,
real y )

Definition at line 2462 of file c_sblat3.f.

2463*
2464* Auxiliary routine for test program for Level 3 Blas.
2465*
2466* -- Written on 8-February-1989.
2467* Jack Dongarra, Argonne National Laboratory.
2468* Iain Duff, AERE Harwell.
2469* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2470* Sven Hammarling, Numerical Algorithms Group Ltd.
2471*
2472* .. Scalar Arguments ..
2473 REAL X, Y
2474* .. Executable Statements ..
2475 sdiff = x - y
2476 RETURN
2477*
2478* End of SDIFF.
2479*
sdiff
real function sdiff(x, y)
Definition c_sblat3.f:2463

◆ smake()

subroutine smake ( character*2 type,
character*1 uplo,
character*1 diag,
integer m,
integer n,
real, dimension( nmax, * ) a,
integer nmax,
real, dimension( * ) aa,
integer lda,
logical reset,
real transl )

Definition at line 2087 of file c_sblat3.f.

2089*
2090* Generates values for an M by N matrix A.
2091* Stores the values in the array AA in the data structure required
2092* by the routine, with unwanted elements set to rogue value.
2093*
2094* TYPE is 'GE', 'SY' or 'TR'.
2095*
2096* Auxiliary routine for test program for Level 3 Blas.
2097*
2098* -- Written on 8-February-1989.
2099* Jack Dongarra, Argonne National Laboratory.
2100* Iain Duff, AERE Harwell.
2101* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2102* Sven Hammarling, Numerical Algorithms Group Ltd.
2103*
2104* .. Parameters ..
2105 REAL ZERO, ONE
2106 parameter( zero = 0.0, one = 1.0 )
2107 REAL ROGUE
2108 parameter( rogue = -1.0e10 )
2109* .. Scalar Arguments ..
2110 REAL TRANSL
2111 INTEGER LDA, M, N, NMAX
2112 LOGICAL RESET
2113 CHARACTER*1 DIAG, UPLO
2114 CHARACTER*2 TYPE
2115* .. Array Arguments ..
2116 REAL A( NMAX, * ), AA( * )
2117* .. Local Scalars ..
2118 INTEGER I, IBEG, IEND, J
2119 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2120* .. External Functions ..
2121 REAL SBEG
2122 EXTERNAL sbeg
2123* .. Executable Statements ..
2124 gen = type.EQ.'GE'
2125 sym = type.EQ.'SY'
2126 tri = type.EQ.'TR'
2127 upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
2128 lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
2129 unit = tri.AND.diag.EQ.'U'
2130*
2131* Generate data in array A.
2132*
2133 DO 20 j = 1, n
2134 DO 10 i = 1, m
2135 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2136 $ THEN
2137 a( i, j ) = sbeg( reset ) + transl
2138 IF( i.NE.j )THEN
2139* Set some elements to zero
2140 IF( n.GT.3.AND.j.EQ.n/2 )
2141 $ a( i, j ) = zero
2142 IF( sym )THEN
2143 a( j, i ) = a( i, j )
2144 ELSE IF( tri )THEN
2145 a( j, i ) = zero
2146 END IF
2147 END IF
2148 END IF
2149 10 CONTINUE
2150 IF( tri )
2151 $ a( j, j ) = a( j, j ) + one
2152 IF( unit )
2153 $ a( j, j ) = one
2154 20 CONTINUE
2155*
2156* Store elements in array AS in data structure required by routine.
2157*
2158 IF( type.EQ.'GE' )THEN
2159 DO 50 j = 1, n
2160 DO 30 i = 1, m
2161 aa( i + ( j - 1 )*lda ) = a( i, j )
2162 30 CONTINUE
2163 DO 40 i = m + 1, lda
2164 aa( i + ( j - 1 )*lda ) = rogue
2165 40 CONTINUE
2166 50 CONTINUE
2167 ELSE IF( type.EQ.'SY'.OR.type.EQ.'TR' )THEN
2168 DO 90 j = 1, n
2169 IF( upper )THEN
2170 ibeg = 1
2171 IF( unit )THEN
2172 iend = j - 1
2173 ELSE
2174 iend = j
2175 END IF
2176 ELSE
2177 IF( unit )THEN
2178 ibeg = j + 1
2179 ELSE
2180 ibeg = j
2181 END IF
2182 iend = n
2183 END IF
2184 DO 60 i = 1, ibeg - 1
2185 aa( i + ( j - 1 )*lda ) = rogue
2186 60 CONTINUE
2187 DO 70 i = ibeg, iend
2188 aa( i + ( j - 1 )*lda ) = a( i, j )
2189 70 CONTINUE
2190 DO 80 i = iend + 1, lda
2191 aa( i + ( j - 1 )*lda ) = rogue
2192 80 CONTINUE
2193 90 CONTINUE
2194 END IF
2195 RETURN
2196*
2197* End of SMAKE.
2198*

◆ smmch()

subroutine smmch ( character*1 transa,
character*1 transb,
integer m,
integer n,
integer kk,
real alpha,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldb, * ) b,
integer ldb,
real beta,
real, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) ct,
real, dimension( * ) g,
real, dimension( ldcc, * ) cc,
integer ldcc,
real eps,
real err,
logical fatal,
integer nout,
logical mv )

Definition at line 2200 of file c_sblat3.f.

2203*
2204* Checks the results of the computational tests.
2205*
2206* Auxiliary routine for test program for Level 3 Blas.
2207*
2208* -- Written on 8-February-1989.
2209* Jack Dongarra, Argonne National Laboratory.
2210* Iain Duff, AERE Harwell.
2211* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2212* Sven Hammarling, Numerical Algorithms Group Ltd.
2213*
2214* .. Parameters ..
2215 REAL ZERO, ONE
2216 parameter( zero = 0.0, one = 1.0 )
2217* .. Scalar Arguments ..
2218 REAL ALPHA, BETA, EPS, ERR
2219 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2220 LOGICAL FATAL, MV
2221 CHARACTER*1 TRANSA, TRANSB
2222* .. Array Arguments ..
2223 REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
2224 $ CC( LDCC, * ), CT( * ), G( * )
2225* .. Local Scalars ..
2226 REAL ERRI
2227 INTEGER I, J, K
2228 LOGICAL TRANA, TRANB
2229* .. Intrinsic Functions ..
2230 INTRINSIC abs, max, sqrt
2231* .. Executable Statements ..
2232 trana = transa.EQ.'T'.OR.transa.EQ.'C'
2233 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2234*
2235* Compute expected result, one column at a time, in CT using data
2236* in A, B and C.
2237* Compute gauges in G.
2238*
2239 DO 120 j = 1, n
2240*
2241 DO 10 i = 1, m
2242 ct( i ) = zero
2243 g( i ) = zero
2244 10 CONTINUE
2245 IF( .NOT.trana.AND..NOT.tranb )THEN
2246 DO 30 k = 1, kk
2247 DO 20 i = 1, m
2248 ct( i ) = ct( i ) + a( i, k )*b( k, j )
2249 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( k, j ) )
2250 20 CONTINUE
2251 30 CONTINUE
2252 ELSE IF( trana.AND..NOT.tranb )THEN
2253 DO 50 k = 1, kk
2254 DO 40 i = 1, m
2255 ct( i ) = ct( i ) + a( k, i )*b( k, j )
2256 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( k, j ) )
2257 40 CONTINUE
2258 50 CONTINUE
2259 ELSE IF( .NOT.trana.AND.tranb )THEN
2260 DO 70 k = 1, kk
2261 DO 60 i = 1, m
2262 ct( i ) = ct( i ) + a( i, k )*b( j, k )
2263 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( j, k ) )
2264 60 CONTINUE
2265 70 CONTINUE
2266 ELSE IF( trana.AND.tranb )THEN
2267 DO 90 k = 1, kk
2268 DO 80 i = 1, m
2269 ct( i ) = ct( i ) + a( k, i )*b( j, k )
2270 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( j, k ) )
2271 80 CONTINUE
2272 90 CONTINUE
2273 END IF
2274 DO 100 i = 1, m
2275 ct( i ) = alpha*ct( i ) + beta*c( i, j )
2276 g( i ) = abs( alpha )*g( i ) + abs( beta )*abs( c( i, j ) )
2277 100 CONTINUE
2278*
2279* Compute the error ratio for this result.
2280*
2281 err = zero
2282 DO 110 i = 1, m
2283 erri = abs( ct( i ) - cc( i, j ) )/eps
2284 IF( g( i ).NE.zero )
2285 $ erri = erri/g( i )
2286 err = max( err, erri )
2287 IF( err*sqrt( eps ).GE.one )
2288 $ GO TO 130
2289 110 CONTINUE
2290*
2291 120 CONTINUE
2292*
2293* If the loop completes, all results are at least half accurate.
2294 GO TO 150
2295*
2296* Report fatal error.
2297*
2298 130 fatal = .true.
2299 WRITE( nout, fmt = 9999 )
2300 DO 140 i = 1, m
2301 IF( mv )THEN
2302 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
2303 ELSE
2304 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
2305 END IF
2306 140 CONTINUE
2307 IF( n.GT.1 )
2308 $ WRITE( nout, fmt = 9997 )j
2309*
2310 150 CONTINUE
2311 RETURN
2312*
2313 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2314 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2315 $ 'TED RESULT' )
2316 9998 FORMAT( 1x, i7, 2g18.6 )
2317 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2318*
2319* End of SMMCH.
2320*

◆ sprcn1()

subroutine sprcn1 ( integer nout,
integer nc,
character*12 sname,
integer iorder,
character*1 transa,
character*1 transb,
integer m,
integer n,
integer k,
real alpha,
integer lda,
integer ldb,
real beta,
integer ldc )

Definition at line 709 of file c_sblat3.f.

711 INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
712 REAL ALPHA, BETA
713 CHARACTER*1 TRANSA, TRANSB
714 CHARACTER*12 SNAME
715 CHARACTER*14 CRC, CTA,CTB
716
717 IF (transa.EQ.'N')THEN
718 cta = ' CblasNoTrans'
719 ELSE IF (transa.EQ.'T')THEN
720 cta = ' CblasTrans'
721 ELSE
722 cta = 'CblasConjTrans'
723 END IF
724 IF (transb.EQ.'N')THEN
725 ctb = ' CblasNoTrans'
726 ELSE IF (transb.EQ.'T')THEN
727 ctb = ' CblasTrans'
728 ELSE
729 ctb = 'CblasConjTrans'
730 END IF
731 IF (iorder.EQ.1)THEN
732 crc = ' CblasRowMajor'
733 ELSE
734 crc = ' CblasColMajor'
735 END IF
736 WRITE(nout, fmt = 9995)nc,sname,crc, cta,ctb
737 WRITE(nout, fmt = 9994)m, n, k, alpha, lda, ldb, beta, ldc
738
739 9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
740 9994 FORMAT( 20x, 3( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',',
741 $ f4.1, ', ', 'C,', i3, ').' )

◆ sprcn2()

subroutine sprcn2 ( integer nout,
integer nc,
character*12 sname,
integer iorder,
character*1 side,
character*1 uplo,
integer m,
integer n,
real alpha,
integer lda,
integer ldb,
real beta,
integer ldc )

Definition at line 1024 of file c_sblat3.f.

1026 INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC
1027 REAL ALPHA, BETA
1028 CHARACTER*1 SIDE, UPLO
1029 CHARACTER*12 SNAME
1030 CHARACTER*14 CRC, CS,CU
1031
1032 IF (side.EQ.'L')THEN
1033 cs = ' CblasLeft'
1034 ELSE
1035 cs = ' CblasRight'
1036 END IF
1037 IF (uplo.EQ.'U')THEN
1038 cu = ' CblasUpper'
1039 ELSE
1040 cu = ' CblasLower'
1041 END IF
1042 IF (iorder.EQ.1)THEN
1043 crc = ' CblasRowMajor'
1044 ELSE
1045 crc = ' CblasColMajor'
1046 END IF
1047 WRITE(nout, fmt = 9995)nc,sname,crc, cs,cu
1048 WRITE(nout, fmt = 9994)m, n, alpha, lda, ldb, beta, ldc
1049
1050 9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
1051 9994 FORMAT( 20x, 2( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',',
1052 $ f4.1, ', ', 'C,', i3, ').' )

◆ sprcn3()

subroutine sprcn3 ( integer nout,
integer nc,
character*12 sname,
integer iorder,
character*1 side,
character*1 uplo,
character*1 transa,
character*1 diag,
integer m,
integer n,
real alpha,
integer lda,
integer ldb )

Definition at line 1371 of file c_sblat3.f.

1373 INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
1374 REAL ALPHA
1375 CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
1376 CHARACTER*12 SNAME
1377 CHARACTER*14 CRC, CS, CU, CA, CD
1378
1379 IF (side.EQ.'L')THEN
1380 cs = ' CblasLeft'
1381 ELSE
1382 cs = ' CblasRight'
1383 END IF
1384 IF (uplo.EQ.'U')THEN
1385 cu = ' CblasUpper'
1386 ELSE
1387 cu = ' CblasLower'
1388 END IF
1389 IF (transa.EQ.'N')THEN
1390 ca = ' CblasNoTrans'
1391 ELSE IF (transa.EQ.'T')THEN
1392 ca = ' CblasTrans'
1393 ELSE
1394 ca = 'CblasConjTrans'
1395 END IF
1396 IF (diag.EQ.'N')THEN
1397 cd = ' CblasNonUnit'
1398 ELSE
1399 cd = ' CblasUnit'
1400 END IF
1401 IF (iorder.EQ.1)THEN
1402 crc = 'CblasRowMajor'
1403 ELSE
1404 crc = 'CblasColMajor'
1405 END IF
1406 WRITE(nout, fmt = 9995)nc,sname,crc, cs,cu
1407 WRITE(nout, fmt = 9994)ca, cd, m, n, alpha, lda, ldb
1408
1409 9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
1410 9994 FORMAT( 22x, 2( a14, ',') , 2( i3, ',' ),
1411 $ f4.1, ', A,', i3, ', B,', i3, ').' )

◆ sprcn4()

subroutine sprcn4 ( integer nout,
integer nc,
character*12 sname,
integer iorder,
character*1 uplo,
character*1 transa,
integer n,
integer k,
real alpha,
integer lda,
real beta,
integer ldc )

Definition at line 1698 of file c_sblat3.f.

1700 INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
1701 REAL ALPHA, BETA
1702 CHARACTER*1 UPLO, TRANSA
1703 CHARACTER*12 SNAME
1704 CHARACTER*14 CRC, CU, CA
1705
1706 IF (uplo.EQ.'U')THEN
1707 cu = ' CblasUpper'
1708 ELSE
1709 cu = ' CblasLower'
1710 END IF
1711 IF (transa.EQ.'N')THEN
1712 ca = ' CblasNoTrans'
1713 ELSE IF (transa.EQ.'T')THEN
1714 ca = ' CblasTrans'
1715 ELSE
1716 ca = 'CblasConjTrans'
1717 END IF
1718 IF (iorder.EQ.1)THEN
1719 crc = ' CblasRowMajor'
1720 ELSE
1721 crc = ' CblasColMajor'
1722 END IF
1723 WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
1724 WRITE(nout, fmt = 9994)n, k, alpha, lda, beta, ldc
1725
1726 9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
1727 9994 FORMAT( 20x, 2( i3, ',' ),
1728 $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ').' )

◆ sprcn5()

subroutine sprcn5 ( integer nout,
integer nc,
character*12 sname,
integer iorder,
character*1 uplo,
character*1 transa,
integer n,
integer k,
real alpha,
integer lda,
integer ldb,
real beta,
integer ldc )

Definition at line 2054 of file c_sblat3.f.

2056 INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2057 REAL ALPHA, BETA
2058 CHARACTER*1 UPLO, TRANSA
2059 CHARACTER*12 SNAME
2060 CHARACTER*14 CRC, CU, CA
2061
2062 IF (uplo.EQ.'U')THEN
2063 cu = ' CblasUpper'
2064 ELSE
2065 cu = ' CblasLower'
2066 END IF
2067 IF (transa.EQ.'N')THEN
2068 ca = ' CblasNoTrans'
2069 ELSE IF (transa.EQ.'T')THEN
2070 ca = ' CblasTrans'
2071 ELSE
2072 ca = 'CblasConjTrans'
2073 END IF
2074 IF (iorder.EQ.1)THEN
2075 crc = ' CblasRowMajor'
2076 ELSE
2077 crc = ' CblasColMajor'
2078 END IF
2079 WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
2080 WRITE(nout, fmt = 9994)n, k, alpha, lda, ldb, beta, ldc
2081
2082 9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
2083 9994 FORMAT( 20x, 2( i3, ',' ),
2084 $ f4.1, ', A,', i3, ', B', i3, ',', f4.1, ', C,', i3, ').' )