/* Implementation of the MATMUL intrinsic
- Copyright (C) 2002-2018 Free Software Foundation, Inc.
+ Copyright (C) 2002-2020 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran runtime library (libgfortran).
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else if (GFC_DESCRIPTOR_RANK (b) == 1)
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 1:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 2:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 2 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
}
if (count != GFC_DESCRIPTOR_EXTENT(b,0))
{
if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0)
- runtime_error ("dimension of array B incorrect in MATMUL intrinsic");
+ runtime_error ("Incorrect extent in argument B in MATMUL intrinsic "
+ "in dimension 1: is %ld, should be %ld",
+ (long int) GFC_DESCRIPTOR_EXTENT(b,0), (long int) count);
}
if (GFC_DESCRIPTOR_RANK (b) == 1)
if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1)
{
assert (gemm != NULL);
- gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m,
+ const char *transa, *transb;
+ if (try_blas & 2)
+ transa = "C";
+ else
+ transa = axstride == 1 ? "N" : "T";
+
+ if (try_blas & 4)
+ transb = "C";
+ else
+ transb = bxstride == 1 ? "N" : "T";
+
+ gemm (transa, transb , &m,
&n, &k, &one, abase, &lda, bbase, &ldb, &zero, dest,
&ldc, 1, 1);
return;
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else if (GFC_DESCRIPTOR_RANK (b) == 1)
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 1:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 2:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 2 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
}
if (count != GFC_DESCRIPTOR_EXTENT(b,0))
{
if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0)
- runtime_error ("dimension of array B incorrect in MATMUL intrinsic");
+ runtime_error ("Incorrect extent in argument B in MATMUL intrinsic "
+ "in dimension 1: is %ld, should be %ld",
+ (long int) GFC_DESCRIPTOR_EXTENT(b,0), (long int) count);
}
if (GFC_DESCRIPTOR_RANK (b) == 1)
if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1)
{
assert (gemm != NULL);
- gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m,
+ const char *transa, *transb;
+ if (try_blas & 2)
+ transa = "C";
+ else
+ transa = axstride == 1 ? "N" : "T";
+
+ if (try_blas & 4)
+ transb = "C";
+ else
+ transb = bxstride == 1 ? "N" : "T";
+
+ gemm (transa, transb , &m,
&n, &k, &one, abase, &lda, bbase, &ldb, &zero, dest,
&ldc, 1, 1);
return;
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else if (GFC_DESCRIPTOR_RANK (b) == 1)
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 1:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 2:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 2 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
}
if (count != GFC_DESCRIPTOR_EXTENT(b,0))
{
if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0)
- runtime_error ("dimension of array B incorrect in MATMUL intrinsic");
+ runtime_error ("Incorrect extent in argument B in MATMUL intrinsic "
+ "in dimension 1: is %ld, should be %ld",
+ (long int) GFC_DESCRIPTOR_EXTENT(b,0), (long int) count);
}
if (GFC_DESCRIPTOR_RANK (b) == 1)
if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1)
{
assert (gemm != NULL);
- gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m,
+ const char *transa, *transb;
+ if (try_blas & 2)
+ transa = "C";
+ else
+ transa = axstride == 1 ? "N" : "T";
+
+ if (try_blas & 4)
+ transb = "C";
+ else
+ transb = bxstride == 1 ? "N" : "T";
+
+ gemm (transa, transb , &m,
&n, &k, &one, abase, &lda, bbase, &ldb, &zero, dest,
&ldc, 1, 1);
return;
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else if (GFC_DESCRIPTOR_RANK (b) == 1)
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 1:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 2:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 2 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
}
if (count != GFC_DESCRIPTOR_EXTENT(b,0))
{
if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0)
- runtime_error ("dimension of array B incorrect in MATMUL intrinsic");
+ runtime_error ("Incorrect extent in argument B in MATMUL intrinsic "
+ "in dimension 1: is %ld, should be %ld",
+ (long int) GFC_DESCRIPTOR_EXTENT(b,0), (long int) count);
}
if (GFC_DESCRIPTOR_RANK (b) == 1)
if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1)
{
assert (gemm != NULL);
- gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m,
+ const char *transa, *transb;
+ if (try_blas & 2)
+ transa = "C";
+ else
+ transa = axstride == 1 ? "N" : "T";
+
+ if (try_blas & 4)
+ transb = "C";
+ else
+ transb = bxstride == 1 ? "N" : "T";
+
+ gemm (transa, transb , &m,
&n, &k, &one, abase, &lda, bbase, &ldb, &zero, dest,
&ldc, 1, 1);
return;
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else if (GFC_DESCRIPTOR_RANK (b) == 1)
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic: is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
else
arg_extent = GFC_DESCRIPTOR_EXTENT(a,0);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 1:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 1 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
arg_extent = GFC_DESCRIPTOR_EXTENT(b,1);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1);
if (arg_extent != ret_extent)
- runtime_error ("Incorrect extent in return array in"
- " MATMUL intrinsic for dimension 2:"
- " is %ld, should be %ld",
+ runtime_error ("Array bound mismatch for dimension 2 of "
+ "array (%ld/%ld) ",
(long int) ret_extent, (long int) arg_extent);
}
}
if (count != GFC_DESCRIPTOR_EXTENT(b,0))
{
if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0)
- runtime_error ("dimension of array B incorrect in MATMUL intrinsic");
+ runtime_error ("Incorrect extent in argument B in MATMUL intrinsic "
+ "in dimension 1: is %ld, should be %ld",
+ (long int) GFC_DESCRIPTOR_EXTENT(b,0), (long int) count);
}
if (GFC_DESCRIPTOR_RANK (b) == 1)
if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1)
{
assert (gemm != NULL);
- gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m,
+ const char *transa, *transb;
+ if (try_blas & 2)
+ transa = "C";
+ else
+ transa = axstride == 1 ? "N" : "T";
+
+ if (try_blas & 4)
+ transb = "C";
+ else
+ transb = bxstride == 1 ? "N" : "T";
+
+ gemm (transa, transb , &m,
&n, &k, &one, abase, &lda, bbase, &ldb, &zero, dest,
&ldc, 1, 1);
return;