Skip to content

Commit 63d2b3a

Browse files
grisuthedragongrisuthedragon
committed
add cblas_sgemmtr tests
1 parent b681b1e commit 63d2b3a

File tree

6 files changed

+677
-174
lines changed

6 files changed

+677
-174
lines changed

‎BLAS/SRC/sgemmtr.f‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -272,8 +272,7 @@ SUBROUTINE SGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,
272272
*
273273
* Quick return if possible.
274274
*
275-
IF ((N.EQ.0) .OR.
276-
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
275+
IF (N.EQ.0) RETURN
277276
*
278277
* And if alpha.eq.zero.
279278
*

‎CBLAS/src/cblas_dgemmtr.c‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
11
/*
22
*
3-
* cblas_dgemm.c
4-
* This program is a C interface to dgemm.
5-
* Written by Keita Teranishi
6-
* 4/8/1998
3+
* cblas_dgemmtr.c
4+
* This program is a C interface to dgemmtr.
5+
* Written by Martin Koehler, MPI Magdeburg
6+
* 06/24/2024
77
*
88
*/
99

‎CBLAS/src/cblas_sgemmtr.c‎

Lines changed: 111 additions & 98 deletions
Original file line numberDiff line numberDiff line change
@@ -1,123 +1,136 @@
1+
12
/*
23
*
3-
* cblas_sgemm.c
4-
* This program is a C interface to sgemm.
5-
* Written by Keita Teranishi
6-
* 4/8/1998
4+
* cblas_sgemmtr.c
5+
* This program is a C interface to sgemmtr.
6+
* Written by Martin Koehler, MPI Magdeburg
7+
* 06/24/2024
78
*
89
*/
910

1011
#include "cblas.h"
1112
#include "cblas_f77.h"
1213
void API_SUFFIX(cblas_sgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA,
13-
const CBLAS_TRANSPOSE TransB, const CBLAS_INT N,
14-
const CBLAS_INT K, const float alpha, const float *A,
15-
const CBLAS_INT lda, const float *B, const CBLAS_INT ldb,
16-
const float beta, float *C, const CBLAS_INT ldc)
14+
const CBLAS_TRANSPOSE TransB, const CBLAS_INT N,
15+
const CBLAS_INT K, const float alpha, const float *A,
16+
const CBLAS_INT lda, const float *B, const CBLAS_INT ldb,
17+
const float beta, float *C, const CBLAS_INT ldc)
1718
{
18-
char TA, TB, UL;
19+
char TA, TB, UL;
1920
#ifdef F77_CHAR
20-
F77_CHAR F77_TA, F77_TB, F77_UL;
21+
F77_CHAR F77_TA, F77_TB, F77_UL;
2122
#else
22-
#define F77_TA &TA
23-
#define F77_TB &TB
24-
#define F77_UL &UL
23+
#define F77_TA &TA
24+
#define F77_TB &TB
25+
#define F77_UL &UL
2526
#endif
2627

2728
#ifdef F77_INT
28-
F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb;
29-
F77_INT F77_ldc=ldc;
29+
F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb;
30+
F77_INT F77_ldc=ldc;
3031
#else
31-
#define F77_N N
32-
#define F77_K K
33-
#define F77_lda lda
34-
#define F77_ldb ldb
35-
#define F77_ldc ldc
32+
#define F77_N N
33+
#define F77_K K
34+
#define F77_lda lda
35+
#define F77_ldb ldb
36+
#define F77_ldc ldc
3637
#endif
3738

38-
extern int CBLAS_CallFromC;
39-
extern int RowMajorStrg;
40-
RowMajorStrg = 0;
41-
CBLAS_CallFromC = 1;
39+
extern int CBLAS_CallFromC;
40+
extern int RowMajorStrg;
41+
RowMajorStrg = 0;
42+
CBLAS_CallFromC = 1;
43+
44+
45+
if( layout == CblasColMajor )
46+
{
47+
if ( Uplo == CblasUpper ) UL = 'U';
48+
else if (Uplo == CblasLower) UL= 'L';
49+
else {
50+
API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmtr", "Illegal Uplo setting, %d\n", Uplo);
51+
CBLAS_CallFromC = 0;
52+
RowMajorStrg = 0;
53+
return;
54+
}
55+
4256

43-
if ( Uplo == CblasUpper ) UL = 'U';
44-
else if (Uplo == CblasLower) UL= 'L';
45-
else {
46-
API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmtr", "Illegal Uplo setting, %d\n", Uplo);
47-
CBLAS_CallFromC = 0;
48-
RowMajorStrg = 0;
49-
return;
50-
}
57+
if(TransA == CblasTrans) TA='T';
58+
else if ( TransA == CblasConjTrans ) TA='C';
59+
else if ( TransA == CblasNoTrans ) TA='N';
60+
else
61+
{
62+
API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr",
63+
"Illegal TransA setting, %d\n", TransA);
64+
CBLAS_CallFromC = 0;
65+
RowMajorStrg = 0;
66+
return;
67+
}
5168

69+
if(TransB == CblasTrans) TB='T';
70+
else if ( TransB == CblasConjTrans ) TB='C';
71+
else if ( TransB == CblasNoTrans ) TB='N';
72+
else
73+
{
74+
API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr",
75+
"Illegal TransB setting, %d\n", TransB);
76+
CBLAS_CallFromC = 0;
77+
RowMajorStrg = 0;
78+
return;
79+
}
5280

53-
if( layout == CblasColMajor )
54-
{
55-
if(TransA == CblasTrans) TA='T';
56-
else if ( TransA == CblasConjTrans ) TA='C';
57-
else if ( TransA == CblasNoTrans ) TA='N';
58-
else
59-
{
60-
API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr",
61-
"Illegal TransA setting, %d\n", TransA);
62-
CBLAS_CallFromC = 0;
63-
RowMajorStrg = 0;
64-
return;
65-
}
81+
#ifdef F77_CHAR
82+
F77_TA = C2F_CHAR(&TA);
83+
F77_TB = C2F_CHAR(&TB);
84+
F77_UL = C2F_CHAR(&UL);
85+
#endif
6686

67-
if(TransB == CblasTrans) TB='T';
68-
else if ( TransB == CblasConjTrans ) TB='C';
69-
else if ( TransB == CblasNoTrans ) TB='N';
70-
else
71-
{
72-
API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr",
73-
"Illegal TransB setting, %d\n", TransB);
74-
CBLAS_CallFromC = 0;
75-
RowMajorStrg = 0;
76-
return;
77-
}
87+
F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc);
88+
}
89+
else if (layout == CblasRowMajor)
90+
{
91+
if ( Uplo == CblasUpper ) UL = 'L';
92+
else if (Uplo == CblasLower) UL= 'U';
93+
else {
94+
API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmtr", "Illegal Uplo setting, %d\n", Uplo);
95+
CBLAS_CallFromC = 0;
96+
RowMajorStrg = 0;
97+
return;
98+
}
7899

79-
#ifdef F77_CHAR
80-
F77_TA = C2F_CHAR(&TA);
81-
F77_TB = C2F_CHAR(&TB);
82-
F77_UL = C2F_CHAR(&UL);
83-
#endif
84100

85-
F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc);
86-
} else if (layout == CblasRowMajor)
87-
{
88-
RowMajorStrg = 1;
89-
if(TransA == CblasTrans) TB='T';
90-
else if ( TransA == CblasConjTrans ) TB='C';
91-
else if ( TransA == CblasNoTrans ) TB='N';
92-
else
93-
{
94-
API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr",
95-
"Illegal TransA setting, %d\n", TransA);
96-
CBLAS_CallFromC = 0;
97-
RowMajorStrg = 0;
98-
return;
99-
}
100-
if(TransB == CblasTrans) TA='T';
101-
else if ( TransB == CblasConjTrans ) TA='C';
102-
else if ( TransB == CblasNoTrans ) TA='N';
103-
else
104-
{
105-
API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr",
106-
"Illegal TransB setting, %d\n", TransB);
107-
CBLAS_CallFromC = 0;
108-
RowMajorStrg = 0;
109-
return;
110-
}
111-
#ifdef F77_CHAR
112-
F77_TA = C2F_CHAR(&TA);
113-
F77_TB = C2F_CHAR(&TB);
114-
F77_UL = C2F_CHAR(&UL);
115-
#endif
101+
RowMajorStrg = 1;
102+
if(TransA == CblasTrans) TB='T';
103+
else if ( TransA == CblasConjTrans ) TB='C';
104+
else if ( TransA == CblasNoTrans ) TB='N';
105+
else
106+
{
107+
API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr",
108+
"Illegal TransA setting, %d\n", TransA);
109+
CBLAS_CallFromC = 0;
110+
RowMajorStrg = 0;
111+
return;
112+
}
113+
if(TransB == CblasTrans) TA='T';
114+
else if ( TransB == CblasConjTrans ) TA='C';
115+
else if ( TransB == CblasNoTrans ) TA='N';
116+
else
117+
{
118+
API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr",
119+
"Illegal TransB setting, %d\n", TransB);
120+
CBLAS_CallFromC = 0;
121+
RowMajorStrg = 0;
122+
return;
123+
}
124+
#ifdef F77_CHAR
125+
F77_TA = C2F_CHAR(&TA);
126+
F77_TB = C2F_CHAR(&TB);
127+
F77_UL = C2F_CHAR(&UL);
128+
#endif
116129

117-
F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc);
118-
} else
119-
API_SUFFIX(cblas_xerbla)(1, "cblas_sgemmtr",
120-
"Illegal layout setting, %d\n", layout);
121-
CBLAS_CallFromC = 0;
122-
RowMajorStrg = 0;
130+
F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc);
131+
} else
132+
API_SUFFIX(cblas_xerbla)(1, "cblas_sgemmtr",
133+
"Illegal layout setting, %d\n", layout);
134+
CBLAS_CallFromC = 0;
135+
RowMajorStrg = 0;
123136
}

‎CBLAS/testing/c_sblas3.c‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -75,7 +75,7 @@ void F77_sgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB
7575
b, *ldb, *beta, c, *ldc );
7676
}
7777

78-
void F77_cgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n,
78+
void F77_sgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n,
7979
CBLAS_INT *k, float *alpha, float *a, CBLAS_INT *lda,
8080
float *b, CBLAS_INT *ldb, float *beta,
8181
float *c, CBLAS_INT *ldc ) {

0 commit comments

Comments
 (0)