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

Go to the source code of this file.

Functions/Subroutines

program cblat3
subroutine cchk1 (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 cprcn1 (nout, nc, sname, iorder, transa, transb, m, n, k, alpha, lda, ldb, beta, ldc)
subroutine cchk2 (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 cprcn2 (nout, nc, sname, iorder, side, uplo, m, n, alpha, lda, ldb, beta, ldc)
subroutine cchk3 (sname, eps, thresh, nout, ntra, trace, rewi, fatal, nidim, idim, nalf, alf, nmax, a, aa, as, b, bb, bs, ct, g, c, iorder)
subroutine cprcn3 (nout, nc, sname, iorder, side, uplo, transa, diag, m, n, alpha, lda, ldb)
subroutine cchk4 (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 cprcn4 (nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
subroutine cprcn6 (nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
subroutine cchk5 (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 cprcn5 (nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
subroutine cprcn7 (nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
subroutine cmake (type, uplo, diag, m, n, a, nmax, aa, lda, reset, transl)
subroutine cmmch (transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
logical function lce (ri, rj, lr)
logical function lceres (type, uplo, m, n, aa, as, lda)
complex function cbeg (reset)
real function sdiff (x, y)

Function/Subroutine Documentation

◆ cbeg()

complex function cbeg ( logical reset)

Definition at line 2715 of file c_cblat3.f.

2716*
2717* Generates complex numbers as pairs of random numbers uniformly
2718* distributed between -0.5 and 0.5.
2719*
2720* Auxiliary routine for test program for Level 3 Blas.
2721*
2722* -- Written on 8-February-1989.
2723* Jack Dongarra, Argonne National Laboratory.
2724* Iain Duff, AERE Harwell.
2725* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2726* Sven Hammarling, Numerical Algorithms Group Ltd.
2727*
2728* .. Scalar Arguments ..
2729 LOGICAL RESET
2730* .. Local Scalars ..
2731 INTEGER I, IC, J, MI, MJ
2732* .. Save statement ..
2733 SAVE i, ic, j, mi, mj
2734* .. Intrinsic Functions ..
2735 INTRINSIC cmplx
2736* .. Executable Statements ..
2737 IF( reset )THEN
2738* Initialize local variables.
2739 mi = 891
2740 mj = 457
2741 i = 7
2742 j = 7
2743 ic = 0
2744 reset = .false.
2745 END IF
2746*
2747* The sequence of values of I or J is bounded between 1 and 999.
2748* If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
2749* If initial I or J = 4 or 8, the period will be 25.
2750* If initial I or J = 5, the period will be 10.
2751* IC is used to break up the period by skipping 1 value of I or J
2752* in 6.
2753*
2754 ic = ic + 1
2755 10 i = i*mi
2756 j = j*mj
2757 i = i - 1000*( i/1000 )
2758 j = j - 1000*( j/1000 )
2759 IF( ic.GE.5 )THEN
2760 ic = 0
2761 GO TO 10
2762 END IF
2763 cbeg = cmplx( ( i - 500 )/1001.0, ( j - 500 )/1001.0 )
2764 RETURN
2765*
2766* End of CBEG.
2767*
cmplx
float cmplx[2]
Definition pblas.h:136
cbeg
complex function cbeg(reset)
Definition c_cblat3.f:2716

◆ cblat3()

program cblat3

Definition at line 1 of file c_cblat3.f.

◆ cchk1()

subroutine cchk1 ( 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,
complex, dimension( nalf ) alf,
integer nbet,
complex, dimension( nbet ) bet,
integer nmax,
complex, dimension( nmax, nmax ) a,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax, nmax ) b,
complex, dimension( nmax*nmax ) bb,
complex, dimension( nmax*nmax ) bs,
complex, dimension( nmax, nmax ) c,
complex, dimension( nmax*nmax ) cc,
complex, dimension( nmax*nmax ) cs,
complex, dimension( nmax ) ct,
real, dimension( nmax ) g,
integer iorder )

Definition at line 425 of file c_cblat3.f.

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

◆ cchk2()

subroutine cchk2 ( 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,
complex, dimension( nalf ) alf,
integer nbet,
complex, dimension( nbet ) bet,
integer nmax,
complex, dimension( nmax, nmax ) a,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax, nmax ) b,
complex, dimension( nmax*nmax ) bb,
complex, dimension( nmax*nmax ) bs,
complex, dimension( nmax, nmax ) c,
complex, dimension( nmax*nmax ) cc,
complex, dimension( nmax*nmax ) cs,
complex, dimension( nmax ) ct,
real, dimension( nmax ) g,
integer iorder )

Definition at line 755 of file c_cblat3.f.

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

◆ cchk3()

subroutine cchk3 ( 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,
complex, dimension( nalf ) alf,
integer nmax,
complex, dimension( nmax, nmax ) a,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax, nmax ) b,
complex, dimension( nmax*nmax ) bb,
complex, dimension( nmax*nmax ) bs,
complex, dimension( nmax ) ct,
real, dimension( nmax ) g,
complex, dimension( nmax, nmax ) c,
integer iorder )

Definition at line 1077 of file c_cblat3.f.

1080*
1081* Tests CTRMM and CTRSM.
1082*
1083* Auxiliary routine for test program for Level 3 Blas.
1084*
1085* -- Written on 8-February-1989.
1086* Jack Dongarra, Argonne National Laboratory.
1087* Iain Duff, AERE Harwell.
1088* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1089* Sven Hammarling, Numerical Algorithms Group Ltd.
1090*
1091* .. Parameters ..
1092 COMPLEX ZERO, ONE
1093 parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
1094 REAL RZERO
1095 parameter( rzero = 0.0 )
1096* .. Scalar Arguments ..
1097 REAL EPS, THRESH
1098 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
1099 LOGICAL FATAL, REWI, TRACE
1100 CHARACTER*12 SNAME
1101* .. Array Arguments ..
1102 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1103 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1104 $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
1105 $ C( NMAX, NMAX ), CT( NMAX )
1106 REAL G( NMAX )
1107 INTEGER IDIM( NIDIM )
1108* .. Local Scalars ..
1109 COMPLEX ALPHA, ALS
1110 REAL ERR, ERRMAX
1111 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
1112 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
1113 $ NS
1114 LOGICAL LEFT, NULL, RESET, SAME
1115 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
1116 $ UPLOS
1117 CHARACTER*2 ICHD, ICHS, ICHU
1118 CHARACTER*3 ICHT
1119* .. Local Arrays ..
1120 LOGICAL ISAME( 13 )
1121* .. External Functions ..
1122 LOGICAL LCE, LCERES
1123 EXTERNAL lce, lceres
1124* .. External Subroutines ..
1125 EXTERNAL cmake, cmmch, cctrmm, cctrsm
1126* .. Intrinsic Functions ..
1127 INTRINSIC max
1128* .. Scalars in Common ..
1129 INTEGER INFOT, NOUTC
1130 LOGICAL LERR, OK
1131* .. Common blocks ..
1132 COMMON /infoc/infot, noutc, ok, lerr
1133* .. Data statements ..
1134 DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/, ichs/'LR'/
1135* .. Executable Statements ..
1136*
1137 nargs = 11
1138 nc = 0
1139 reset = .true.
1140 errmax = rzero
1141* Set up zero matrix for CMMCH.
1142 DO 20 j = 1, nmax
1143 DO 10 i = 1, nmax
1144 c( i, j ) = zero
1145 10 CONTINUE
1146 20 CONTINUE
1147*
1148 DO 140 im = 1, nidim
1149 m = idim( im )
1150*
1151 DO 130 in = 1, nidim
1152 n = idim( in )
1153* Set LDB to 1 more than minimum value if room.
1154 ldb = m
1155 IF( ldb.LT.nmax )
1156 $ ldb = ldb + 1
1157* Skip tests if not enough room.
1158 IF( ldb.GT.nmax )
1159 $ GO TO 130
1160 lbb = ldb*n
1161 null = m.LE.0.OR.n.LE.0
1162*
1163 DO 120 ics = 1, 2
1164 side = ichs( ics: ics )
1165 left = side.EQ.'L'
1166 IF( left )THEN
1167 na = m
1168 ELSE
1169 na = n
1170 END IF
1171* Set LDA to 1 more than minimum value if room.
1172 lda = na
1173 IF( lda.LT.nmax )
1174 $ lda = lda + 1
1175* Skip tests if not enough room.
1176 IF( lda.GT.nmax )
1177 $ GO TO 130
1178 laa = lda*na
1179*
1180 DO 110 icu = 1, 2
1181 uplo = ichu( icu: icu )
1182*
1183 DO 100 ict = 1, 3
1184 transa = icht( ict: ict )
1185*
1186 DO 90 icd = 1, 2
1187 diag = ichd( icd: icd )
1188*
1189 DO 80 ia = 1, nalf
1190 alpha = alf( ia )
1191*
1192* Generate the matrix A.
1193*
1194 CALL cmake( 'tr', uplo, diag, na, na, a,
1195 $ nmax, aa, lda, reset, zero )
1196*
1197* Generate the matrix B.
1198*
1199 CALL cmake( 'ge', ' ', ' ', m, n, b, nmax,
1200 $ bb, ldb, reset, zero )
1201*
1202 nc = nc + 1
1203*
1204* Save every datum before calling the
1205* subroutine.
1206*
1207 sides = side
1208 uplos = uplo
1209 tranas = transa
1210 diags = diag
1211 ms = m
1212 ns = n
1213 als = alpha
1214 DO 30 i = 1, laa
1215 as( i ) = aa( i )
1216 30 CONTINUE
1217 ldas = lda
1218 DO 40 i = 1, lbb
1219 bs( i ) = bb( i )
1220 40 CONTINUE
1221 ldbs = ldb
1222*
1223* Call the subroutine.
1224*
1225 IF( sname( 10: 11 ).EQ.'mm' )THEN
1226 IF( trace )
1227 $ CALL cprcn3( ntra, nc, sname, iorder,
1228 $ side, uplo, transa, diag, m, n, alpha,
1229 $ lda, ldb)
1230 IF( rewi )
1231 $ rewind ntra
1232 CALL cctrmm(iorder, side, uplo, transa,
1233 $ diag, m, n, alpha, aa, lda,
1234 $ bb, ldb )
1235 ELSE IF( sname( 10: 11 ).EQ.'sm' )THEN
1236 IF( trace )
1237 $ CALL cprcn3( ntra, nc, sname, iorder,
1238 $ side, uplo, transa, diag, m, n, alpha,
1239 $ lda, ldb)
1240 IF( rewi )
1241 $ rewind ntra
1242 CALL cctrsm(iorder, side, uplo, transa,
1243 $ diag, m, n, alpha, aa, lda,
1244 $ bb, ldb )
1245 END IF
1246*
1247* Check if error-exit was taken incorrectly.
1248*
1249 IF( .NOT.ok )THEN
1250 WRITE( nout, fmt = 9994 )
1251 fatal = .true.
1252 GO TO 150
1253 END IF
1254*
1255* See what data changed inside subroutines.
1256*
1257 isame( 1 ) = sides.EQ.side
1258 isame( 2 ) = uplos.EQ.uplo
1259 isame( 3 ) = tranas.EQ.transa
1260 isame( 4 ) = diags.EQ.diag
1261 isame( 5 ) = ms.EQ.m
1262 isame( 6 ) = ns.EQ.n
1263 isame( 7 ) = als.EQ.alpha
1264 isame( 8 ) = lce( as, aa, laa )
1265 isame( 9 ) = ldas.EQ.lda
1266 IF( null )THEN
1267 isame( 10 ) = lce( bs, bb, lbb )
1268 ELSE
1269 isame( 10 ) = lceres( 'ge', ' ', m, n, bs,
1270 $ bb, ldb )
1271 END IF
1272 isame( 11 ) = ldbs.EQ.ldb
1273*
1274* If data was incorrectly changed, report and
1275* return.
1276*
1277 same = .true.
1278 DO 50 i = 1, nargs
1279 same = same.AND.isame( i )
1280 IF( .NOT.isame( i ) )
1281 $ WRITE( nout, fmt = 9998 )i
1282 50 CONTINUE
1283 IF( .NOT.same )THEN
1284 fatal = .true.
1285 GO TO 150
1286 END IF
1287*
1288 IF( .NOT.null )THEN
1289 IF( sname( 10: 11 ).EQ.'mm' )THEN
1290*
1291* Check the result.
1292*
1293 IF( left )THEN
1294 CALL cmmch( transa, 'N', m, n, m,
1295 $ alpha, a, nmax, b, nmax,
1296 $ zero, c, nmax, ct, g,
1297 $ bb, ldb, eps, err,
1298 $ fatal, nout, .true. )
1299 ELSE
1300 CALL cmmch( 'N', transa, m, n, n,
1301 $ alpha, b, nmax, a, nmax,
1302 $ zero, c, nmax, ct, g,
1303 $ bb, ldb, eps, err,
1304 $ fatal, nout, .true. )
1305 END IF
1306 ELSE IF( sname( 10: 11 ).EQ.'sm' )THEN
1307*
1308* Compute approximation to original
1309* matrix.
1310*
1311 DO 70 j = 1, n
1312 DO 60 i = 1, m
1313 c( i, j ) = bb( i + ( j - 1 )*
1314 $ ldb )
1315 bb( i + ( j - 1 )*ldb ) = alpha*
1316 $ b( i, j )
1317 60 CONTINUE
1318 70 CONTINUE
1319*
1320 IF( left )THEN
1321 CALL cmmch( transa, 'N', m, n, m,
1322 $ one, a, nmax, c, nmax,
1323 $ zero, b, nmax, ct, g,
1324 $ bb, ldb, eps, err,
1325 $ fatal, nout, .false. )
1326 ELSE
1327 CALL cmmch( 'N', transa, m, n, n,
1328 $ one, c, nmax, a, nmax,
1329 $ zero, b, nmax, ct, g,
1330 $ bb, ldb, eps, err,
1331 $ fatal, nout, .false. )
1332 END IF
1333 END IF
1334 errmax = max( errmax, err )
1335* If got really bad answer, report and
1336* return.
1337 IF( fatal )
1338 $ GO TO 150
1339 END IF
1340*
1341 80 CONTINUE
1342*
1343 90 CONTINUE
1344*
1345 100 CONTINUE
1346*
1347 110 CONTINUE
1348*
1349 120 CONTINUE
1350*
1351 130 CONTINUE
1352*
1353 140 CONTINUE
1354*
1355* Report result.
1356*
1357 IF( errmax.LT.thresh )THEN
1358 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1359 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1360 ELSE
1361 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1362 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1363 END IF
1364 GO TO 160
1365*
1366 150 CONTINUE
1367 WRITE( nout, fmt = 9996 )sname
1368 IF( trace )
1369 $ CALL cprcn3( ntra, nc, sname, iorder, side, uplo, transa, diag,
1370 $ m, n, alpha, lda, ldb)
1371*
1372 160 CONTINUE
1373 RETURN
1374*
137510003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1376 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1377 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
137810002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1379 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1380 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
138110001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1382 $ ' (', i6, ' CALL', 'S)' )
138310000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1384 $ ' (', i6, ' CALL', 'S)' )
1385 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1386 $ 'ANGED INCORRECTLY *******' )
1387 9996 FORMAT(' ******* ', a12,' FAILED ON CALL NUMBER:' )
1388 9995 FORMAT(1x, i6, ': ', a12,'(', 4( '''', a1, ''',' ), 2( i3, ',' ),
1389 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ') ',
1390 $ ' .' )
1391 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1392 $ '******' )
1393*
1394* End of CCHK3.
1395*
cprcn3
subroutine cprcn3(nout, nc, sname, iorder, side, uplo, transa, diag, m, n, alpha, lda, ldb)
Definition c_cblat3.f:1400

◆ cchk4()

subroutine cchk4 ( 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,
complex, dimension( nalf ) alf,
integer nbet,
complex, dimension( nbet ) bet,
integer nmax,
complex, dimension( nmax, nmax ) a,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax, nmax ) b,
complex, dimension( nmax*nmax ) bb,
complex, dimension( nmax*nmax ) bs,
complex, dimension( nmax, nmax ) c,
complex, dimension( nmax*nmax ) cc,
complex, dimension( nmax*nmax ) cs,
complex, dimension( nmax ) ct,
real, dimension( nmax ) g,
integer iorder )

Definition at line 1441 of file c_cblat3.f.

1445*
1446* Tests CHERK and CSYRK.
1447*
1448* Auxiliary routine for test program for Level 3 Blas.
1449*
1450* -- Written on 8-February-1989.
1451* Jack Dongarra, Argonne National Laboratory.
1452* Iain Duff, AERE Harwell.
1453* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1454* Sven Hammarling, Numerical Algorithms Group Ltd.
1455*
1456* .. Parameters ..
1457 COMPLEX ZERO
1458 parameter( zero = ( 0.0, 0.0 ) )
1459 REAL RONE, RZERO
1460 parameter( rone = 1.0, rzero = 0.0 )
1461* .. Scalar Arguments ..
1462 REAL EPS, THRESH
1463 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1464 LOGICAL FATAL, REWI, TRACE
1465 CHARACTER*12 SNAME
1466* .. Array Arguments ..
1467 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1468 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1469 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1470 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1471 $ CS( NMAX*NMAX ), CT( NMAX )
1472 REAL G( NMAX )
1473 INTEGER IDIM( NIDIM )
1474* .. Local Scalars ..
1475 COMPLEX ALPHA, ALS, BETA, BETS
1476 REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS
1477 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1478 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1479 $ NARGS, NC, NS
1480 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1481 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1482 CHARACTER*2 ICHT, ICHU
1483* .. Local Arrays ..
1484 LOGICAL ISAME( 13 )
1485* .. External Functions ..
1486 LOGICAL LCE, LCERES
1487 EXTERNAL lce, lceres
1488* .. External Subroutines ..
1489 EXTERNAL ccherk, cmake, cmmch, ccsyrk
1490* .. Intrinsic Functions ..
1491 INTRINSIC cmplx, max, real
1492* .. Scalars in Common ..
1493 INTEGER INFOT, NOUTC
1494 LOGICAL LERR, OK
1495* .. Common blocks ..
1496 COMMON /infoc/infot, noutc, ok, lerr
1497* .. Data statements ..
1498 DATA icht/'NC'/, ichu/'UL'/
1499* .. Executable Statements ..
1500 conj = sname( 8: 9 ).EQ.'he'
1501*
1502 NARGS = 10
1503 NC = 0
1504 RESET = .TRUE.
1505 ERRMAX = RZERO
1506*
1507 DO 100 IN = 1, NIDIM
1508 N = IDIM( IN )
1509* Set LDC to 1 more than minimum value if room.
1510 LDC = N
1511.LT. IF( LDCNMAX )
1512 $ LDC = LDC + 1
1513* Skip tests if not enough room.
1514.GT. IF( LDCNMAX )
1515 $ GO TO 100
1516 LCC = LDC*N
1517*
1518 DO 90 IK = 1, NIDIM
1519 K = IDIM( IK )
1520*
1521 DO 80 ICT = 1, 2
1522 TRANS = ICHT( ICT: ICT )
1523.EQ. TRAN = TRANS'c'
1524.AND..NOT. IF( TRANCONJ )
1525 $ TRANS = 't'
1526 IF( TRAN )THEN
1527 MA = K
1528 NA = N
1529 ELSE
1530 MA = N
1531 NA = K
1532 END IF
1533* Set LDA to 1 more than minimum value if room.
1534 LDA = MA
1535.LT. IF( LDANMAX )
1536 $ LDA = LDA + 1
1537* Skip tests if not enough room.
1538.GT. IF( LDANMAX )
1539 $ GO TO 80
1540 LAA = LDA*NA
1541*
1542* Generate the matrix A.
1543*
1544 CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1545 $ RESET, ZERO )
1546*
1547 DO 70 ICU = 1, 2
1548 UPLO = ICHU( ICU: ICU )
1549.EQ. UPPER = UPLO'u'
1550*
1551 DO 60 IA = 1, NALF
1552 ALPHA = ALF( IA )
1553 IF( CONJ )THEN
1554 RALPHA = REAL( ALPHA )
1555 ALPHA = CMPLX( RALPHA, RZERO )
1556 END IF
1557*
1558 DO 50 IB = 1, NBET
1559 BETA = BET( IB )
1560 IF( CONJ )THEN
1561 RBETA = REAL( BETA )
1562 BETA = CMPLX( RBETA, RZERO )
1563 END IF
1564.LE. NULL = N0
1565 IF( CONJ )
1566.OR..LE..OR..EQ. $ NULL = NULL( ( K0RALPHA
1567.AND..EQ. $ RZERO )RBETARONE )
1568*
1569* Generate the matrix C.
1570*
1571 CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C,
1572 $ NMAX, CC, LDC, RESET, ZERO )
1573*
1574 NC = NC + 1
1575*
1576* Save every datum before calling the subroutine.
1577*
1578 UPLOS = UPLO
1579 TRANSS = TRANS
1580 NS = N
1581 KS = K
1582 IF( CONJ )THEN
1583 RALS = RALPHA
1584 ELSE
1585 ALS = ALPHA
1586 END IF
1587 DO 10 I = 1, LAA
1588 AS( I ) = AA( I )
1589 10 CONTINUE
1590 LDAS = LDA
1591 IF( CONJ )THEN
1592 RBETS = RBETA
1593 ELSE
1594 BETS = BETA
1595 END IF
1596 DO 20 I = 1, LCC
1597 CS( I ) = CC( I )
1598 20 CONTINUE
1599 LDCS = LDC
1600*
1601* Call the subroutine.
1602*
1603 IF( CONJ )THEN
1604 IF( TRACE )
1605 $ CALL CPRCN6( NTRA, NC, SNAME, IORDER,
1606 $ UPLO, TRANS, N, K, RALPHA, LDA, RBETA,
1607 $ LDC)
1608 IF( REWI )
1609 $ REWIND NTRA
1610 CALL CCHERK( IORDER, UPLO, TRANS, N, K,
1611 $ RALPHA, AA, LDA, RBETA, CC,
1612 $ LDC )
1613 ELSE
1614 IF( TRACE )
1615 $ CALL CPRCN4( NTRA, NC, SNAME, IORDER,
1616 $ UPLO, TRANS, N, K, ALPHA, LDA, BETA, LDC)
1617 IF( REWI )
1618 $ REWIND NTRA
1619 CALL CCSYRK( IORDER, UPLO, TRANS, N, K,
1620 $ ALPHA, AA, LDA, BETA, CC, LDC )
1621 END IF
1622*
1623* Check if error-exit was taken incorrectly.
1624*
1625.NOT. IF( OK )THEN
1626 WRITE( NOUT, FMT = 9992 )
1627 FATAL = .TRUE.
1628 GO TO 120
1629 END IF
1630*
1631* See what data changed inside subroutines.
1632*
1633.EQ. ISAME( 1 ) = UPLOSUPLO
1634.EQ. ISAME( 2 ) = TRANSSTRANS
1635.EQ. ISAME( 3 ) = NSN
1636.EQ. ISAME( 4 ) = KSK
1637 IF( CONJ )THEN
1638.EQ. ISAME( 5 ) = RALSRALPHA
1639 ELSE
1640.EQ. ISAME( 5 ) = ALSALPHA
1641 END IF
1642 ISAME( 6 ) = LCE( AS, AA, LAA )
1643.EQ. ISAME( 7 ) = LDASLDA
1644 IF( CONJ )THEN
1645.EQ. ISAME( 8 ) = RBETSRBETA
1646 ELSE
1647.EQ. ISAME( 8 ) = BETSBETA
1648 END IF
1649 IF( NULL )THEN
1650 ISAME( 9 ) = LCE( CS, CC, LCC )
1651 ELSE
1652 ISAME( 9 ) = LCERES( SNAME( 8: 9 ), UPLO, N,
1653 $ N, CS, CC, LDC )
1654 END IF
1655.EQ. ISAME( 10 ) = LDCSLDC
1656*
1657* If data was incorrectly changed, report and
1658* return.
1659*
1660 SAME = .TRUE.
1661 DO 30 I = 1, NARGS
1662.AND. SAME = SAMEISAME( I )
1663.NOT. IF( ISAME( I ) )
1664 $ WRITE( NOUT, FMT = 9998 )I
1665 30 CONTINUE
1666.NOT. IF( SAME )THEN
1667 FATAL = .TRUE.
1668 GO TO 120
1669 END IF
1670*
1671.NOT. IF( NULL )THEN
1672*
1673* Check the result column by column.
1674*
1675 IF( CONJ )THEN
1676 TRANST = 'c'
1677 ELSE
1678 TRANST = 't'
1679 END IF
1680 JC = 1
1681 DO 40 J = 1, N
1682 IF( UPPER )THEN
1683 JJ = 1
1684 LJ = J
1685 ELSE
1686 JJ = J
1687 LJ = N - J + 1
1688 END IF
1689 IF( TRAN )THEN
1690 CALL CMMCH( TRANST, 'n', LJ, 1, K,
1691 $ ALPHA, A( 1, JJ ), NMAX,
1692 $ A( 1, J ), NMAX, BETA,
1693 $ C( JJ, J ), NMAX, CT, G,
1694 $ CC( JC ), LDC, EPS, ERR,
1695 $ FATAL, NOUT, .TRUE. )
1696 ELSE
1697 CALL CMMCH( 'n', TRANST, LJ, 1, K,
1698 $ ALPHA, A( JJ, 1 ), NMAX,
1699 $ A( J, 1 ), NMAX, BETA,
1700 $ C( JJ, J ), NMAX, CT, G,
1701 $ CC( JC ), LDC, EPS, ERR,
1702 $ FATAL, NOUT, .TRUE. )
1703 END IF
1704 IF( UPPER )THEN
1705 JC = JC + LDC
1706 ELSE
1707 JC = JC + LDC + 1
1708 END IF
1709 ERRMAX = MAX( ERRMAX, ERR )
1710* If got really bad answer, report and
1711* return.
1712 IF( FATAL )
1713 $ GO TO 110
1714 40 CONTINUE
1715 END IF
1716*
1717 50 CONTINUE
1718*
1719 60 CONTINUE
1720*
1721 70 CONTINUE
1722*
1723 80 CONTINUE
1724*
1725 90 CONTINUE
1726*
1727 100 CONTINUE
1728*
1729* Report result.
1730*
1731.LT. IF( ERRMAXTHRESH )THEN
1732.EQ. IF ( IORDER0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1733.EQ. IF ( IORDER1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1734 ELSE
1735.EQ. IF ( IORDER0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1736.EQ. IF ( IORDER1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1737 END IF
1738 GO TO 130
1739*
1740 110 CONTINUE
1741.GT. IF( N1 )
1742 $ WRITE( NOUT, FMT = 9995 )J
1743*
1744 120 CONTINUE
1745 WRITE( NOUT, FMT = 9996 )SNAME
1746 IF( CONJ )THEN
1747 CALL CPRCN6( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, RALPHA,
1748 $ LDA, rBETA, LDC)
1749 ELSE
1750 CALL CPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA,
1751 $ LDA, BETA, LDC)
1752 END IF
1753*
1754 130 CONTINUE
1755 RETURN
1756*
175710003 FORMAT( ' ', A12,' completed the row-major computational ',
1758 $ 'tests(', I6, ' calls)', /' ******* but with maximum test ',
1759 $ 'ratio ', F8.2, ' - suspect *******' )
176010002 FORMAT( ' ', A12,' completed the column-major computational ',
1761 $ 'tests(', I6, ' calls)', /' ******* but with maximum test ',
1762 $ 'ratio ', F8.2, ' - suspect *******' )
176310001 FORMAT( ' ', A12,' passed the row-major computational tests',
1764 $ ' (', I6, ' call', 's)' )
176510000 FORMAT( ' ', A12,' passed the column-major computational tests',
1766 $ ' (', I6, ' call', 's)' )
1767 9998 FORMAT(' ******* fatal error - PARAMETER number ', I2, ' was ch',
1768 $ 'anged incorrectly *******' )
1769 9996 FORMAT( ' ******* ', A12,' failed on CALL number:' )
1770 9995 FORMAT( ' these are the results for column ', I3 )
1771 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1772 $ F4.1, ', a,', I3, ',', F4.1, ', c,', I3, ') ',
1773 $ ' .' )
1774 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1775 $ '(', F4.1, ',', F4.1, ') , a,', I3, ',(', F4.1, ',', F4.1,
1776 $ '), c,', I3, ') .' )
1777 9992 FORMAT(' ******* fatal error - error-EXIT taken on valid CALL *',
1778 $ '******' )
1779*
1780* End of CCHK4.
1781*
the
end diagonal values have been computed in the(sparse) matrix id.SOL
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91

◆ cchk5()

subroutine cchk5 ( 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,
complex, dimension( nalf ) alf,
integer nbet,
complex, dimension( nbet ) bet,
integer nmax,
complex, dimension( 2*nmax*nmax ) ab,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax*nmax ) bb,
complex, dimension( nmax*nmax ) bs,
complex, dimension( nmax, nmax ) c,
complex, dimension( nmax*nmax ) cc,
complex, dimension( nmax*nmax ) cs,
complex, dimension( nmax ) ct,
real, dimension( nmax ) g,
complex, dimension( 2*nmax ) w,
integer iorder )

Definition at line 1851 of file c_cblat3.f.

1855*
1856* Tests CHER2K and CSYR2K.
1857*
1858* Auxiliary routine for test program for Level 3 Blas.
1859*
1860* -- Written on 8-February-1989.
1861* Jack Dongarra, Argonne National Laboratory.
1862* Iain Duff, AERE Harwell.
1863* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1864* Sven Hammarling, Numerical Algorithms Group Ltd.
1865*
1866* .. Parameters ..
1867 COMPLEX ZERO, ONE
1868 parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
1869 REAL RONE, RZERO
1870 parameter( rone = 1.0, rzero = 0.0 )
1871* .. Scalar Arguments ..
1872 REAL EPS, THRESH
1873 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1874 LOGICAL FATAL, REWI, TRACE
1875 CHARACTER*12 SNAME
1876* .. Array Arguments ..
1877 COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1878 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1879 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1880 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1881 $ W( 2*NMAX )
1882 REAL G( NMAX )
1883 INTEGER IDIM( NIDIM )
1884* .. Local Scalars ..
1885 COMPLEX ALPHA, ALS, BETA, BETS
1886 REAL ERR, ERRMAX, RBETA, RBETS
1887 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1888 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1889 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1890 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1891 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1892 CHARACTER*2 ICHT, ICHU
1893* .. Local Arrays ..
1894 LOGICAL ISAME( 13 )
1895* .. External Functions ..
1896 LOGICAL LCE, LCERES
1897 EXTERNAL lce, lceres
1898* .. External Subroutines ..
1899 EXTERNAL ccher2k, cmake, cmmch, ccsyr2k
1900* .. Intrinsic Functions ..
1901 INTRINSIC cmplx, conjg, max, real
1902* .. Scalars in Common ..
1903 INTEGER INFOT, NOUTC
1904 LOGICAL LERR, OK
1905* .. Common blocks ..
1906 COMMON /infoc/infot, noutc, ok, lerr
1907* .. Data statements ..
1908 DATA icht/'NC'/, ichu/'UL'/
1909* .. Executable Statements ..
1910 conj = sname( 8: 9 ).EQ.'he'
1911*
1912 nargs = 12
1913 nc = 0
1914 reset = .true.
1915 errmax = rzero
1916*
1917 DO 130 in = 1, nidim
1918 n = idim( in )
1919* Set LDC to 1 more than minimum value if room.
1920 ldc = n
1921 IF( ldc.LT.nmax )
1922 $ ldc = ldc + 1
1923* Skip tests if not enough room.
1924 IF( ldc.GT.nmax )
1925 $ GO TO 130
1926 lcc = ldc*n
1927*
1928 DO 120 ik = 1, nidim
1929 k = idim( ik )
1930*
1931 DO 110 ict = 1, 2
1932 trans = icht( ict: ict )
1933 tran = trans.EQ.'C'
1934 IF( tran.AND..NOT.conj )
1935 $ trans = 'T'
1936 IF( tran )THEN
1937 ma = k
1938 na = n
1939 ELSE
1940 ma = n
1941 na = k
1942 END IF
1943* Set LDA to 1 more than minimum value if room.
1944 lda = ma
1945 IF( lda.LT.nmax )
1946 $ lda = lda + 1
1947* Skip tests if not enough room.
1948 IF( lda.GT.nmax )
1949 $ GO TO 110
1950 laa = lda*na
1951*
1952* Generate the matrix A.
1953*
1954 IF( tran )THEN
1955 CALL cmake( 'ge', ' ', ' ', ma, na, ab, 2*nmax, aa,
1956 $ lda, reset, zero )
1957 ELSE
1958 CALL cmake( 'ge', ' ', ' ', ma, na, ab, nmax, aa, lda,
1959 $ reset, zero )
1960 END IF
1961*
1962* Generate the matrix B.
1963*
1964 ldb = lda
1965 lbb = laa
1966 IF( tran )THEN
1967 CALL cmake( 'ge', ' ', ' ', ma, na, ab( k + 1 ),
1968 $ 2*nmax, bb, ldb, reset, zero )
1969 ELSE
1970 CALL cmake( 'ge', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1971 $ nmax, bb, ldb, reset, zero )
1972 END IF
1973*
1974 DO 100 icu = 1, 2
1975 uplo = ichu( icu: icu )
1976 upper = uplo.EQ.'U'
1977*
1978 DO 90 ia = 1, nalf
1979 alpha = alf( ia )
1980*
1981 DO 80 ib = 1, nbet
1982 beta = bet( ib )
1983 IF( conj )THEN
1984 rbeta = real( beta )
1985 beta = cmplx( rbeta, rzero )
1986 END IF
1987 null = n.LE.0
1988 IF( conj )
1989 $ null = null.OR.( ( k.LE.0.OR.alpha.EQ.
1990 $ zero ).AND.rbeta.EQ.rone )
1991*
1992* Generate the matrix C.
1993*
1994 CALL cmake( sname( 8: 9 ), uplo, ' ', n, n, c,
1995 $ nmax, cc, ldc, reset, zero )
1996*
1997 nc = nc + 1
1998*
1999* Save every datum before calling the subroutine.
2000*
2001 uplos = uplo
2002 transs = trans
2003 ns = n
2004 ks = k
2005 als = alpha
2006 DO 10 i = 1, laa
2007 as( i ) = aa( i )
2008 10 CONTINUE
2009 ldas = lda
2010 DO 20 i = 1, lbb
2011 bs( i ) = bb( i )
2012 20 CONTINUE
2013 ldbs = ldb
2014 IF( conj )THEN
2015 rbets = rbeta
2016 ELSE
2017 bets = beta
2018 END IF
2019 DO 30 i = 1, lcc
2020 cs( i ) = cc( i )
2021 30 CONTINUE
2022 ldcs = ldc
2023*
2024* Call the subroutine.
2025*
2026 IF( conj )THEN
2027 IF( trace )
2028 $ CALL cprcn7( ntra, nc, sname, iorder,
2029 $ uplo, trans, n, k, alpha, lda, ldb,
2030 $ rbeta, ldc)
2031 IF( rewi )
2032 $ rewind ntra
2033 CALL ccher2k( iorder, uplo, trans, n, k,
2034 $ alpha, aa, lda, bb, ldb, rbeta,
2035 $ cc, ldc )
2036 ELSE
2037 IF( trace )
2038 $ CALL cprcn5( ntra, nc, sname, iorder,
2039 $ uplo, trans, n, k, alpha, lda, ldb,
2040 $ beta, ldc)
2041 IF( rewi )
2042 $ rewind ntra
2043 CALL ccsyr2k( iorder, uplo, trans, n, k,
2044 $ alpha, aa, lda, bb, ldb, beta,
2045 $ cc, ldc )
2046 END IF
2047*
2048* Check if error-exit was taken incorrectly.
2049*
2050 IF( .NOT.ok )THEN
2051 WRITE( nout, fmt = 9992 )
2052 fatal = .true.
2053 GO TO 150
2054 END IF
2055*
2056* See what data changed inside subroutines.
2057*
2058 isame( 1 ) = uplos.EQ.uplo
2059 isame( 2 ) = transs.EQ.trans
2060 isame( 3 ) = ns.EQ.n
2061 isame( 4 ) = ks.EQ.k
2062 isame( 5 ) = als.EQ.alpha
2063 isame( 6 ) = lce( as, aa, laa )
2064 isame( 7 ) = ldas.EQ.lda
2065 isame( 8 ) = lce( bs, bb, lbb )
2066 isame( 9 ) = ldbs.EQ.ldb
2067 IF( conj )THEN
2068 isame( 10 ) = rbets.EQ.rbeta
2069 ELSE
2070 isame( 10 ) = bets.EQ.beta
2071 END IF
2072 IF( null )THEN
2073 isame( 11 ) = lce( cs, cc, lcc )
2074 ELSE
2075 isame( 11 ) = lceres( 'he', uplo, n, n, cs,
2076 $ cc, ldc )
2077 END IF
2078 isame( 12 ) = ldcs.EQ.ldc
2079*
2080* If data was incorrectly changed, report and
2081* return.
2082*
2083 same = .true.
2084 DO 40 i = 1, nargs
2085 same = same.AND.isame( i )
2086 IF( .NOT.isame( i ) )
2087 $ WRITE( nout, fmt = 9998 )i
2088 40 CONTINUE
2089 IF( .NOT.same )THEN
2090 fatal = .true.
2091 GO TO 150
2092 END IF
2093*
2094 IF( .NOT.null )THEN
2095*
2096* Check the result column by column.
2097*
2098 IF( conj )THEN
2099 transt = 'C'
2100 ELSE
2101 transt = 'T'
2102 END IF
2103 jjab = 1
2104 jc = 1
2105 DO 70 j = 1, n
2106 IF( upper )THEN
2107 jj = 1
2108 lj = j
2109 ELSE
2110 jj = j
2111 lj = n - j + 1
2112 END IF
2113 IF( tran )THEN
2114 DO 50 i = 1, k
2115 w( i ) = alpha*ab( ( j - 1 )*2*
2116 $ nmax + k + i )
2117 IF( conj )THEN
2118 w( k + i ) = conjg( alpha )*
2119 $ ab( ( j - 1 )*2*
2120 $ nmax + i )
2121 ELSE
2122 w( k + i ) = alpha*
2123 $ ab( ( j - 1 )*2*
2124 $ nmax + i )
2125 END IF
2126 50 CONTINUE
2127 CALL cmmch( transt, 'N', lj, 1, 2*k,
2128 $ one, ab( jjab ), 2*nmax, w,
2129 $ 2*nmax, beta, c( jj, j ),
2130 $ nmax, ct, g, cc( jc ), ldc,
2131 $ eps, err, fatal, nout,
2132 $ .true. )
2133 ELSE
2134 DO 60 i = 1, k
2135 IF( conj )THEN
2136 w( i ) = alpha*conjg( ab( ( k +
2137 $ i - 1 )*nmax + j ) )
2138 w( k + i ) = conjg( alpha*
2139 $ ab( ( i - 1 )*nmax +
2140 $ j ) )
2141 ELSE
2142 w( i ) = alpha*ab( ( k + i - 1 )*
2143 $ nmax + j )
2144 w( k + i ) = alpha*
2145 $ ab( ( i - 1 )*nmax +
2146 $ j )
2147 END IF
2148 60 CONTINUE
2149 CALL cmmch( 'N', 'N', lj, 1, 2*k, one,
2150 $ ab( jj ), nmax, w, 2*nmax,
2151 $ beta, c( jj, j ), nmax, ct,
2152 $ g, cc( jc ), ldc, eps, err,
2153 $ fatal, nout, .true. )
2154 END IF
2155 IF( upper )THEN
2156 jc = jc + ldc
2157 ELSE
2158 jc = jc + ldc + 1
2159 IF( tran )
2160 $ jjab = jjab + 2*nmax
2161 END IF
2162 errmax = max( errmax, err )
2163* If got really bad answer, report and
2164* return.
2165 IF( fatal )
2166 $ GO TO 140
2167 70 CONTINUE
2168 END IF
2169*
2170 80 CONTINUE
2171*
2172 90 CONTINUE
2173*
2174 100 CONTINUE
2175*
2176 110 CONTINUE
2177*
2178 120 CONTINUE
2179*
2180 130 CONTINUE
2181*
2182* Report result.
2183*
2184 IF( errmax.LT.thresh )THEN
2185 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2186 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2187 ELSE
2188 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2189 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2190 END IF
2191 GO TO 160
2192*
2193 140 CONTINUE
2194 IF( n.GT.1 )
2195 $ WRITE( nout, fmt = 9995 )j
2196*
2197 150 CONTINUE
2198 WRITE( nout, fmt = 9996 )sname
2199 IF( conj )THEN
2200 CALL cprcn7( nout, nc, sname, iorder, uplo, trans, n, k,
2201 $ alpha, lda, ldb, rbeta, ldc)
2202 ELSE
2203 CALL cprcn5( nout, nc, sname, iorder, uplo, trans, n, k,
2204 $ alpha, lda, ldb, beta, ldc)
2205 END IF
2206*
2207 160 CONTINUE
2208 RETURN
2209*
221010003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2211 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2212 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
221310002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2214 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2215 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
221610001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2217 $ ' (', i6, ' CALL', 'S)' )
221810000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2219 $ ' (', i6, ' CALL', 'S)' )
2220 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2221 $ 'ANGED INCORRECTLY *******' )
2222 9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
2223 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2224 9994 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2225 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',', f4.1,
2226 $ ', C,', i3, ') .' )
2227 9993 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2228 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
2229 $ ',', f4.1, '), C,', i3, ') .' )
2230 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2231 $ '******' )
2232*
2233* End of CCHK5.
2234*
cprcn7
subroutine cprcn7(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_cblat3.f:2273
cprcn5
subroutine cprcn5(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_cblat3.f:2239
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ cmake()

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

Definition at line 2305 of file c_cblat3.f.

2307*
2308* Generates values for an M by N matrix A.
2309* Stores the values in the array AA in the data structure required
2310* by the routine, with unwanted elements set to rogue value.
2311*
2312* TYPE is 'ge', 'he', 'sy' or 'tr'.
2313*
2314* Auxiliary routine for test program for Level 3 Blas.
2315*
2316* -- Written on 8-February-1989.
2317* Jack Dongarra, Argonne National Laboratory.
2318* Iain Duff, AERE Harwell.
2319* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2320* Sven Hammarling, Numerical Algorithms Group Ltd.
2321*
2322* .. Parameters ..
2323 COMPLEX ZERO, ONE
2324 parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
2325 COMPLEX ROGUE
2326 parameter( rogue = ( -1.0e10, 1.0e10 ) )
2327 REAL RZERO
2328 parameter( rzero = 0.0 )
2329 REAL RROGUE
2330 parameter( rrogue = -1.0e10 )
2331* .. Scalar Arguments ..
2332 COMPLEX TRANSL
2333 INTEGER LDA, M, N, NMAX
2334 LOGICAL RESET
2335 CHARACTER*1 DIAG, UPLO
2336 CHARACTER*2 TYPE
2337* .. Array Arguments ..
2338 COMPLEX A( NMAX, * ), AA( * )
2339* .. Local Scalars ..
2340 INTEGER I, IBEG, IEND, J, JJ
2341 LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER
2342* .. External Functions ..
2343 COMPLEX CBEG
2344 EXTERNAL cbeg
2345* .. Intrinsic Functions ..
2346 INTRINSIC cmplx, conjg, real
2347* .. Executable Statements ..
2348 gen = type.EQ.'ge'
2349 her = type.EQ.'he'
2350 sym = type.EQ.'sy'
2351 tri = type.EQ.'tr'
2352 upper = ( her.OR.sym.OR.tri ).AND.uplo.EQ.'U'
2353 lower = ( her.OR.sym.OR.tri ).AND.uplo.EQ.'L'
2354 unit = tri.AND.diag.EQ.'U'
2355*
2356* Generate data in array A.
2357*
2358 DO 20 j = 1, n
2359 DO 10 i = 1, m
2360 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2361 $ THEN
2362 a( i, j ) = cbeg( reset ) + transl
2363 IF( i.NE.j )THEN
2364* Set some elements to zero
2365 IF( n.GT.3.AND.j.EQ.n/2 )
2366 $ a( i, j ) = zero
2367 IF( her )THEN
2368 a( j, i ) = conjg( a( i, j ) )
2369 ELSE IF( sym )THEN
2370 a( j, i ) = a( i, j )
2371 ELSE IF( tri )THEN
2372 a( j, i ) = zero
2373 END IF
2374 END IF
2375 END IF
2376 10 CONTINUE
2377 IF( her )
2378 $ a( j, j ) = cmplx( real( a( j, j ) ), rzero )
2379 IF( tri )
2380 $ a( j, j ) = a( j, j ) + one
2381 IF( unit )
2382 $ a( j, j ) = one
2383 20 CONTINUE
2384*
2385* Store elements in array AS in data structure required by routine.
2386*
2387 IF( type.EQ.'ge' )THEN
2388 DO 50 j = 1, n
2389 DO 30 i = 1, m
2390 aa( i + ( j - 1 )*lda ) = a( i, j )
2391 30 CONTINUE
2392 DO 40 i = m + 1, lda
2393 aa( i + ( j - 1 )*lda ) = rogue
2394 40 CONTINUE
2395 50 CONTINUE
2396 ELSE IF( type.EQ.'he'.OR.type.EQ.'sy'.OR.type.EQ.'tr' )THEN
2397 DO 90 j = 1, n
2398 IF( upper )THEN
2399 ibeg = 1
2400 IF( unit )THEN
2401 iend = j - 1
2402 ELSE
2403 iend = j
2404 END IF
2405 ELSE
2406 IF( unit )THEN
2407 ibeg = j + 1
2408 ELSE
2409 ibeg = j
2410 END IF
2411 iend = n
2412 END IF
2413 DO 60 i = 1, ibeg - 1
2414 aa( i + ( j - 1 )*lda ) = rogue
2415 60 CONTINUE
2416 DO 70 i = ibeg, iend
2417 aa( i + ( j - 1 )*lda ) = a( i, j )
2418 70 CONTINUE
2419 DO 80 i = iend + 1, lda
2420 aa( i + ( j - 1 )*lda ) = rogue
2421 80 CONTINUE
2422 IF( her )THEN
2423 jj = j + ( j - 1 )*lda
2424 aa( jj ) = cmplx( real( aa( jj ) ), rrogue )
2425 END IF
2426 90 CONTINUE
2427 END IF
2428 RETURN
2429*
2430* End of CMAKE.
2431*

◆ cmmch()

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

Definition at line 2433 of file c_cblat3.f.

2436*
2437* Checks the results of the computational tests.
2438*
2439* Auxiliary routine for test program for Level 3 Blas.
2440*
2441* -- Written on 8-February-1989.
2442* Jack Dongarra, Argonne National Laboratory.
2443* Iain Duff, AERE Harwell.
2444* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2445* Sven Hammarling, Numerical Algorithms Group Ltd.
2446*
2447* .. Parameters ..
2448 COMPLEX ZERO
2449 parameter( zero = ( 0.0, 0.0 ) )
2450 REAL RZERO, RONE
2451 parameter( rzero = 0.0, rone = 1.0 )
2452* .. Scalar Arguments ..
2453 COMPLEX ALPHA, BETA
2454 REAL EPS, ERR
2455 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2456 LOGICAL FATAL, MV
2457 CHARACTER*1 TRANSA, TRANSB
2458* .. Array Arguments ..
2459 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
2460 $ CC( LDCC, * ), CT( * )
2461 REAL G( * )
2462* .. Local Scalars ..
2463 COMPLEX CL
2464 REAL ERRI
2465 INTEGER I, J, K
2466 LOGICAL CTRANA, CTRANB, TRANA, TRANB
2467* .. Intrinsic Functions ..
2468 INTRINSIC abs, aimag, conjg, max, real, sqrt
2469* .. Statement Functions ..
2470 REAL ABS1
2471* .. Statement Function definitions ..
2472 abs1( cl ) = abs( real( cl ) ) + abs( aimag( cl ) )
2473* .. Executable Statements ..
2474 trana = transa.EQ.'T'.OR.transa.EQ.'C'
2475 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2476 ctrana = transa.EQ.'C'
2477 ctranb = transb.EQ.'C'
2478*
2479* Compute expected result, one column at a time, in CT using data
2480* in A, B and C.
2481* Compute gauges in G.
2482*
2483 DO 220 j = 1, n
2484*
2485 DO 10 i = 1, m
2486 ct( i ) = zero
2487 g( i ) = rzero
2488 10 CONTINUE
2489 IF( .NOT.trana.AND..NOT.tranb )THEN
2490 DO 30 k = 1, kk
2491 DO 20 i = 1, m
2492 ct( i ) = ct( i ) + a( i, k )*b( k, j )
2493 g( i ) = g( i ) + abs1( a( i, k ) )*abs1( b( k, j ) )
2494 20 CONTINUE
2495 30 CONTINUE
2496 ELSE IF( trana.AND..NOT.tranb )THEN
2497 IF( ctrana )THEN
2498 DO 50 k = 1, kk
2499 DO 40 i = 1, m
2500 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( k, j )
2501 g( i ) = g( i ) + abs1( a( k, i ) )*
2502 $ abs1( b( k, j ) )
2503 40 CONTINUE
2504 50 CONTINUE
2505 ELSE
2506 DO 70 k = 1, kk
2507 DO 60 i = 1, m
2508 ct( i ) = ct( i ) + a( k, i )*b( k, j )
2509 g( i ) = g( i ) + abs1( a( k, i ) )*
2510 $ abs1( b( k, j ) )
2511 60 CONTINUE
2512 70 CONTINUE
2513 END IF
2514 ELSE IF( .NOT.trana.AND.tranb )THEN
2515 IF( ctranb )THEN
2516 DO 90 k = 1, kk
2517 DO 80 i = 1, m
2518 ct( i ) = ct( i ) + a( i, k )*conjg( b( j, k ) )
2519 g( i ) = g( i ) + abs1( a( i, k ) )*
2520 $ abs1( b( j, k ) )
2521 80 CONTINUE
2522 90 CONTINUE
2523 ELSE
2524 DO 110 k = 1, kk
2525 DO 100 i = 1, m
2526 ct( i ) = ct( i ) + a( i, k )*b( j, k )
2527 g( i ) = g( i ) + abs1( a( i, k ) )*
2528 $ abs1( b( j, k ) )
2529 100 CONTINUE
2530 110 CONTINUE
2531 END IF
2532 ELSE IF( trana.AND.tranb )THEN
2533 IF( ctrana )THEN
2534 IF( ctranb )THEN
2535 DO 130 k = 1, kk
2536 DO 120 i = 1, m
2537 ct( i ) = ct( i ) + conjg( a( k, i ) )*
2538 $ conjg( b( j, k ) )
2539 g( i ) = g( i ) + abs1( a( k, i ) )*
2540 $ abs1( b( j, k ) )
2541 120 CONTINUE
2542 130 CONTINUE
2543 ELSE
2544 DO 150 k = 1, kk
2545 DO 140 i = 1, m
2546 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( j, k )
2547 g( i ) = g( i ) + abs1( a( k, i ) )*
2548 $ abs1( b( j, k ) )
2549 140 CONTINUE
2550 150 CONTINUE
2551 END IF
2552 ELSE
2553 IF( ctranb )THEN
2554 DO 170 k = 1, kk
2555 DO 160 i = 1, m
2556 ct( i ) = ct( i ) + a( k, i )*conjg( b( j, k ) )
2557 g( i ) = g( i ) + abs1( a( k, i ) )*
2558 $ abs1( b( j, k ) )
2559 160 CONTINUE
2560 170 CONTINUE
2561 ELSE
2562 DO 190 k = 1, kk
2563 DO 180 i = 1, m
2564 ct( i ) = ct( i ) + a( k, i )*b( j, k )
2565 g( i ) = g( i ) + abs1( a( k, i ) )*
2566 $ abs1( b( j, k ) )
2567 180 CONTINUE
2568 190 CONTINUE
2569 END IF
2570 END IF
2571 END IF
2572 DO 200 i = 1, m
2573 ct( i ) = alpha*ct( i ) + beta*c( i, j )
2574 g( i ) = abs1( alpha )*g( i ) +
2575 $ abs1( beta )*abs1( c( i, j ) )
2576 200 CONTINUE
2577*
2578* Compute the error ratio for this result.
2579*
2580 err = zero
2581 DO 210 i = 1, m
2582 erri = abs1( ct( i ) - cc( i, j ) )/eps
2583 IF( g( i ).NE.rzero )
2584 $ erri = erri/g( i )
2585 err = max( err, erri )
2586 IF( err*sqrt( eps ).GE.rone )
2587 $ GO TO 230
2588 210 CONTINUE
2589*
2590 220 CONTINUE
2591*
2592* If the loop completes, all results are at least half accurate.
2593 GO TO 250
2594*
2595* Report fatal error.
2596*
2597 230 fatal = .true.
2598 WRITE( nout, fmt = 9999 )
2599 DO 240 i = 1, m
2600 IF( mv )THEN
2601 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
2602 ELSE
2603 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
2604 END IF
2605 240 CONTINUE
2606 IF( n.GT.1 )
2607 $ WRITE( nout, fmt = 9997 )j
2608*
2609 250 CONTINUE
2610 RETURN
2611*
2612 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2613 $ 'F ACCURATE *******', /' EXPECTED RE',
2614 $ 'SULT COMPUTED RESULT' )
2615 9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
2616 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2617*
2618* End of CMMCH.
2619*

◆ cprcn1()

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

Definition at line 720 of file c_cblat3.f.

722 INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
723 COMPLEX ALPHA, BETA
724 CHARACTER*1 TRANSA, TRANSB
725 CHARACTER*12 SNAME
726 CHARACTER*14 CRC, CTA,CTB
727
728 IF (transa.EQ.'N')THEN
729 cta = ' CblasNoTrans'
730 ELSE IF (transa.EQ.'T')THEN
731 cta = ' CblasTrans'
732 ELSE
733 cta = 'CblasConjTrans'
734 END IF
735 IF (transb.EQ.'N')THEN
736 ctb = ' CblasNoTrans'
737 ELSE IF (transb.EQ.'T')THEN
738 ctb = ' CblasTrans'
739 ELSE
740 ctb = 'CblasConjTrans'
741 END IF
742 IF (iorder.EQ.1)THEN
743 crc = ' CblasRowMajor'
744 ELSE
745 crc = ' CblasColMajor'
746 END IF
747 WRITE(nout, fmt = 9995)nc,sname,crc, cta,ctb
748 WRITE(nout, fmt = 9994)m, n, k, alpha, lda, ldb, beta, ldc
749
750 9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
751 9994 FORMAT( 10x, 3( i3, ',' ) ,' (', f4.1,',',f4.1,') , A,',
752 $ i3, ', B,', i3, ', (', f4.1,',',f4.1,') , C,', i3, ').' )

◆ cprcn2()

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

Definition at line 1046 of file c_cblat3.f.

1048 INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC
1049 COMPLEX ALPHA, BETA
1050 CHARACTER*1 SIDE, UPLO
1051 CHARACTER*12 SNAME
1052 CHARACTER*14 CRC, CS,CU
1053
1054 IF (side.EQ.'L')THEN
1055 cs = ' CblasLeft'
1056 ELSE
1057 cs = ' CblasRight'
1058 END IF
1059 IF (uplo.EQ.'U')THEN
1060 cu = ' CblasUpper'
1061 ELSE
1062 cu = ' cblaslower'
1063 END IF
1064.EQ. IF (IORDER1)THEN
1065 CRC = ' cblasrowmajor'
1066 ELSE
1067 CRC = ' cblascolmajor'
1068 END IF
1069 WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
1070 WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC
1071
1072 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
1073 9994 FORMAT( 10X, 2( I3, ',' ),' (',F4.1,',',F4.1, '), a,', I3,
1074 $ ', b,', I3, ', (',F4.1,',',F4.1, '), ', 'c,', I3, ').' )

◆ cprcn3()

subroutine cprcn3 ( 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,
complex alpha,
integer lda,
integer ldb )

Definition at line 1398 of file c_cblat3.f.

1400 INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
1401 COMPLEX ALPHA
1402 CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
1403 CHARACTER*12 SNAME
1404 CHARACTER*14 CRC, CS, CU, CA, CD
1405
1406 IF (side.EQ.'L')THEN
1407 cs = ' CblasLeft'
1408 ELSE
1409 cs = ' CblasRight'
1410 END IF
1411 IF (uplo.EQ.'U')THEN
1412 cu = ' CblasUpper'
1413 ELSE
1414 cu = ' CblasLower'
1415 END IF
1416 IF (transa.EQ.'N')THEN
1417 ca = ' CblasNoTrans'
1418 ELSE IF (transa.EQ.'T')THEN
1419 ca = ' CblasTrans'
1420 ELSE
1421 ca = 'CblasConjTrans'
1422 END IF
1423 IF (diag.EQ.'N')THEN
1424 cd = ' CblasNonUnit'
1425 ELSE
1426 cd = ' CblasUnit'
1427 END IF
1428 IF (iorder.EQ.1)THEN
1429 crc = ' CblasRowMajor'
1430 ELSE
1431 crc = ' CblasColMajor'
1432 END IF
1433 WRITE(nout, fmt = 9995)nc,sname,crc, cs,cu
1434 WRITE(nout, fmt = 9994)ca, cd, m, n, alpha, lda, ldb
1435
1436 9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
1437 9994 FORMAT( 10x, 2( a14, ',') , 2( i3, ',' ), ' (', f4.1, ',',
1438 $ f4.1, '), A,', i3, ', B,', i3, ').' )

◆ cprcn4()

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

Definition at line 1784 of file c_cblat3.f.

1786 INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
1787 COMPLEX ALPHA, BETA
1788 CHARACTER*1 UPLO, TRANSA
1789 CHARACTER*12 SNAME
1790 CHARACTER*14 CRC, CU, CA
1791
1792 IF (uplo.EQ.'U')THEN
1793 cu = ' CblasUpper'
1794 ELSE
1795 cu = ' CblasLower'
1796 END IF
1797 IF (transa.EQ.'N')THEN
1798 ca = ' CblasNoTrans'
1799 ELSE IF (transa.EQ.'T')THEN
1800 ca = ' CblasTrans'
1801 ELSE
1802 ca = 'CblasConjTrans'
1803 END IF
1804 IF (iorder.EQ.1)THEN
1805 crc = ' CblasRowMajor'
1806 ELSE
1807 crc = ' CblasColMajor'
1808 END IF
1809 WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
1810 WRITE(nout, fmt = 9994)n, k, alpha, lda, beta, ldc
1811
1812 9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
1813 9994 FORMAT( 10x, 2( i3, ',' ), ' (', f4.1, ',', f4.1 ,'), A,',
1814 $ i3, ', (', f4.1,',', f4.1, '), C,', i3, ').' )

◆ cprcn5()

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

Definition at line 2237 of file c_cblat3.f.

2239 INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2240 COMPLEX ALPHA, BETA
2241 CHARACTER*1 UPLO, TRANSA
2242 CHARACTER*12 SNAME
2243 CHARACTER*14 CRC, CU, CA
2244
2245 IF (uplo.EQ.'U')THEN
2246 cu = ' CblasUpper'
2247 ELSE
2248 cu = ' CblasLower'
2249 END IF
2250 IF (transa.EQ.'N')THEN
2251 ca = ' CblasNoTrans'
2252 ELSE IF (transa.EQ.'T')THEN
2253 ca = ' CblasTrans'
2254 ELSE
2255 ca = 'CblasConjTrans'
2256 END IF
2257 IF (iorder.EQ.1)THEN
2258 crc = ' CblasRowMajor'
2259 ELSE
2260 crc = ' CblasColMajor'
2261 END IF
2262 WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
2263 WRITE(nout, fmt = 9994)n, k, alpha, lda, ldb, beta, ldc
2264
2265 9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
2266 9994 FORMAT( 10x, 2( i3, ',' ), ' (', f4.1, ',', f4.1, '), A,',
2267 $ i3, ', B', i3, ', (', f4.1, ',', f4.1, '), C,', i3, ').' )

◆ cprcn6()

subroutine cprcn6 ( 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 1818 of file c_cblat3.f.

1820 INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
1821 REAL ALPHA, BETA
1822 CHARACTER*1 UPLO, TRANSA
1823 CHARACTER*12 SNAME
1824 CHARACTER*14 CRC, CU, CA
1825
1826 IF (uplo.EQ.'U')THEN
1827 cu = ' CblasUpper'
1828 ELSE
1829 cu = ' CblasLower'
1830 END IF
1831 IF (transa.EQ.'n')THEN
1832 CA = ' cblasnotrans'
1833.EQ. ELSE IF (TRANSA't')THEN
1834 CA = ' cblastrans'
1835 ELSE
1836 CA = 'cblasconjtrans'
1837 END IF
1838.EQ. IF (IORDER1)THEN
1839 CRC = ' cblasrowmajor'
1840 ELSE
1841 CRC = ' cblascolmajor'
1842 END IF
1843 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
1844 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
1845
1846 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
1847 9994 FORMAT( 10X, 2( I3, ',' ),
1848 $ F4.1, ', a,', I3, ',', F4.1, ', c,', I3, ').' )

◆ cprcn7()

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

Definition at line 2271 of file c_cblat3.f.

2273 INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2274 COMPLEX ALPHA
2275 REAL BETA
2276 CHARACTER*1 UPLO, TRANSA
2277 CHARACTER*12 SNAME
2278 CHARACTER*14 CRC, CU, CA
2279
2280 IF (uplo.EQ.'U')THEN
2281 cu = ' cblasupper'
2282 ELSE
2283 CU = ' cblaslower'
2284 END IF
2285.EQ. IF (TRANSA'n')THEN
2286 CA = ' cblasnotrans'
2287.EQ. ELSE IF (TRANSA't')THEN
2288 CA = ' cblastrans'
2289 ELSE
2290 CA = 'cblasconjtrans'
2291 END IF
2292.EQ. IF (IORDER1)THEN
2293 CRC = ' cblasrowmajor'
2294 ELSE
2295 CRC = ' cblascolmajor'
2296 END IF
2297 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
2298 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
2299
2300 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
2301 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), a,',
2302 $ I3, ', b', I3, ',', F4.1, ', c,', I3, ').' )

◆ lce()

logical function lce ( complex, dimension( * ) ri,
complex, dimension( * ) rj,
integer lr )

Definition at line 2621 of file c_cblat3.f.

2622*
2623* Tests if two arrays are identical.
2624*
2625* Auxiliary routine for test program for Level 3 Blas.
2626*
2627* -- Written on 8-February-1989.
2628* Jack Dongarra, Argonne National Laboratory.
2629* Iain Duff, AERE Harwell.
2630* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2631* Sven Hammarling, Numerical Algorithms Group Ltd.
2632*
2633* .. Scalar Arguments ..
2634 INTEGER LR
2635* .. Array Arguments ..
2636 COMPLEX RI( * ), RJ( * )
2637* .. Local Scalars ..
2638 INTEGER I
2639* .. Executable Statements ..
2640 DO 10 i = 1, lr
2641 IF( ri( i ).NE.rj( i ) )
2642 $ GO TO 20
2643 10 CONTINUE
2644 lce = .true.
2645 GO TO 30
2646 20 CONTINUE
2647 lce = .false.
2648 30 RETURN
2649*
2650* End of LCE.
2651*

◆ lceres()

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

Definition at line 2653 of file c_cblat3.f.

2654*
2655* Tests if selected elements in two arrays are equal.
2656*
2657* TYPE is 'ge' or 'he' or 'sy'.
2658*
2659* Auxiliary routine for test program for Level 3 Blas.
2660*
2661* -- Written on 8-February-1989.
2662* Jack Dongarra, Argonne National Laboratory.
2663* Iain Duff, AERE Harwell.
2664* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2665* Sven Hammarling, Numerical Algorithms Group Ltd.
2666*
2667* .. Scalar Arguments ..
2668 INTEGER LDA, M, N
2669 CHARACTER*1 UPLO
2670 CHARACTER*2 TYPE
2671* .. Array Arguments ..
2672 COMPLEX AA( LDA, * ), AS( LDA, * )
2673* .. Local Scalars ..
2674 INTEGER I, IBEG, IEND, J
2675 LOGICAL UPPER
2676* .. Executable Statements ..
2677 upper = uplo.EQ.'U'
2678 IF( type.EQ.'ge' )THEN
2679 DO 20 j = 1, n
2680 DO 10 i = m + 1, lda
2681 IF( aa( i, j ).NE.as( i, j ) )
2682 $ GO TO 70
2683 10 CONTINUE
2684 20 CONTINUE
2685 ELSE IF( type.EQ.'he'.OR.type.EQ.'sy' )THEN
2686 DO 50 j = 1, n
2687 IF( upper )THEN
2688 ibeg = 1
2689 iend = j
2690 ELSE
2691 ibeg = j
2692 iend = n
2693 END IF
2694 DO 30 i = 1, ibeg - 1
2695 IF( aa( i, j ).NE.as( i, j ) )
2696 $ GO TO 70
2697 30 CONTINUE
2698 DO 40 i = iend + 1, lda
2699 IF( aa( i, j ).NE.as( i, j ) )
2700 $ GO TO 70
2701 40 CONTINUE
2702 50 CONTINUE
2703 END IF
2704*
2705 60 CONTINUE
2706 lceres = .true.
2707 GO TO 80
2708 70 CONTINUE
2709 lceres = .false.
2710 80 RETURN
2711*
2712* End of LCERES.
2713*

◆ sdiff()

real function sdiff ( real x,
real y )

Definition at line 2769 of file c_cblat3.f.

2770*
2771* Auxiliary routine for test program for Level 3 Blas.
2772*
2773* -- Written on 8-February-1989.
2774* Jack Dongarra, Argonne National Laboratory.
2775* Iain Duff, AERE Harwell.
2776* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2777* Sven Hammarling, Numerical Algorithms Group Ltd.
2778*
2779* .. Scalar Arguments ..
2780 REAL X, Y
2781* .. Executable Statements ..
2782 sdiff = x - y
2783 RETURN
2784*
2785* End of SDIFF.
2786*
sdiff
real function sdiff(x, y)
Definition c_cblat3.f:2770