mirror of
https://github.com/jart/cosmopolitan.git
synced 2025-10-08 13:51:38 +00:00
Initial import
This commit is contained in:
Justine Tunney
commit
c91b3c5006
14915 changed files with 590219 additions and 0 deletions
13
third_party/blas/blas.h
vendored
Normal file
13
third_party/blas/blas.h
vendored
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
#ifndef COSMOPOLITAN_THIRD_PARTY_BLAS_BLAS_H_
|
||||
#define COSMOPOLITAN_THIRD_PARTY_BLAS_BLAS_H_
|
||||
#if !(__ASSEMBLER__ + __LINKER__ + 0)
|
||||
COSMOPOLITAN_C_START_
|
||||
|
||||
int dgemm_(char *transa, char *transb, long *m, long *n, long *k, double *alpha,
|
||||
double *A /*['N'?k:m][1≤m≤lda]*/, long *lda,
|
||||
double *B /*['N'?k:n][1≤n≤ldb]*/, long *ldb, double *beta,
|
||||
double *C /*[n][1≤m≤ldc]*/, long *ldc);
|
||||
|
||||
COSMOPOLITAN_C_END_
|
||||
#endif /* !(__ASSEMBLER__ + __LINKER__ + 0) */
|
||||
#endif /* COSMOPOLITAN_THIRD_PARTY_BLAS_BLAS_H_ */
|
||||
59
third_party/blas/blas.mk
vendored
Normal file
59
third_party/blas/blas.mk
vendored
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
#-*-mode:makefile-gmake;indent-tabs-mode:t;tab-width:8;coding:utf-8-*-┐
|
||||
#───vi: set et ft=make ts=8 tw=8 fenc=utf-8 :vi───────────────────────┘
|
||||
|
||||
PKGS += THIRD_PARTY_BLAS
|
||||
|
||||
THIRD_PARTY_BLAS_ARTIFACTS += THIRD_PARTY_BLAS_A
|
||||
THIRD_PARTY_BLAS = $(THIRD_PARTY_BLAS_A_DEPS) $(THIRD_PARTY_BLAS_A)
|
||||
THIRD_PARTY_BLAS_A = o/$(MODE)/third_party/blas/blas.a
|
||||
THIRD_PARTY_BLAS_A_FILES := $(wildcard third_party/blas/*)
|
||||
THIRD_PARTY_BLAS_A_HDRS = $(filter %.h,$(THIRD_PARTY_BLAS_A_FILES))
|
||||
THIRD_PARTY_BLAS_A_SRCS_S = $(filter %.S,$(THIRD_PARTY_BLAS_A_FILES))
|
||||
THIRD_PARTY_BLAS_A_SRCS_C = $(filter %.c,$(THIRD_PARTY_BLAS_A_FILES))
|
||||
|
||||
THIRD_PARTY_BLAS_A_SRCS = \
|
||||
$(THIRD_PARTY_BLAS_A_SRCS_S) \
|
||||
$(THIRD_PARTY_BLAS_A_SRCS_C)
|
||||
|
||||
THIRD_PARTY_BLAS_A_OBJS = \
|
||||
$(THIRD_PARTY_BLAS_A_SRCS:%=o/$(MODE)/%.zip.o) \
|
||||
$(THIRD_PARTY_BLAS_A_SRCS_S:%.S=o/$(MODE)/%.o) \
|
||||
$(THIRD_PARTY_BLAS_A_SRCS_C:%.c=o/$(MODE)/%.o)
|
||||
|
||||
THIRD_PARTY_BLAS_A_CHECKS = \
|
||||
$(THIRD_PARTY_BLAS_A).pkg \
|
||||
$(THIRD_PARTY_BLAS_A_HDRS:%=o/$(MODE)/%.ok)
|
||||
|
||||
THIRD_PARTY_BLAS_A_DIRECTDEPS = \
|
||||
LIBC_STUBS \
|
||||
LIBC_NEXGEN32E \
|
||||
THIRD_PARTY_F2C
|
||||
|
||||
THIRD_PARTY_BLAS_A_DEPS := \
|
||||
$(call uniq,$(foreach x,$(THIRD_PARTY_BLAS_A_DIRECTDEPS),$($(x))))
|
||||
|
||||
$(THIRD_PARTY_BLAS_A_OBJS): \
|
||||
OVERRIDE_CFLAGS += \
|
||||
-O3 #$(MATHEMATICAL)
|
||||
|
||||
#$(THIRD_PARTY_BLAS_A_OBJS): \
|
||||
CC = $(CLANG)
|
||||
|
||||
$(THIRD_PARTY_BLAS_A): \
|
||||
third_party/blas/ \
|
||||
$(THIRD_PARTY_BLAS_A).pkg \
|
||||
$(THIRD_PARTY_BLAS_A_OBJS)
|
||||
|
||||
$(THIRD_PARTY_BLAS_A).pkg: \
|
||||
$(THIRD_PARTY_BLAS_A_OBJS) \
|
||||
$(foreach x,$(THIRD_PARTY_BLAS_A_DIRECTDEPS),$($(x)_A).pkg)
|
||||
|
||||
THIRD_PARTY_BLAS_LIBS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)))
|
||||
THIRD_PARTY_BLAS_SRCS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_SRCS))
|
||||
THIRD_PARTY_BLAS_HDRS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_HDRS))
|
||||
THIRD_PARTY_BLAS_CHECKS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_CHECKS))
|
||||
THIRD_PARTY_BLAS_OBJS = $(foreach x,$(THIRD_PARTY_BLAS_ARTIFACTS),$($(x)_OBJS))
|
||||
$(THIRD_PARTY_BLAS_OBJS): $(BUILD_FILES) third_party/blas/blas.mk
|
||||
|
||||
.PHONY: o/$(MODE)/third_party/blas
|
||||
o/$(MODE)/third_party/blas: $(THIRD_PARTY_BLAS_CHECKS)
|
||||
384
third_party/blas/dgemm.f
vendored
Normal file
384
third_party/blas/dgemm.f
vendored
Normal file
|
|
@ -0,0 +1,384 @@
|
|||
*> \brief \b DGEMM
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* DOUBLE PRECISION ALPHA,BETA
|
||||
* INTEGER K,LDA,LDB,LDC,M,N
|
||||
* CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> DGEMM performs one of the matrix-matrix operations
|
||||
*>
|
||||
*> C := alpha*op( A )*op( B ) + beta*C,
|
||||
*>
|
||||
*> where op( X ) is one of
|
||||
*>
|
||||
*> op( X ) = X or op( X ) = X**T,
|
||||
*>
|
||||
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
||||
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] TRANSA
|
||||
*> \verbatim
|
||||
*> TRANSA is CHARACTER*1
|
||||
*> On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSA = 'N' or 'n', op( A ) = A.
|
||||
*>
|
||||
*> TRANSA = 'T' or 't', op( A ) = A**T.
|
||||
*>
|
||||
*> TRANSA = 'C' or 'c', op( A ) = A**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] TRANSB
|
||||
*> \verbatim
|
||||
*> TRANSB is CHARACTER*1
|
||||
*> On entry, TRANSB specifies the form of op( B ) to be used in
|
||||
*> the matrix multiplication as follows:
|
||||
*>
|
||||
*> TRANSB = 'N' or 'n', op( B ) = B.
|
||||
*>
|
||||
*> TRANSB = 'T' or 't', op( B ) = B**T.
|
||||
*>
|
||||
*> TRANSB = 'C' or 'c', op( B ) = B**T.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] M
|
||||
*> \verbatim
|
||||
*> M is INTEGER
|
||||
*> On entry, M specifies the number of rows of the matrix
|
||||
*> op( A ) and of the matrix C. M must be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] N
|
||||
*> \verbatim
|
||||
*> N is INTEGER
|
||||
*> On entry, N specifies the number of columns of the matrix
|
||||
*> op( B ) and the number of columns of the matrix C. N must be
|
||||
*> at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] K
|
||||
*> \verbatim
|
||||
*> K is INTEGER
|
||||
*> On entry, K specifies the number of columns of the matrix
|
||||
*> op( A ) and the number of rows of the matrix op( B ). K must
|
||||
*> be at least zero.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is DOUBLE PRECISION.
|
||||
*> On entry, ALPHA specifies the scalar alpha.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] A
|
||||
*> \verbatim
|
||||
*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is
|
||||
*> k when TRANSA = 'N' or 'n', and is m otherwise.
|
||||
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
|
||||
*> part of the array A must contain the matrix A, otherwise
|
||||
*> the leading k by m part of the array A must contain the
|
||||
*> matrix A.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDA
|
||||
*> \verbatim
|
||||
*> LDA is INTEGER
|
||||
*> On entry, LDA specifies the first dimension of A as declared
|
||||
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
||||
*> LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
*> least max( 1, k ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] B
|
||||
*> \verbatim
|
||||
*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is
|
||||
*> n when TRANSB = 'N' or 'n', and is k otherwise.
|
||||
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
|
||||
*> part of the array B must contain the matrix B, otherwise
|
||||
*> the leading n by k part of the array B must contain the
|
||||
*> matrix B.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDB
|
||||
*> \verbatim
|
||||
*> LDB is INTEGER
|
||||
*> On entry, LDB specifies the first dimension of B as declared
|
||||
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
||||
*> LDB must be at least max( 1, k ), otherwise LDB must be at
|
||||
*> least max( 1, n ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] BETA
|
||||
*> \verbatim
|
||||
*> BETA is DOUBLE PRECISION.
|
||||
*> On entry, BETA specifies the scalar beta. When BETA is
|
||||
*> supplied as zero then C need not be set on input.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] C
|
||||
*> \verbatim
|
||||
*> C is DOUBLE PRECISION array, dimension ( LDC, N )
|
||||
*> Before entry, the leading m by n part of the array C must
|
||||
*> contain the matrix C, except when beta is zero, in which
|
||||
*> case C need not be set on entry.
|
||||
*> On exit, the array C is overwritten by the m by n matrix
|
||||
*> ( alpha*op( A )*op( B ) + beta*C ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDC
|
||||
*> \verbatim
|
||||
*> LDC is INTEGER
|
||||
*> On entry, LDC specifies the first dimension of C as declared
|
||||
*> in the calling (sub) program. LDC must be at least
|
||||
*> max( 1, m ).
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date December 2016
|
||||
*
|
||||
*> \ingroup double_blas_level3
|
||||
*
|
||||
*> \par Further Details:
|
||||
* =====================
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> Level 3 Blas routine.
|
||||
*>
|
||||
*> -- Written on 8-February-1989.
|
||||
*> Jack Dongarra, Argonne National Laboratory.
|
||||
*> Iain Duff, AERE Harwell.
|
||||
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
*> Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*> \endverbatim
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
*
|
||||
* -- Reference BLAS level3 routine (version 3.7.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* December 2016
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,M,N
|
||||
CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
|
||||
LOGICAL NOTA,NOTB
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Set NOTA and NOTB as true if A and B respectively are not
|
||||
* transposed and set NROWA, NCOLA and NROWB as the number of rows
|
||||
* and columns of A and the number of rows of B respectively.
|
||||
*
|
||||
NOTA = LSAME(TRANSA,'N')
|
||||
NOTB = LSAME(TRANSB,'N')
|
||||
IF (NOTA) THEN
|
||||
NROWA = M
|
||||
NCOLA = K
|
||||
ELSE
|
||||
NROWA = K
|
||||
NCOLA = M
|
||||
END IF
|
||||
IF (NOTB) THEN
|
||||
NROWB = K
|
||||
ELSE
|
||||
NROWB = N
|
||||
END IF
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSB,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
|
||||
INFO = 10
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And if alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (NOTB) THEN
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
DO 90 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 50 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 60 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
DO 80 L = 1,K
|
||||
TEMP = ALPHA*B(L,J)
|
||||
DO 70 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + beta*C
|
||||
*
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 100 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(L,J)
|
||||
100 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + beta*C
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
130 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 140 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
140 CONTINUE
|
||||
END IF
|
||||
DO 160 L = 1,K
|
||||
TEMP = ALPHA*B(J,L)
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B**T + beta*C
|
||||
*
|
||||
DO 200 J = 1,N
|
||||
DO 190 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 180 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(J,L)
|
||||
180 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGEMM .
|
||||
*
|
||||
END
|
||||
1102
third_party/blas/dgemm_.S
vendored
Normal file
1102
third_party/blas/dgemm_.S
vendored
Normal file
File diff suppressed because it is too large
Load diff
155
third_party/blas/lsame.c
vendored
Normal file
155
third_party/blas/lsame.c
vendored
Normal file
|
|
@ -0,0 +1,155 @@
|
|||
/* lsame.f -- translated by f2c (version 20191129).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "third_party/f2c/f2c.h"
|
||||
|
||||
/* > \brief \b LSAME */
|
||||
|
||||
/* =========== DOCUMENTATION =========== */
|
||||
|
||||
/* Online html documentation available at */
|
||||
/* http://www.netlib.org/lapack/explore-html/ */
|
||||
|
||||
/* Definition: */
|
||||
/* =========== */
|
||||
|
||||
/* LOGICAL FUNCTION LSAME(CA,CB) */
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* CHARACTER CA,CB */
|
||||
/* .. */
|
||||
|
||||
/* > \par Purpose: */
|
||||
/* ============= */
|
||||
/* > */
|
||||
/* > \verbatim */
|
||||
/* > */
|
||||
/* > LSAME returns .TRUE. if CA is the same letter as CB regardless of */
|
||||
/* > case. */
|
||||
/* > \endverbatim */
|
||||
|
||||
/* Arguments: */
|
||||
/* ========== */
|
||||
|
||||
/* > \param[in] CA */
|
||||
/* > \verbatim */
|
||||
/* > CA is CHARACTER*1 */
|
||||
/* > \endverbatim */
|
||||
/* > */
|
||||
/* > \param[in] CB */
|
||||
/* > \verbatim */
|
||||
/* > CB is CHARACTER*1 */
|
||||
/* > CA and CB specify the single characters to be compared. */
|
||||
/* > \endverbatim */
|
||||
|
||||
/* Authors: */
|
||||
/* ======== */
|
||||
|
||||
/* > \author Univ. of Tennessee */
|
||||
/* > \author Univ. of California Berkeley */
|
||||
/* > \author Univ. of Colorado Denver */
|
||||
/* > \author NAG Ltd. */
|
||||
|
||||
/* > \date December 2016 */
|
||||
|
||||
/* > \ingroup aux_blas */
|
||||
|
||||
/* ===================================================================== */
|
||||
logical lsame_(char *ca, char *cb) {
|
||||
/* System generated locals */
|
||||
logical ret_val;
|
||||
|
||||
/* Local variables */
|
||||
static integer inta, intb, zcode;
|
||||
|
||||
/* -- Reference BLAS level1 routine (version 3.1) -- */
|
||||
/* -- Reference BLAS is a software package provided by Univ. of Tennessee,
|
||||
* -- */
|
||||
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
*/
|
||||
/* December 2016 */
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* .. */
|
||||
/* .. Local Scalars .. */
|
||||
/* .. */
|
||||
|
||||
/* Test if the characters are equal */
|
||||
|
||||
ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
|
||||
if (ret_val) {
|
||||
return ret_val;
|
||||
}
|
||||
|
||||
/* Now test for equivalence if both characters are alphabetic. */
|
||||
|
||||
zcode = 'Z';
|
||||
|
||||
/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
|
||||
/* machines, on which ICHAR returns a value with bit 8 set. */
|
||||
/* ICHAR('A') on Prime machines returns 193 which is the same as */
|
||||
/* ICHAR('A') on an EBCDIC machine. */
|
||||
|
||||
inta = *(unsigned char *)ca;
|
||||
intb = *(unsigned char *)cb;
|
||||
|
||||
if (zcode == 90 || zcode == 122) {
|
||||
|
||||
/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
|
||||
/* upper case 'Z'. */
|
||||
|
||||
if (inta >= 97 && inta <= 122) {
|
||||
inta += -32;
|
||||
}
|
||||
if (intb >= 97 && intb <= 122) {
|
||||
intb += -32;
|
||||
}
|
||||
|
||||
} else if (zcode == 233 || zcode == 169) {
|
||||
|
||||
/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
|
||||
/* upper case 'Z'. */
|
||||
|
||||
if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 ||
|
||||
inta >= 162 && inta <= 169) {
|
||||
inta += 64;
|
||||
}
|
||||
if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 ||
|
||||
intb >= 162 && intb <= 169) {
|
||||
intb += 64;
|
||||
}
|
||||
|
||||
} else if (zcode == 218 || zcode == 250) {
|
||||
|
||||
/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
|
||||
/* plus 128 of either lower or upper case 'Z'. */
|
||||
|
||||
if (inta >= 225 && inta <= 250) {
|
||||
inta += -32;
|
||||
}
|
||||
if (intb >= 225 && intb <= 250) {
|
||||
intb += -32;
|
||||
}
|
||||
}
|
||||
ret_val = inta == intb;
|
||||
|
||||
/* RETURN */
|
||||
|
||||
/* End of LSAME */
|
||||
|
||||
return ret_val;
|
||||
} /* lsame_ */
|
||||
125
third_party/blas/lsame.f
vendored
Normal file
125
third_party/blas/lsame.f
vendored
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
*> \brief \b LSAME
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* LOGICAL FUNCTION LSAME(CA,CB)
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER CA,CB
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> LSAME returns .TRUE. if CA is the same letter as CB regardless of
|
||||
*> case.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] CA
|
||||
*> \verbatim
|
||||
*> CA is CHARACTER*1
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] CB
|
||||
*> \verbatim
|
||||
*> CB is CHARACTER*1
|
||||
*> CA and CB specify the single characters to be compared.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date December 2016
|
||||
*
|
||||
*> \ingroup aux_blas
|
||||
*
|
||||
* =====================================================================
|
||||
LOGICAL FUNCTION LSAME(CA,CB)
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.1) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* December 2016
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER CA,CB
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ICHAR
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER INTA,INTB,ZCODE
|
||||
* ..
|
||||
*
|
||||
* Test if the characters are equal
|
||||
*
|
||||
LSAME = CA .EQ. CB
|
||||
IF (LSAME) RETURN
|
||||
*
|
||||
* Now test for equivalence if both characters are alphabetic.
|
||||
*
|
||||
ZCODE = ICHAR('Z')
|
||||
*
|
||||
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
|
||||
* machines, on which ICHAR returns a value with bit 8 set.
|
||||
* ICHAR('A') on Prime machines returns 193 which is the same as
|
||||
* ICHAR('A') on an EBCDIC machine.
|
||||
*
|
||||
INTA = ICHAR(CA)
|
||||
INTB = ICHAR(CB)
|
||||
*
|
||||
IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
|
||||
*
|
||||
* ASCII is assumed - ZCODE is the ASCII code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
|
||||
IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
|
||||
*
|
||||
ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
|
||||
*
|
||||
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
|
||||
* upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
|
||||
+ INTA.GE.145 .AND. INTA.LE.153 .OR.
|
||||
+ INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
|
||||
IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
|
||||
+ INTB.GE.145 .AND. INTB.LE.153 .OR.
|
||||
+ INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
|
||||
*
|
||||
ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
|
||||
*
|
||||
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
|
||||
* plus 128 of either lower or upper case 'Z'.
|
||||
*
|
||||
IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
|
||||
IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
|
||||
END IF
|
||||
LSAME = INTA .EQ. INTB
|
||||
*
|
||||
* RETURN
|
||||
*
|
||||
* End of LSAME
|
||||
*
|
||||
END
|
||||
121
third_party/blas/xerbla.c
vendored
Normal file
121
third_party/blas/xerbla.c
vendored
Normal file
|
|
@ -0,0 +1,121 @@
|
|||
/* xerbla.f -- translated by f2c (version 20191129).
|
||||
You must link the resulting object file with libf2c:
|
||||
on Microsoft Windows system, link with libf2c.lib;
|
||||
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
||||
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
||||
-- in that order, at the end of the command line, as in
|
||||
cc *.o -lf2c -lm
|
||||
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
||||
|
||||
http://www.netlib.org/f2c/libf2c.zip
|
||||
*/
|
||||
|
||||
#include "third_party/f2c/f2c.h"
|
||||
|
||||
/* Table of constant values */
|
||||
|
||||
static integer c__1 = 1;
|
||||
|
||||
/* > \brief \b XERBLA */
|
||||
|
||||
/* =========== DOCUMENTATION =========== */
|
||||
|
||||
/* Online html documentation available at */
|
||||
/* http://www.netlib.org/lapack/explore-html/ */
|
||||
|
||||
/* Definition: */
|
||||
/* =========== */
|
||||
|
||||
/* SUBROUTINE XERBLA( SRNAME, INFO ) */
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* CHARACTER*(*) SRNAME */
|
||||
/* INTEGER INFO */
|
||||
/* .. */
|
||||
|
||||
/* > \par Purpose: */
|
||||
/* ============= */
|
||||
/* > */
|
||||
/* > \verbatim */
|
||||
/* > */
|
||||
/* > XERBLA is an error handler for the LAPACK routines. */
|
||||
/* > It is called by an LAPACK routine if an input parameter has an */
|
||||
/* > invalid value. A message is printed and execution stops. */
|
||||
/* > */
|
||||
/* > Installers may consider modifying the STOP statement in order to */
|
||||
/* > call system-specific exception-handling facilities. */
|
||||
/* > \endverbatim */
|
||||
|
||||
/* Arguments: */
|
||||
/* ========== */
|
||||
|
||||
/* > \param[in] SRNAME */
|
||||
/* > \verbatim */
|
||||
/* > SRNAME is CHARACTER*(*) */
|
||||
/* > The name of the routine which called XERBLA. */
|
||||
/* > \endverbatim */
|
||||
/* > */
|
||||
/* > \param[in] INFO */
|
||||
/* > \verbatim */
|
||||
/* > INFO is INTEGER */
|
||||
/* > The position of the invalid parameter in the parameter list */
|
||||
/* > of the calling routine. */
|
||||
/* > \endverbatim */
|
||||
|
||||
/* Authors: */
|
||||
/* ======== */
|
||||
|
||||
/* > \author Univ. of Tennessee */
|
||||
/* > \author Univ. of California Berkeley */
|
||||
/* > \author Univ. of Colorado Denver */
|
||||
/* > \author NAG Ltd. */
|
||||
|
||||
/* > \date December 2016 */
|
||||
|
||||
/* > \ingroup aux_blas */
|
||||
|
||||
/* ===================================================================== */
|
||||
/* Subroutine */ int xerbla_(char *srname, integer *info, ftnlen srname_len) {
|
||||
/* Format strings */
|
||||
static char fmt_9999[] =
|
||||
"(\002 ** On entry to \002,a,\002 parameter num"
|
||||
"ber \002,i2,\002 had \002,\002an illegal value\002)";
|
||||
|
||||
/* Builtin functions */
|
||||
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
|
||||
/* Subroutine */ int s_stop(char *, ftnlen);
|
||||
|
||||
/* Local variables */
|
||||
extern doublereal trmlen_(char *, ftnlen);
|
||||
|
||||
/* Fortran I/O blocks */
|
||||
static cilist io___1 = {0, 6, 0, fmt_9999, 0};
|
||||
|
||||
/* -- Reference BLAS level1 routine (version 3.7.0) -- */
|
||||
/* -- Reference BLAS is a software package provided by Univ. of Tennessee,
|
||||
* -- */
|
||||
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
*/
|
||||
/* December 2016 */
|
||||
|
||||
/* .. Scalar Arguments .. */
|
||||
/* .. */
|
||||
|
||||
/* ===================================================================== */
|
||||
|
||||
/* .. Intrinsic Functions .. */
|
||||
/* INTRINSIC LEN_TRIM */
|
||||
/* .. */
|
||||
/* .. Executable Statements .. */
|
||||
|
||||
s_wsfe(&io___1);
|
||||
do_fio(&c__1, srname, (integer)trmlen_(srname, srname_len));
|
||||
do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
|
||||
e_wsfe();
|
||||
|
||||
s_stop("", (ftnlen)0);
|
||||
|
||||
/* End of XERBLA */
|
||||
|
||||
return 0;
|
||||
} /* xerbla_ */
|
||||
89
third_party/blas/xerbla.f
vendored
Normal file
89
third_party/blas/xerbla.f
vendored
Normal file
|
|
@ -0,0 +1,89 @@
|
|||
*> \brief \b XERBLA
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE XERBLA( SRNAME, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* CHARACTER*(*) SRNAME
|
||||
* INTEGER INFO
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> XERBLA is an error handler for the LAPACK routines.
|
||||
*> It is called by an LAPACK routine if an input parameter has an
|
||||
*> invalid value. A message is printed and execution stops.
|
||||
*>
|
||||
*> Installers may consider modifying the STOP statement in order to
|
||||
*> call system-specific exception-handling facilities.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] SRNAME
|
||||
*> \verbatim
|
||||
*> SRNAME is CHARACTER*(*)
|
||||
*> The name of the routine which called XERBLA.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> The position of the invalid parameter in the parameter list
|
||||
*> of the calling routine.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date December 2016
|
||||
*
|
||||
*> \ingroup aux_blas
|
||||
*
|
||||
* =====================================================================
|
||||
SUBROUTINE XERBLA( SRNAME, INFO )
|
||||
*
|
||||
* -- Reference BLAS level1 routine (version 3.7.0) --
|
||||
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* December 2016
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
CHARACTER*(*) SRNAME
|
||||
INTEGER INFO
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Intrinsic Functions ..
|
||||
* INTRINSIC LEN_TRIM
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
WRITE( *, FMT = 9999 )SRNAME( 1:TRMLEN( SRNAME ) ), INFO
|
||||
*
|
||||
STOP
|
||||
*
|
||||
9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
|
||||
$ 'an illegal value' )
|
||||
*
|
||||
* End of XERBLA
|
||||
*
|
||||
END
|
||||
Loading…
Add table
Add a link
Reference in a new issue